ape/0000755000176200001440000000000014166047412011024 5ustar liggesusersape/NAMESPACE0000644000176200001440000002614414164530562012253 0ustar liggesusersuseDynLib(ape, .registration = TRUE) export(.compressTipLabel, .PlotPhyloEnv, .uncompressTipLabel, "[.DNAbin", AAsubst, abbreviateGenus, ace, add.scale.bar, additive, alex, all.equal.DNAbin, all.equal.phylo, alview, arecompatible, as.AAbin, as.AAbin.character, as.alignment, as.bitsplits, as.bitsplits.prop.part, as.character.AAbin, as.character.DNAbin, as.DNAbin, as.DNAbin.alignment, as.DNAbin.character, as.DNAbin.list, as.evonet, as.evonet.phylo, as.hclust.phylo, as.igraph.evonet, as.igraph.phylo, as.list.AAbin, as.list.DNAbin, as.matching, as.matching.phylo, as.matrix.DNAbin, as.network.evonet, as.network.phylo, as.networx.evonet, as.phyDat.AAbin, as.phylo, as.phylo.evonet, as.phylo.formula, as.phylo.hclust, as.phylo.matching, as.phylo.phylog, as.prop.part, axisPhylo, balance, base.freq, bd.ext, bd.time, binaryPGLMM, binaryPGLMM.sim, bind.tree, bionj, bionjs, biplot.pcoa, birthdeath, bitsplits, boot.phylo, BOTHlabels, branching.times, bydir, c.DNAbin, CADM.global, CADM.post, cbind.DNAbin, checkAlignment, checkLabel, checkValidPhylo, cherry, chronoMPL, chronopl, chronos, chronos.control, circular.plot, cladewise, cladogram.plot, clustal, clustalomega, coalescent.intervals, collapse.singles, collapsed.intervals, compar.cheverud, compar.gee, compar.lynch, compar.ou, comparePhylo, complement, compute.brlen, compute.brtime, consensus, cophenetic.phylo, cophyloplot, corBlomberg, corBrownian, corGrafen, corMartins, corPagel, corphylo, correlogram.formula, countBipartitions, dbd, dbdTime, def, degree, del.colgapsonly, del.gaps, del.rowgapsonly, delta.plot, deviance.ace, di2multi, di2multi.multiPhylo, di2multi.phylo, dist.aa, dist.dna, dist.gene, dist.nodes, dist.topo, diversi.gof, diversi.time, diversity.contrast.test, DNAbin2indel, dnds, drawSupportOnEdges, drop.fossil, drop.tip, dyule, edgelabels, edges, editFileExtensions, estimate.dates, estimate.mu, evonet, ewLasso, extract.clade, extract.popsize, fancyarrows, fastme.bal, fastme.ols, find.skyline.epsilon, floating.pie.asp, Ftab, gammaStat, GC.content, getAnnotationsGenBank, getMRCA, has.singles, howmanytrees, image.AAbin, image.DNAbin, is.binary, is.binary.multiPhylo, is.binary.phylo, is.binary.tree, is.compatible, is.compatible.bitsplits, is.monophyletic, is.rooted, is.rooted.multiPhylo, is.rooted.phylo, is.ultrametric, is.ultrametric.multiPhylo, is.ultrametric.phylo, keep.tip, kronoviz, label2table, labels.DNAbin, ladderize, LargeNumber, latag2n, lmorigin, LTT, ltt.coplot, ltt.lines, ltt.plot, ltt.plot.coords, makeChronosCalib, makeLabel, makeLabel.character, makeNodeLabel, mantel.test, matexpo, mcconwaysims.test, mcmc.popsize, mixedFontLabel, mltt.plot, Moran.I, MPR, mrca, mst, multi2di, multi2di.multiPhylo, multi2di.phylo, muscle, mvr, mvrs, Nedge, Nedge.evonet, Nedge.multiPhylo, Nedge.phylo, new2old.phylo, nexus2DNAbin, nj, njs, Nnode, Nnode.multiPhylo, Nnode.phylo, node.depth, node.depth.edgelength, node.height, nodelabels, nodepath, Ntip, Ntip.multiPhylo, Ntip.phylo, old2new.phylo, ONEwise, SHORTwise, parafit, pcoa, perm.rowscols, phydataplot, phylogram.plot, phymltest, pic, pic.ortho, plot.evonet, plot.multiPhylo, plot.phylo, plotBreakLongEdges, plotPhyloCoor, plotTreeTime, polar2rect, postorder, postprocess.prop.part, print.AAbin, print.DNAbin, print.phylo, prop.clades, prop.part, rbdtree, rbind.DNAbin, rcoal, rDNAbin, read.caic, read.dna, read.evonet, read.FASTA, read.fastq, read.GenBank, read.gff, read.nexus, read.nexus.data, read.tree, reconstruct, rect2polar, reorder.evonet, reorder.multiPhylo, reorder.phylo, reorderRcpp, richness.yule.test, ring, rlineage, rmtree, root, root.multiPhylo, root.phylo, rotate, rotateConstr, rphylo, rmtopology, rtopology, rTraitCont, rTraitDisc, rTraitMult, rtree, rtt, SDM, seg.sites, skyline, skylineplot, skylineplot.deluxe, slowinskiguyer.test, solveAmbiguousBases, speciesTree, stree, stripLabel, subtreeplot, subtrees, summary.phylo, tcoffee, tiplabels, trans, treePop, trex, triangMtd, triangMtds, ultrametric, unique.multiPhylo, unroot, unroot.multiPhylo, unroot.phylo, unrooted.xy, updateLabel, varcomp, varCompPhylip, vcv, vcv.corPhyl, vcv.phylo, vcv2phylo, weight.taxo, weight.taxo2, where, which.edge, write.dna, write.evonet, write.FASTA, write.nexus, write.nexus.data, write.tree, Xplor, Xplorefiles, yule, yule.cov, yule.time, zoom, node_depth, node_depth_edgelength, node_height, node_height_clado, seq_root2tip) importFrom(graphics, abline, arrows, axTicks, axis, barplot, boxplot, bxp, close.screen, identify, image, image.default, layout, legend, lines, locator, mtext, par, plot, plot.default, points, polygon, rect, screen, segments, split.screen, strheight, strwidth, symbols, text, title, xinch, yinch) importFrom(grDevices, col2rgb, dev.cur, dev.new, dev.off, dev.set, devAskNewPage, deviceIsInteractive, grey, rainbow, rgb, topo.colors) importFrom(lattice, xyplot, panel.lines, panel.points) importFrom(methods, as, show) importFrom(nlme, corMatrix, Dim, getCovariate, getCovariateFormula, getGroups, getGroupsFormula, gls, Initialize) importFrom(stats, AIC, anova, as.dist, as.hclust, biplot, coef, complete.cases, cophenetic, cor, cor.test, cov, cov2cor, density, dgamma, dpois, drop1, formula, gaussian, glm, hclust, integrate, lm, mahalanobis, median, model.frame, model.matrix, model.response, na.fail, na.omit, nlm, nlminb, optim, optimize, p.adjust, pchisq, pf, pgamma, pnorm, ppois, printCoefmat, pt, qbinom, qnorm, qt, quantile, quasibinomial, rbinom, reorder, resid, rexp, rgamma, rnorm, runif, sd, setNames, terms, uniroot, var, wilcox.test) importFrom(utils, browseURL, download.file, edit, read.table, str) importFrom(parallel, mclapply) importFrom(Rcpp, sourceCpp) ## Methods for the classes defined in ape, including for the generics ## defined in ape (see also below). Some methods are exported above. S3method(is.binary, tree) # to delete when removing the function AS WELL FROM THE LIST OF EXPORTED OBJECTS ABOVE S3method("[", AAbin) S3method(as.character, AAbin) S3method(as.list, AAbin) S3method(as.matrix, AAbin) S3method(c, AAbin) S3method(cbind, AAbin) S3method(image, AAbin) S3method(labels, AAbin) S3method(print, AAbin) S3method(rbind, AAbin) S3method(updateLabel, AAbin) S3method(AIC, ace) S3method(anova, ace) S3method(deviance, ace) S3method(logLik, ace) S3method(print, ace) S3method(print, binaryPGLMM) S3method(as.prop.part, bitsplits) S3method(is.compatible, bitsplits) S3method(print, bitsplits) S3method(sort, bitsplits) S3method(drop1, compar.gee) S3method(predict, compar.gee) S3method(print, compar.gee) S3method(print, corphylo) S3method("[", DNAbin) S3method(all.equal, DNAbin) S3method(as.character, DNAbin) S3method(as.list, DNAbin) S3method(as.matrix, DNAbin) S3method(c, DNAbin) S3method(cbind, DNAbin) S3method(image, DNAbin) S3method(labels, DNAbin) S3method(makeLabel, DNAbin) S3method(print, DNAbin) S3method(rbind, DNAbin) S3method(updateLabel, DNAbin) S3method(as.phylo, evonet) S3method(degree, evonet) S3method(Nedge, evonet) S3method(plot, evonet) S3method(print, evonet) S3method(reorder, evonet) S3method(updateLabel, evonet) S3method("[", multiPhylo) S3method("[<-", multiPhylo) S3method("[[", multiPhylo) S3method("[[<-", multiPhylo) S3method("$", multiPhylo) S3method("$<-", multiPhylo) S3method(c, multiPhylo) S3method(di2multi, multiPhylo) S3method(is.binary, multiPhylo) S3method(is.rooted, multiPhylo) S3method(is.ultrametric, multiPhylo) S3method(makeLabel, multiPhylo) S3method(multi2di, multiPhylo) S3method(Nedge, multiPhylo) S3method(Nnode, multiPhylo) S3method(Ntip, multiPhylo) S3method(plot, multiPhylo) S3method(print, multiPhylo) S3method(reorder, multiPhylo) S3method(root, multiPhylo) S3method(str, multiPhylo) S3method(unique, multiPhylo) S3method(unroot, multiPhylo) S3method("+", phylo) S3method(all.equal, phylo) S3method(as.hclust, phylo) S3method(as.matching, phylo) S3method(coalescent.intervals, phylo) S3method(c, phylo) S3method(cophenetic, phylo) S3method(degree, phylo) S3method(di2multi, phylo) S3method(identify, phylo) S3method(is.binary, phylo) S3method(is.rooted, phylo) S3method(is.ultrametric, phylo) S3method(makeLabel, phylo) S3method(multi2di, phylo) S3method(Nedge, phylo) S3method(Nnode, phylo) S3method(Ntip, phylo) S3method(plot, phylo) S3method(print, phylo) S3method(reorder, phylo) S3method(root, phylo) S3method(skyline, phylo) S3method(summary, phylo) S3method(unroot, phylo) S3method(updateLabel, phylo) S3method(vcv, phylo) S3method(plot, phymltest) S3method(print, phymltest) S3method(summary, phymltest) S3method(lines, popsize) S3method(plot, popsize) S3method(as.bitsplits, prop.part) S3method(plot, prop.part) S3method(print, prop.part) S3method(summary, prop.part) S3method(lines, skyline) S3method(plot, skyline) ## Methods for PGLS: ## methods of coef() from stats: S3method(coef, corBlomberg) S3method(coef, corBrownian) S3method(coef, corGrafen) S3method(coef, corMartins) S3method(coef, corPagel) ## methods to work with nlme: S3method(corMatrix, corBlomberg) S3method(corMatrix, corBrownian) S3method(corMatrix, corGrafen) S3method(corMatrix, corMartins) S3method(corMatrix, corPagel) S3method(Initialize, corPhyl) ## Miscellaneous classes for which there is only one method: S3method(biplot, pcoa) S3method(plot, correlogram) S3method(plot, correlogramList) S3method(plot, mst) S3method(plot, varcomp) S3method(print, birthdeath) S3method(print, bitsplits) S3method(print, chronos) S3method(print, comparePhylo) S3method(print, LargeNumber) S3method(print, lmorigin) S3method(print, parafit) ## Other methods of the generics defined in ape: S3method(as.AAbin, AAMultipleAlignment) S3method(as.AAbin, AAString) S3method(as.AAbin, AAStringSet) S3method(as.AAbin, character) S3method(as.AAbin, list) S3method(as.DNAbin, alignment) S3method(as.DNAbin, character) S3method(as.DNAbin, DNAMultipleAlignment) S3method(as.DNAbin, DNAString) S3method(as.DNAbin, DNAStringSet) S3method(as.DNAbin, list) S3method(as.DNAbin, PairwiseAlignmentsSingleSubject) S3method(as.evonet, phylo) S3method(as.phylo, formula) S3method(as.phylo, hclust) S3method(as.phylo, matching) S3method(as.phylo, phylog) S3method(coalescent.intervals, default) S3method(makeLabel, character) S3method(skyline, coalescentIntervals) S3method(skyline, collapsedIntervals) S3method(updateLabel, character) S3method(updateLabel, data.frame) S3method(updateLabel, matrix) S3method(vcv, corPhyl) if (getRversion() >= "3.6.0") { ##S3method(phangorn::as.phyDat, AAbin) S3method(network::as.network, phylo) S3method(igraph::as.igraph, phylo) ##S3method(phangorn::as.networx, evonet) S3method(network::as.network, evonet) S3method(igraph::as.igraph, evonet) } ape/README.md0000644000176200001440000000014214164530562012301 0ustar liggesusers# ape This is the development version of ape. To know more about ape: http://ape-package.ird.fr ape/data/0000755000176200001440000000000014164530667011744 5ustar liggesusersape/data/chiroptera.rda0000644000176200001440000002730314164530562014573 0ustar liggesusers}y$U^DdeI;t.00좕Y,cQVUtUngefVL 6m|ۀcsdn - /32EVJo7:^q{_Dּ>Y/}R( LR{5]dUZ*U*9D .1x9TȧAO|? ˟%N> >pºw?9',@XE/v8N/|@ E~W=+ _䫜|7',׏ o y;uB7;y78',t&ȷM_osCc ߐ| s;aB ?,aݏi!?g NXE'e'":"uo8ͧro;὿]'?tkHC ovO qHJ n N?gL'iw ºK]',9ay u9r GN\\u~',?巃 !qNN.Nֽws/8a=NX~/',68a}!A8a;!||?aNXp't?!ם !',?䣝'8}/%'uBnBsPw 򗝰b' y ?K'/ugU'uNXeBR'2 'NNx9y!KHrSB*!ºr݅l|o '@&o ߟ8^!iw? wނC',#! 'OvO!l ɿpk_;7#o|S|;pk> brg uw^uyo|;w:a b',ޏ}K|;¿_%AlNW z;_;!>Aa=b;8&!u NN ۂx{1Λo}+#Fa'{;仜NX',}o| ?r;aGB ?.tºrNX3N~ ~n º_tKBXN~ɯ:ׄ~7~ow'?Nx-b7 巄^oY댓饽y… NXFpNXFpNu .勝D^pa {B|C'Bp WK\&#vҾ흼wt2 9oF<᝝uDXnoA X{ u#mOQ ¿:a u#NXºrC|@NX!ÅooY$Iƴ>xR-_' ~NSU˰TiViVer JS{*ߒTY =|/*$yM$ GSL|>M{*yOQTP <Wa썼T1R'QgQy>삼=(M'07<]a>Ya{*"|O!7TAPr B^s yB^s BT {*=7\>r>>Tr@O!S=|N!ST˔>r9F!GSzS!S7\L!o#)g B>)a B{)X BNc)W=r*܊B>#Tȟ( BCSB3TȋrB.(><rG!!穐(: yNG!Qmrr B J~Gѷ>Gr<T% fR;pܧ$Q ^RpO1_RyS56hwt]{*=7tƎTxO[VxM;V ܧ =s Ua%DeOŸXTKݎTGcu퇱>m17B;m0vܧ-0)9f`<*ˎTOXX8>瓱/pQasyh_rMkr[5K}@mxa:SۄNۤxi:S7N5F8F |v \u \u \u \t ,q p n n χ5Z5Z59<ݡ-ۡ=جmMٱ]fM^6k`&k`k`k`krnpX_sܧkkc2rSsܧ.krdgMN@c8&iMcC CS52}j&W"/1qMFn c嚼>59/\ܧ&'1C>5]⸒5y.1]Xkx☓59-?9-́krY| { {MqWq^Uan4_h&75>5 'Oq~>5'̑&9X4_50_50_GܧkKX4$M> sد#9Sc X4Mq SchrCW5@5_ܧhA[ ~ O5@|kدxxO |؃kb=mXɩ64^ɣ8S50_a#< lD5 1ɍNk`&vq~lIpܧkr%5@=pܧzG45Aopܧڠ949.-0X# :p?6i)Kuqb5XS q{hWuj1Yu`0X? }a%O<7q6m}'}`!î `Xl7aý'}`! ;7^عl{aNy5oܧ`! 0k k 0_ pS p-rܧ|7 p/ # p?~d{A4O`!· [g3<38`!^/ 0xe75(C\`!_ pm 0sc5?6|1 W q~mG6 =:6 5m8a k <onn }x`~n\0o` }`׆ p}V)}ɽ? }GW +2/1{C?1C{ c3rud4ZjB}` @n`ۆM;F m $i`7 6H=юh?K} l> 6svA&`=ihvyO4_)yO9|4K!yO#i8OE}?ƞ Լ{< ¸$}ɷ 9 7!~WrԄ/05A?U  @K yr>hOBmpgBxsug|ޓ_>'|x'kYx؝<'vNKxtN 9;u 99r p8!M| `oM 7!wM{4!7C^xޒLsy&s{&/x|\w&xoxk&}&blw&s;nMɲ=;`oMII p7&NK&d 07L yO gBnLs`nBNXk1I>cr1_0O'EYF)^;L[Jt-maoWj]VNOmz?TOmbTQӢvLrۯXO7ꪜdE]Y`Ѩ|bmmݬJ)-Y7MSZhu{餬FfiE$ߔTo,7MӬox=⤬f]׮YJi6Cu/Z'USߞ:yY3GUqӅ9x4]m46C^w /ZXX}%^XdS'{]sW5&N׽u?ʎ,iN\Ez6UT=|W֫tMW< ھ`ڃݴCV߶Ӵ괩r]fۚ"CnkoMڽȊ}bc]l[\ʢSb>OtEY'ͽ/l,uYz{z/.ڮ1b^Ң{y9˺NieZxp6+a_6?k}YlZxM0[5F3SM0ZPGt7uׄrl`b`wv"Xҩ~&vyZ;3yxv9ɳLZUV` am)ۮ=݀J%챜EkgǏaH vW٬l^;[]yxU.N˓^7+',OO67i.#/, `_*l{..澓Rѭt9`Խ0RͳlNm=~*[z,x )z{iHW* ?~|3 Mz\ .,@a]IX٭LSG7X:_9ʴx K흲Gj+͖n]qg|aS+|&/mL6m^o{^0IC_c,Uvw떳ʂ\r m{O  ӭgۻcóK,6 k_o#Vdjꗹl;ӛpزr?UB0`ަ^K]0EǁP|+uD|lyբYfHD侯ǒ9rPO#sXkriӪ1Aie"@YXvQމeUEM}|b ycGΖ_wV/'iS4m^1K BR^k3[-wR^6M1˰\ٕpִU6eBlmmZ`'=]r|Iנs脩E!{(2=ͶG\,<\~LE5A`FzsO|I>@&>w3minղ"jFY n+lCjTfYUH]?3uE;MѮrXo-[f:-J*T VnTimqɟg77Qdte fwin֋ 펄\[ܽe0B կH~؛2UavrK:q *a+0\i}/=6SZ`"vSa'X3c!/2ġ<х_sڹBhM r@J]Y30Œ[ne#gedX7I*Lxu?ΰ ,V ҍ`b )I$Os:bQin|'r#Q^΅Gs>ڢ,Xބ=HYJפVUO5Y1L\ k6`Љ| L8@ԝLQQO&Z#oQ{XGhັb*VV5h^@ȧeqU:+?G`kB]yEeugշ+ D`g9Q[ r,ޙAE|cB~$'yO$Ɋb3 RX—aC.xyi^|`:״Qq(!fj֣]V6/FUKXwD L:DmQeZyٴHCN;D 40GR1%öma?ypbҟS%qq$EV Z@Ցd#Bu3+blEPnd { ޜ弌N6k,˰otk3w$s["\%e:sjx B;;P'k\\5?Ekլ;p:Dۺ׫u6 VWVy`W eė y6Ћ+N"пetgB x0,uR1gxh ]"*D;{Oa&cm*q1Px*$B-WP2*j_"I>-7mn(( Qt!RC/\G4q/4.E ,i5[.'G^C&1('X8g*}kS1%bn,ȌCqR^ם1/՘Zxj]fqU*+;ND墸X*ϲ,˕Myp1̰'^ݗ.4ffi7v`^Yvq?i ׂz]G@s EN2mi^Y[ȽÖ迫kc^Ryi }Z}q%Rb3`Ey81RU#X+Fjl1ͨԮI'Y.H22e͓r$!v5< Kt릓&繌zM >|59jxR˟_m,/)yBO,bg6߂I`~Ek\0~`(V^m$c6렯S|!X[UdWikWq]yvbR!6 /]).zX< )Mag꒫-!qt *|N?GNC\*۸I2ٮf<+T[i!?OjnM|%͑dHWQ5s~3>YF"բ eQo0>͸/5ґ[0Yf;$w3cȥݬͪvt7)I}l [zV[5jֽvK v]Z#S-u3}F)NG+7a~1.*ˏRݱCZ(,UNtksD(ʲQPQSlZdC.?2l^ӼŬ &4g#,-:b]16c KBA ]JHo kby司[ Xg٭8f7Dy=_?k?pB+jaU:|ݧq? [hq[2_6eI}GA*-L9GOHmՎ`hVuM6ݲ6餪nP r4+O`OYrA_ji6FNof,h"}{_SNtې. 2B9rm-1=@êϬbi2˔x?qi}*&f]~0 b[4 ^t{#~+I 3 \y8e àFV,VNVZ4k~PĿ}|;ƈhC%6/@<9 ޡN\*da[ރ4l"^xώ*3ڤĺX#[,Iî Pΐi-B> :#2P+K`cٞH! $p?DHu~ AGPHA1p'aI3!at&rM> LO %2^;~*B/ʹ5T\ _9G$">? YwM sx68{^J0~Aine7d5}B6B}!.-W+p !fp mYw@tVtAqKh >#:-< TxtԒ?%~B'%.&b8 mOdĞabGtҌ> >X}{^J6$C0}wD41C.I{Yi)@qSׂz,yMX˻UomɆ`aϛYOQdODz}U˼lA! ~H}t[4cLlӐFnj#)\/[웛WYe$ʐzg0 -tHt# ݈ 8}ν3߱y=mX1UT $H Qrgb$b0A )_S 9JJMI qfٟ؟xqt ېnްVZ+X/;?4(!)Ϯ(W\}E} cgPQ~Kro NJ47/B}SB[zq8=+.PkWp^M|&xl_tp^杠=Rp ʝ5'̓p*fj*pӝypW>ޮ6TxNnNqδO{7f_o,x^p v6el֔{`/m-nګYpFEػ/,xѷdzcB5`mn۶:SߚH׵I>:陆Z 򻾪vEvNƥ|EUe/`w u'̖aby9=͟[Xz__pq>]LOjJߘ7I~5+k=]rվY"t3nުqXx ^tС0ωbU"3B_UQJ=njkv\}8&;7Y >coPѻůf[+Fg~VZp~;늧ό௏rѶ+j]˯a蘡WkS3Gݻۥo/@hbߊ~/kUX9))۔Eo_vN*wk'cXꞹ]ԙIF5᫸_ljo)/'F % #K#΂ѣQ.C;n+%6zb~[ջ0V+_٬ӷrQ{atX0͆ w=Lu M0/nZlNtϜ I f'#47{n3Z 5rzxqu85n٥Oоn1+8voq=;hU)oMX G$Xzލ@WvISd;;IʱX֫Ca=x.Xe;^eJ~&wlp,l։TmvJKF[k.t>W/̾˻3~t~`|2f0A= ?]`Tɒ)驄l5tchYޔ|{۹n; wwaqèzIVǚYk:Gw}ڂދ?t`摍6vrNlU C%wQZZ,} j/m+)reV߷\ cL}U8o^m @̗5B#<*/m}ATŞs=i {J8v(4nO#؛a[aIU=ǻ?/0x5x{TkVQ Vg7&洞`w@;-J^$~}IBxókH }6JvlwG̖#64rߐt~\],GKY\g ɯ暇@My~O_A/3YGVl>|f[;^AeHSSa_GIq}ٔ_o+`==XyG40[~-_J̲}5{FZ$;#so8h'rfOT0{cx2NreF VZvdM(EEΏൟ۝o}V,^.b{~n&߰G wl#cͷ'DJeK>̥Ab] OH+G080'&*MY`=ڀ^GԞLM`}j.ݖ0¾4ڀgdM`xCCdqVY}M`.k5R!m~nHY3cW>m~H8Foyg U#a+|l7xv;SQMRE]8K%J BeoXQ#R7זF :.뱯N3ics`umS!'^>Iecx91iW^J#5ɴzv >n7s uaquWbL;`VYA5b+YqV_C_^;T9nԋkbt.#y?%sE2-3u_`ΏU/y?!w6fxIlX~P}ffp gi {M\S<B\[-Ny0cEIVkq'`Sio[O2g}1w<{Hތ0\Ƕ8ܖr?q:Zy;`HT"ᲇSY*˚F4w'ŏARk0\4jPݬCVZi>ncFkhΑɟ$k'oD˸'u8:]R1\!߬`u˳W՟W|I,1\d*ܹz5 9 9!ndpDT#n~l?aj`|Trt:k=?AΆ;3i.ky4qKe~&޹B㫝_Z=t Uˣz7B؋W 5ԅ(OŢ`8]Nx}w=[50DwyS־8S:}v&VXt  ̓]/V[V\)dToα~w4KnqL>C S=G!*/Oe r}g ~'>|b7_l#al?-\7`3T6 B +i209Y~(<G`ྻQ#*ο6bU'"q;"vGXmZbh=;kVo` ۿbѰ* |*~//WK?N|p'D u<^Cδ0K|K;>&2?;AvZŻ7>z?_{W N`ن;||4]<  66;& '-ϩG8rB!YRdKwhⵚ }5K\[KϠo.S[dO 6@wa\ڶ:+{tEܯwnv9< ?فCqP^P9}2Q?NG0 7,&oI|m%hڰ{|vh׋$ k_b%~UJ W7ޢ ܘ*WnrxL\8}S=ct@0FeJoW E^0/0bK |)={.)>\{Bx=pcN;3m _+#LT_ Xk3Oyi~.!+rJ?a#SH-'p(Mh)t7Pc+X{'I۹+6<:,{^k7Z -;`i m!m%8얀3i[etaa-3p/r;s[N]mCz?ťMK\jzGH]W|T#cm^NVġߔ|=ap6 c7Yw`r >}[O۵,k; ;{r46DZ |̂vF9:ЁVɭ<=' k:N n nt۰"&֧ݿ&V2;럞bGL^voNtYZnG@k#.NGoCݕ*mIvJOʛ SosYɑK7+RbGU?/V@}#M#gSO8?w] '?A,˰^1z`r4g;Hlq>}Rg?Q`k Yu{Y9S%gKt S=BpػD̼s_`j䇿٠'v`p>r$H\9r}y`xaxq| _5Ώ*aXj?<&_N_=u>^4zr\&^mwYXb[l.E!W'[15Y0`0|2Azg6HUv>>ü>SrVaDy4*M}b޳.g YG Cn떺%lG6<;~dC veåiR[{n֎ ÀeoNڸpŸ̼ʹE}/v* `!buw ?`.pL}X?P{f oӓ2W=Y P ^㴜6/؛Ve^xŷ+|NX+~c\5\~B|Wl ਫcM731qs?~wͰΆA|Ygo+ǐؓŋ/G !k%F3#~} 5ÒXnfO7(.+_% iA@3Θm9=e }߮9+yc.ZN.̥ڙxsE tgù;x\m]cW2 ۞  ]ȉax0:_3:kɕ'HOՋbSC%ݙ€c.xͅ`v^w,!kHī<}Z0[b#̅nAYY?M:-珰r gF n%,;ht`>%||9=|:|;?tnq&^?'=e=4Ry]Vז=B˂}W T4FP}3 Lq V]~iR;{z&(/9!>^,4!ǶYYf?5z?od ^Էq|+? m`%\3BK>3f>aǙL؜Ej>NSD?+qVg׼M%(4fu"X*`RT>zYwIaf? sUoxEy4۹導r!1~\;p^d:K&f9 d?-Z '>.0ApΏ%f}fa0$I(yrw%ߍg/_Cz_O4S0tOJ/_&ѣdxGFE$h!+NqvaC'i+^s>:&qz; y*BETl1co'rgB..gw[iV֔ zJ5`ނBkj.E# 9ϺZ=<SB܎6,=9%,N&{ C-~vϩGCOO/j^I`qI>xSA]ϣÖO@=/p~^LV wA~Rxc9 xsjj'ܬòѤz]Ye+]BqJ/{AmEz.q42=O_i#یY*^0J~*zC_د6Guo8_x#A ƾڗ~/g}K+)\ S=烋|*҇tXa3|ᙯ-lduUF塓fϙQrw9,~!O4]uBB[#Zkgi":m~D57O\pgE|jsü+7۳` 3R_O-ϙ38I'6Jp,[&ވ^^CK]gfIgZHO.xK+?߮9z8[x7oɛͽ*=\U&g-&6WV0H>0Z\0X_j(,AnuvIQm0,A^ȿ7 f)y$6eZ Z9yY*HeigN4p.ûPWoK}3x_-⥬~釴*<.5<V󄣟Uau=@.4xөʧ+?߮9\![܎S!t!umS]_|`4tEX\1-]$-QyX'R#J axY;ΊfcnG%Seft-B*m$ҿ󎏿Kʖv&^^\]N{}UxM\{J=T㮏\!t8$|߮pJ?W|T#aLQGnv:Wt{Ј [URvn>;S/v@ystW@pU-t̹"{5-aet!O#俸nDž* ;w ^lauʝ&}JWMR2 9VK=L~1N.nhp42̷o\Y"vS>z Ý0|H:.TaUCX?\g]1o]F?m@ $݉s- (߃M4 [mN^=X.{ Le}j.}̄Ѧwauh^?AѴ>Z/y ;x̗{<{bќB|j^Mە.߮9R)W`p:ubDsE`Il]&+XI ߎ?9j[C <տ75]rC%IUqr~I'~O2BxZ&i͂Nn!MZM蛱' '+7SE pi(@zZD0 l>‡K?FەNoWyd=4׹O*~,b} nvހ(GhN>d!?\|~!kAޣ ;Lk YU1oZ<;>MA%ghز*w~B7.|7 Ugx[kO+ݒ+"Ӡ\G@  Z0bމ/]-äW]`ʫ!ӑy5oW~8+]s}18bүOf8乪#o`i'|p04ڏAi}Bb}C xM>ƒ:kk}-G~Ӏ}[Bj!> &zJO^G#MX_hbP3B 팕ܰ?—O4m^Vyy~hGp6 >̫))\꿣z^ޥqZ\eI)bp# v71zΌ N KqX4g9d [N g%/7!aݐ>S+ybO`1}%UF +8F:7[z^o͍0G\mfMtB'FMԼ+?߮98̉Ѭ*K}_]4Itm=rNխNoSݭ~!Os@JX?LL گmۂBHl= Mw:bZaA>U;CWisFl`$=r0O'>Ks˜=w1|ۯ9Yɛa>X?G\!uxi^MەNoWyd}L5gE:Ew|*WvHphnLZSܤW'Z !$AK?l~>k}Osojp7T00}wO~ sH ~sٻ*Y"L1&Dշ0>:,y!o+ڂWٟ=ve҄{-䜦Y4B0tWSvS>z/vdChMЁ}HYo[ѱ_()ukNGٟmͻAi#/c`VkNw4),>m|{@|nۗ@ho(vjt#joH?W|T!p׭CҧЭip~.·Mb_e(ttN[ -4іCtzQhaReY]c~+{Ճ5z° =Ni: .!@M4Nm1'sà_YυXTŻ\v2w3ɫHE[8|O[~C1P?Wj߮pJ?W|TRW2Gl_HVS2Uc߱}@>iv^0HZ6G[-dnNӚyy͐ cx_|a p"m'iji Zn̙WvU|C8sk1|VoY !ٞU0-']4МI}ui4As5sŷ+|N<^]!V?>X;,cWU_=d_7^aBtu3| HGS?s6|N Hi:/_ [B m^ k7i>H#^Фa.i=&氖S TBnLeժ"z>.+H]Wy2j\ͫ))\ S='d@7.7@& }A#.l0ϣ0ˡ\t5ɮo} Vcʛx5c`/c yas0S-x^[2sd |ۤo㗜b n{X쾖V[}qy>I~y3OJV!X>.,0Nˬp:o i.ʺ́dOLLxVcW׹OG:Is*O&2Nj߮pJ?W|{$Gz_:lAhn¾-jh=&PE> .8CzM:o;18{O-{bū6Lp/ c|3.G; ok;77Dd"Lh'U*H? |Oq0A 6Ǹ0W*,#!ZD/ *'1{gZH?Wj߮pJ?W|T#aw?Ħ#wv;j /P~{~{?m_ⰸ^ &J8&"UOKsIry=wԭ](l=PaxW0wis껛ߟr- ߩ<1ows5 yxʇSy2j\ͫES>z~s cyVIԓsT6EQ hV ~:WL^e1&à[8<Z>})žd1L!2LFy 9Ϡs-a,Bt}9N (̚_p$i>Íq)Jé<5Ք]~vտR=绢03m2_Zi: -H|i~_, Щx&_i]|;&gI1\Ϻ^vHSU5![V_1xI4Z}0||`"@}r,zx` ͛Q>\$OF͟ӼZN~8+]s|9Q?<`hS\'KFp!lT=2صlD C[`P3 \Ș/MsyVbx|0-h4h0&+L/' "nbB箕dE rPBy\x=$D@csY+-܎χ<5Ք]~vϩǯ6NWD_y>`'q:5/r,1:,2W-Lt!(+I9<t,]UF,B+U;^v6Z^ni9m>`9n8E/\9*TX#s,x1DT?Wj߮pJ?W|T#I$(b@JX&CqW#hc7ϓ5V]#_SP~zaLrPb)?yGW#-G:~h}?u[4~a8f"&Fv$ňh"͸6J6bHrF #2begu^U>ʓQy5NoWyd}B䵒yQa:5^7cJ:>7`rtrUcv_(MI}amGבKK=}T߅v};bI!~!_2*2+yNáxZNo9t3g^U>ʓQj^MەNoWyzDK^+D>|\ k(A:MO wT74g74'ko,\ d ~*OxM:XW!TaCUOVb nS9/lt֝(ԺeΤ ayd[ov< J{Up*OF͟G߮pJ?W|T׃N!Du#v'Cr; F%%1`_GbN"8 JLY۔SaWmP)X}E8`{a AG,7%l gX)6MY}?g>XsAD{#Y6DfH]W*Ué<5Ք]~vϩG'.>R>CXz:SJ~P9ք' pބ6<س {r2:D~!]⭼ur߄oq艹zw7F/c07ovRAn*1(Bnx}j|$IݕGDG\ LJj>tȺ( W$\Mnb){?y,|9xxl~6+ʹbSr N>n\hUv^v{Up*OF͟y5Q~8+]sshե`eMqp(k<7n$6tٴg6 _<.֧=O&C O鿞3¯c  zPOß^k|Us>lbg\?2oq20ݒ^U>ʓQj^M#~8߮9~kE?yC|xz"ް #η\ nc7lFyVA$ª# ǻ!M,fKj^!(Cg<1nH9!dݱJ ė-Gf6}.dgSch,ۭұsI_>߮^U>ʓQj^MەN9z|h,0~*ӫ+\!|s"߈Ż^ աOrSY6Z1 O~$Jg^Ïe6q.aY/|=O_%,'r& G^b _杇ˉ@sѽ/g +BF"ۧ\`M},*]彪|H{y5oW~8+]s$HB#'xJ/sio_8EIȜ=,kda"īGF%.JP~k>xA7`!HqZ>þ$?M9oxjvhOw:j},*]彪|8'ռGp+]sp oeo""oD/@y%~M>wp ;; O@AyмyW>pk<+櫝$G,0Ze4P.-7r17!| <:lR?>sfC3J`{Ƒ o>^YuuE巫Wɓ!ܫՔ]~vϩ12'=S)/REjV,p>s},*]彪|8'ռ+?߮9xg&sC=n,fܟqF((!4"&Ke|S`Db?I'~"A;x򵥈p%^qqS 8=ּ讈Sf~܂إF6TՌG!KVXT~{Up*OF͟y5oW~8+]sKőQ;c ̟J͒pU *ǣ F&+ qx'@Q;Y&rVc2Okѹv2'v'W饖zkA#BTR}Ou&厚ڊ0a=R~g%|_oZtW} a[m8a="Y܆FRa|KV1㋿bknpY[;SdOݯcQ*Ué<5Ք]~vϩǯ\0}Yh/ M{o9G#g-sb \91"3@+19cr6k Pr^S˟McgS#٪A]02u|Mn q! ^fG\nWv"u]ݗWSvT?Wj߮pJ?W|T#cxȄpoT:3q:2֋)Sؾ'oegݹ'rY/am%7M7';ΟCRf{pvwr˄_(ٮ.sw<9`7Z,pͳr~Ľ&`W-p C8D-'o\c L"},*]F(OF͟y5oW~8+]s0:fo<)uٹ).JIAʳ|Nݯ &$2$ߞ%>N>ɞ?I%B&kIL:΀M}k<{6ᡈV:ڿ2ۤ{4tݗ2o}u__MǢUޫʇSy2j\ͫ))\ S=7d5=W%6;ۜL|yn;τyDm:4_n2Ɋ>6ﹼO*TNěڜf]Ö4آ#T%=u췄_{;a)Un7Eޣa=r__MǢUk$dWSvS>zYEp)ǕA8(1rE,uߊgUyM9KzHb Q۲m{? *LN'Iu=k`/!ȯ/7ác6M|ɯi+Rj>߮^U>ʓQj^MەNoWyd=t޶ފ(>U0n%n=j:櫻#M3Ap)]ZqwɈ:yߒGTuJgMea{+yt% p"EsA<|}K 'o:AGt>? .;S /RPuE巫Wd"4NoWy1L1ݑ($}K'ߐ\ ^IV`]$/G/khK<cpᶔN Ky(ԯI_O_Đ~<(05iO5[Ԕ-{]0 1́=k  ub@΍딻>4_`R.NVwmg3"|'[tsNG~.S b: cINTuE巫Wd"4sŷ+|N<~ӏ́oeH| P)#q]eA.6å</Qˌ0HPGܺ%}F>ruE5HJDEG0@#0@*@KܯG9]TQj߮pJ?W|T;i,3 b< -O3J[8-I]X [:Z_ p!J4#˷Wn$s?kE>0J~ ᡓ%BvClv^J^^UzN&ON[utu/UݯcQ*Uͱ<5Ք]~vϩʕF 1_}/1~19)OR _l.ɗu>cƖuخ&*lY[=]D1'^+sƜҲ_2c4ďX4og/5 b<1Hst[H=*TuE巫WdWS ŷ+|N<2sp0DLVEDm N8* VYq0;eAL&}oN^t`yi^Io!e~05șaomO?#(?G@G=Pq2MKUX"*T?Wj߮pJ?W|T*~='E6݃+˂K#5Tj翥G=.Wmk{ޣۼmw:+84~ 8ʻ>lLGK},*]彪|8'ϕsŷ+|N<o#ƕj0!os#}t\){Uo|C5#&hз~XQ6GXdfAfD*tWVq? jèzΈ'?fɜ堺wr2 hnУ{j4uOU?ܗJ8[ǢUޫʇSy2j\ͫ))\ S=*C؟L\Ny,&0ɟb {_#Dtq}wvo=IZ୐2QRetE3Gh/.Eοߝ(=ǡ%Au/~gVGB;e0E@'h>t *IT},*]彪|8'ռ+?߮9xQ(G:i+ocq5':. ~-CH?xC9V[G!QG#P_4RH?Ư~gWLX4g\#rܦRC8g+P 2@6#Rj>߮^U>ʓQj^MەNoWy<~]D tu6h~LSy @ sIcb:gOۊ ӽo^3 rvqS'rbS6k :qנO r(?ӼŠ1Y- 3 WooWuuSܵP@)n/ݭ@Bq/^$ +眭kϽ 5!={5לs03ϙ|5汐N+pNqy;syq6;IX$׾M[a.)x)#)yVo|df! 'Ҟ_6=v4k].)sG2\8tS5 8lG-#cL<11v^ɇ#Osըosٟ7ϣe0LOq&S1{ŒG6k:k?%'0&O>-S%r!\1;J#ϙ9a}{]~Z >xMKʷQ3_EƕK83} [V $0 2OJSQez "yWc 佒G QN=眷?G=Ul?AF8yhfφӼm I7^vmznϫJ9*A~ѽxۦ&?^=?Jgho;q{H /iBh'<%ഐHuHWf9R<{%<Wz89oosGP}1'çToگ rY3?R"0\3GߗcY [`9儏B &<}>?`:Wx.T1Y.Ŋ<,)ϙ|5汐N+p Osըoop؟s7ߚ_ wő?K6W$և? =}J޻v!Dx⸝u%t:x:˸U ,ȟeUݧ_€F2\{qq_ƷGNV齒?#]ۖw1?g^*՘B~;yÑ'C9jԷS9Qϛ{;k9y+|>/BT/kiⰷg4\2[ؾ#6WRR,Y_|y:D*:K:*Q],1}tzƷs,>v{Fbu$^ߚ$% }ϙ|5汐N+pqy;sN17~\}H?a}T8O {wPtGRX޳ѻLAu>R2V=[ 4osb!ʝb4:ϯڞ0KeXoox{O@ըosٟ%M. aב*4)\Ɯ\I\VP,x}29u5HL@4.g_q#:轊[L_X#StQ'oR {ݟ.2}l?gz!3/jc!Wȓ~5۩vmrcp3o?Q #}gc:#r楃29G?UY|p9A)|#/0vcNh)C\RxvaP ϙ|5ڍN+p4sըosٟ_[Z}o+9hx;-SeЩ8}^b^? e>t5;'9:]p7_lX%r p&c6//2cj.phZI178(^4>;>Gb9EW!}ĸ?g^*՘B~;yÑ'C9jԷS9Q{p APS^ = Ӱic|I#oZ rӿBΚ=|s7QD?c1>H[v_SV _$M]wV)cYKe |@?g^*՘B~;yÑ'ϱz89ogzƘ/dyc{;G/w>5.'wMaKG#U!mӁOc;Z&W0oٺh{OorPi?Z61ShۧE.u]B\k.JL]h6:/3/jc!Wȓ~5۩?zޫ'LA3r0ZPx?ࢷouL3%owaҁ/|pt8EqmCw ؆;Sim\VY2[{pxB}^$̙&Xǽu7.& oX%:P3/jc!Wȓ~5۩v@6J$!#_V@Wف4~}%N:,.õ{VͲ~j#̹Vp7l2k? %z2u7Ug~y?g^*՘B~{{<Wz89ogz<1I/3HIw\-6| .vATI[L\ݝl1rGD/un7y6e]9m^T͠aɐs2_y,䷓J>y2ӯF};pܟsW?/.0dKrR1o<}~7#(a9nU[Ys+2Mmpo&[K Ar/$_ q7(" 5hyLM]1ɇ[ `<.Q;R|4KeXo'Á'C9jԷSy3oGz<wqm_߄ov+y{XG}d{=NC.wNc z)-r;c>H M@M@~RPg?rJF;zڻ?g^*՘=&<Wz8ϛy;sMꉎ6\\}S<$`J> 7-v?ף7dI+I1gK90nJL]#tykvț]>m *M prm;9$aЪJi)x*8#/jM 佒G QN=ͼ|9a~VhdŽm8\\g&Ԓ3i0%ɑOK#+hP;݌0V=Og9a#Lgkw!ͽ%CB_k1%F^jϙ|5汐N+pՠoop0ogz<?,?/[6䒖?[p/w?D^^Y}SAZ;6/-7)C>KIdsu\ y} Og}k:c~[7fa3طf^f9R<{%<Wz89ogz< ~Ō'_~ǜ no~Az'-%kҒ}LP>KI ԟ!_LB)K+"N]N'*ߛ7_[A sIKaEU~$Ds2_y,䷓J>y2s.N};pܟsς)FꀱC%'!vq2\y*g|0c>()|28q}.`Ӈ%~!YH:FN |SvQe}?,͇0QX&dU&3/jc!Wȓ~5=i?G=݇[OQ0CHD$kHy?[ԅ g,D9u WСHiRlcaOнU5õg~'de O'$>KeZ~;yÑ'C9jԷ7z89ogzޫOM.u$,9x뗫6i-|$ '׫кsM9?ϔm&z M9I`׃_6nWy~)Rq$'ekځh|sWc 佒ǽ qQN=眷?G=W7Fs% /kOzܹ4ػw[\fƋ?YCO؍҅c oJvUvT%Zj޳ISaP<+4[?؞;`b6ࡠ6X5NJ,t1(ԱF/A7O utW!dTw'\QaPϗ7Y*?҇G{ɻ_Wt0d 1bo?oR<{%Ϗsըosۛyo>Ł*8h5ƑP~c~ KO&`{2%@u݁T=HD?s)y9dSB rZ^f|-.ćHSa""ОLy]On5KeXo'|8d?_v?缝9yo{/ >nsϯ+gJ俸(8_1wx0,Rf\|+5H1j:I2My *^P]2_YDJr.A:~GAJJ_5.ϙ|54vɇ#Osըosٟu\7% 6>s,%ں9Qb9ֹb~W;tQ#Iivxp*>cO)ꅿB6f ?oR<{%<Wz89ogz<"toM =0C59U%(]))q}PfKy*8e!6OdAE7[H1u|-EC_<Ȍl'H'Eߠ9AjK=vsR<{%<Wz89ogz;XYS2y/%m].Y9soA'涴9xkW?5YjaF/͟{s>Exs1)f!1Ŝ~QGc"p;LxѸ!{fIҁ#N~μT1v^ɇ#Osըos9w̑S-I:o&3*$zğ$R80, [,mUd̿_;gIM\mnf W%H6GSVEr݋`?N1=]#K6~d1yWc 佒G QN=眷7^}[r2] ')EbŽwqq ?+A~f!FX鑏=C}+_V}Oχ$9#cf~l:9w\?$T [wϷ]+~t#>s9$ӻ7DG cJ뿳0.`$O-J IN?u*C:Y6?x)tkp3/jc!Wȓ~5۩k瘷?G=oOΝ|)_Y<,_us#.!ϓ1μ,ǟW.HȊS,ٟ% Pߛ;E ʸwF_P4Mr8S_'3d^)YS=AfՓҏs34?t9L?g^*՘B~;yÑ'װz89ogz<)`lIzW@x?^#6Q,o-)rX' *XbuU&(w5?ƈ}ȡ۸ɛˆ5uCs2_y,䷓J>y2ӯF};pܟsyexf3ܠ<$[Gt s+h{◷{t:E J]8qERqs[a!ʨZIʒwßoz}8䌕o(\3/jc\R2!]s>+e^j>DC/wsM9R<ߎ{nÇOsըosٟsmd-%s7Ԅu_c#put[k]ZmpOyaayR"70Nd‹5K^B^xڂۮ 's]73yWc 佒G QN=眷?G=}?`>t=RS%|/)V@fpv/(^t(g ؗ9B0WNR ^ .r13̉c+.aI'؅vv _cKeXooxÑ'~~5۩vcs/ՉK^ć%AJv!bNN]%;Vo^$ rMo'ͿzRύB/׫UVh$AB-G\ 9|$e+4F$ RQ∺4g|a?g^*՘B~;y'C9jԷS9|Ri;X%F.}tSG)Ł4 -#.t0XbOcyGk>y~q7aۼR][t[ikcHM$_SRnXϙ|5汐N+pN휯ry;s.%r,Ump~msΖXmӋJ%üs K$TCCIJ'lF՘/S0w$ϽmNllLe'{J~1?:'?n+\_$]zwwB'V03JqrKs2_y,7|  Qssٟk[b>|՟E!f}< OAw%ud ;FEj%-C-+Jiso鸼hg~Tcr:L:FJ|;gXrPmǙ^.b"98p5n|Ls#6}Q:ȗL'4 'ϙ|^ x6|8+?_v?缝9yL>k)ARxy'BuuI;!Klqv722_y,䷓J>y2~5vn{o\y ^cV|~)2_x(sK}}7XU{S -]ˮQwSៈqj|[/.Kx7nX\3/jciདྷG 쇨osٟ_\=_Z VNoxDSOPtW×=8qۋorǙ?ouoNUOvdgSׅqݪВf>^L(˜' 9/1y >9u 2rTT_ƼT1v^ɇ#Osըosٟ7cE/CI=m:z 998:Sj5tq5u}hKi w]})16 됓në#Up/䥂ϭBϵ|Vߧml>iߦn'̱f9R<{%<Wz89ogzޫ/XWiTspMȟ.|r3uw(]爇bq'_]d{_^}Iy@qo7Y8vg'Z>R5 CT i%)s譪~`@tpX}{VW1Tnq'5Q~Xu M9Rg 佒G QN=眷?G=}?7WVHs9m/[ ^Z[2Ճ>NAq] ھ:D]KOt ۹wq[`;=z* 7Qf؟  ^Keu䷓J>y27~5۩vyZKkZ3srpTc*7Nrs<,޽뇋7RMC)N{SY R⾞myAgo<*=e{1;5c~ϹDVz֚_'s6jc!Wȓ~5۩㹣捳->8M2\Qr_ ӋѮ?71`[hF]s.%-Bϒ>£:HF,vzm>P:.uy_dz^8$/ǷTps^'2\o&yWc 佒G _vW?缝9y|xIm/A7US;}7vO CEO}s&Id/->)N7K-$1Hy@\ kÞ~ ><|mIb?O }.r-*s3/e汐N+pN5sٟ7cqB Ӷ6gؾzK% j%~r7ۗDӁW. 5R,oXOiimdb\Xp=ZRr230O0ݭljta}1yWc 佒G QN=\?Ǽ9y<@n`+`~UbM~z08-t'sm@ǫzYƏK0}A@^ynf}" ϼF,W׹dK^[t?sYAD}+TRn|ȵL/s2_y,䷓J>y2ӯF};pܟsy)n5)1$ӵ9YNG6x&K=▯/c;CI?Arx]@ō [cL6+`ܫ/\j|F_S @ugKeXo'|~F=眷?G=wŇ*5H9NAw䎵cT@o?+O?}%9Ӭ;WÚsD|h9itlL0\?,*T`tt]r Zn)?|>U9 ߨn#YbXqg}?g^*՘B~;yÑ'C9jԷS9Qϛ9^QttS˫ԡK' Zn6I.ЅM3*!FRpcS2qyu ĺήArY%A|n<~?ǯ9aR*q'[Z/f9R<{%<WzcyO+w҃GFs8˥Ӹ-l`Sp1b pZ:v]I |twȯ4zͱ:{=><qi!L%[(~UBatI3/jc!ὂG QN=眷?G=oGK}]`( J{E=S ̟>\ G--yN u]Ba)B3wMO"JE 9nnu1spOk^CI}- ks4[:$ 9>x~ ;c9R<{%<Wz89ogzޫ'Ћt=6ݿSY2s>M; O O]ϩ}NC6Pz)#Rp2Tǽ^@-+e "N_TK :y]` B7 ˀ#1rs2_y,CJ>y2ӯF};psx7<<|x|ڼmc%QLⰯM#"C elK ]b5jW,),ؕ|k :$ER\eHy2ӯF};pܟsy>äc,! k=?~)ƼaNUp$B㾔cE|jx'x~_qEMNqٜvr7CYHs<,uLu7^[!Tr#[S?"22yWc 佒G 5y89Q{QZSԀokk+f^sD1o9W˂`%WjRKv/J6 y/ou4=/yC)zOs =H{ӡVqI%lȍqZ=\8<-0/jc!Wȓ~5۩v I]_Qnbתs}t 0t3HϬa18+̽~/pC2| vY ݪ,OE?)PDա?D{1'nï;7KeXo'|8d?_v?缝9yyKqd*=Fc`([K58)_ }c({V3.AyS Ux ~B0χqO9N/RL4|eY[!IbH TK{ףm)dy?g^*՘B~;yÑ'C9jԷS9Q{oeyl+UgW~l5z\sL\9l[@/)ߋ׉7kt)ϝk t'P::_CU;L]Pr1|l9}ɶ?ϙ|5汐^ɇ#/sըoٟ_ez޻/pOPK=-—ɵd3> [v|x"ݶa\Ó~5۩v1.MŭG/K:.Qmh<N0BR,Oz~I }lLpOgE*3KQ%zmrma{*[]  ܉~k&Ih?) 2KEXo'|'jԷS9Q{ś+mg z{@ʿoGJyA99tq9􏺟3^9x [K2 (.ui&^CC ̎5KeXo'|8d?ojзS9y<Zp36/߈m$IB^rsOE}^b;?{sq;ZzcW %GnoG;=Oyx0O2zF?Oz73 )0:;?v.SolycmMWR37;oBM9R<{%<Wz89ogzO8rӯU-cpA~dk pdXm +"޸yӀeĆo3u;` %[}}G܌>Uz\m!CTck}y  }R<{%<Wk,?oQ{;8z־[6Y(=CPtː5 /IvU9O8JRWmw?/a!Ye9)xX_%w*W^%>n~%Νjrco Cq;̒XμT1v^ɇ#OsըofގX;Yy]!(OS9S-z^ނdBo~mrU [؎gJcn\ԁ :)m}kM9R<{%<Way;sxC IRYoI}~,up(E-ؽmćkD.;8"9 YR=C_ s&G \(vqכ/?tgqs]:dό|X1-:?J~,;3/jc!W QN=ͼ9y:wAs%ҁ+A%*]Sb揩.ɠIul;B>xb~|)+N6=t=X:ZBgIߋl*1?/=&l 󷿒a耻Nո'3@r;~1ORlwJGoI|KeXo'|8d?_v?缝9y|s>z|y4=AT# 2=PZWoKݦ(0(|~nJ~s|^vrKJpTOgA0_WpKK8ojϿHkkK˦*¢e?[seq-nhJμNc^|5汐N+p4sըosٟ7#;+Ju{}Jea@x8-Y;uV?̟۟L#;X`/۝N>_w~^IKtcVa.=H M{')g6R|bG;_Ҡ^j-g/`aׯB&yWc 佒GL?_v?缝9y<{N~Ε{湿Xp=}Lg9A_Y`Νdbb_fdaD_|~)I>&?n]?Щ%<AR3fӷiYC0/Wv^ɇ#OsըosٟcP4~AeCKۣ_Xs9na$9R[R8p=St_Krq/1/ I1|2j-q$j>]e-?g^*՘B~{{<qy;sy ԧҖ;^}r /1$aZ6])5LuwAFUƅV>AҰΞ9q[~efW%H D&%_L7oHʜ~}Z dз~\r؋a"IH{;}S4.#1Y`SμT1v^ɇ#Osըosٟ7';3HM$*ZI:OݣOIJlS$?I%IK'bpR]v3Dk SbqZIHO@9s,ؓ0Gr}mWp M:ȥD_oAA/䟣?eXo'Á'C9jz89ogzޫ[`s`h7$ =kPsC]GA~i8AҽW=e^|a~k帻5^" m䶮4t]~b9R<{%<Wk؏py;sCHHMmXDIv0e:WX(Ə'j=Z"8%~)P!ئM0.]k#َV=pΰw/noܱ$V'~%IaX;4)sP3|_G/6)}%M)TיB~;yÑ'C9jԷS1ogzޛϿmb Mc?SN!?+^J.GN*BEtUbύ#BCŇ՟?/_A.7F)6+KlG|}wo`9r0yWc 6|8d9jԷS9Q{U[%;S0RpM?^bs{s-OΎ:zG=[b~)9tKϠs|hN'UiZ6={)?ypTI j~ vulABn+IX7KeXo'|8d?_v?缝9y|5s=]N{qӠ a|'p{N|݄d7sH?L7"~9ACc+]CGწ˥ݶun:9~Hq$Mp쇞V@B`n,ϙy,䷓J>y2ӯF};pvF4఑B0{C~W\l>'GrGh?]eSq}g>Ʒ!Ţ@ug7WŃUa?0eZGS7RXIHz U~#xܛSyAP\Rb{$7/qǺ/"t6Nh|)@N-^Ε$NLm)`KytT;ϤE;9n/ e\k3/jc!Wȓ~5۩v8!>~ϔk޼3]msIj:^]Gݤ5/z憅b֖W ':>|JiR!^}/y?N}*激Y??v^3{H< H~Ϳe:_m{bw"P9?g^*՘B~;yÑ'C9jԷS9Q{yšɁR/0W CK@:m0>F|%gϗ+@CJi[N ,be<~)é4});vqy2ӯF};pܟsyȁuQ\H\ oΟ]jκ^=lUH|Gآ2E7m#Oû*@C/)@7\hh0qJJ|ngשs}k(Ĕ#ÅkBV^hHO+o-. ߧD^e*ԠF?a9R<{%<Wz89ogz rGg^c~8^cl{ S[}=[*헌Wց_?ϙ|5汐N+p4sըosٟg\^l{^kDvGq*<K.rN>K NJsw50Hĝ?%GO6k|*s'Sg?Ə@yI?З2yWc 佒G 5v?缝9y3LA'30!員#q:oO4fJgNu O"ԥzr])707n?nA]IT_r7\9҂y ko$>b'.V?g$zVμT1v^ɇkx2ӯGv}ϴl*j̧c>z[҇x;#ߢ|&mL_00 8#ڢO=ބ0k /֏|ڪsGZCԿS\s2_y,䷓J>\Ó~5۩vpl=߷C!/?m|WIe#/%?vi+foeXpֆwW_Z0p7hSܘH. ?@c?@F7_LO(r`Mϙ|5汐N=p O(ըosٟ^U1?Z:a;:vQ=|ʄZjbpp|*7?Psi:)o5)7y> t9%-7aY|m ǼmO)ZxpIf3yWc |8d?_ѷC9Q{5I?<{T9pIzV kR/8qH>_2oߋ_,>/oy.)m$_q.3Ư|8}|qc{?g>|p|Dzl/!'/*Aϙ汐N+pNqy;s^{:h?\b\'M]/Y_bsVn3yWc 佒G Q?缝9y|:[?yܷ0ӇKuJS+>2|me_$Cnq(^mhz|5bAq8Yf 1J\tM#2yWc ~Vd?_v?缝9y<>z]ErPr̷+RNkrUMTQj8xyV<ԓJ 90`Y //9Bq.ƿqY 9&K 4ra}zkqo?g^*՘B~;yÑ'C9jԷS9Q{ߏ{i`s{{yuDA>u⎴w㟮ǘ:fIkQoTfB]oN_4^|_--$ S͑36KeXo'|'{6jԷS9Q{;>v# :cuOT. 9yKMOGq[t [u1Y$ףۮj`Y@ <.8d;I$n\jg]Y'uU:s%G~hM]eqIW!4KeXox'C9jԷS9Qϛ&Lt_/i> ߏtWί N6x)QڍJ2pʍzzX/^1a>4|#','_ul܃8lÖI4x>1yWc 佒G QN=眷?G=oG8靧#iXm7I qMHgtI$TK%Yt>T+8'Aӭw:#u>#/F9lb~sra-'!eze%* /1yWcKo'7d?_v?缝9yyA~.xcV!]ó cۿ|*p[D)T.3Z7#o[ }b>]7>jwu=ԘS>пWp=x~0?Yg v{C/SB]ZΦB&yWc |8d?_v?缝9y}p׽wz D䯯d OI.L'!9tѦʴX{X^Bg?˵8 " \s?ǖ#F?= FT KI*n@ugaޚ>`Θ> &yWc 佒G Q?9y<~4,M/WIR]G/!>}ߖW:ɺD">(?RopyZ'V9t+ٍ|>(LIvY&LvadEIo7.Dx_s2_y,䷓J>y2ӯF}{c.Q{`n-w0]U,$Ï VARhaޞ*VI_Qtt md&u'c+h7 DZ{BTP&1x@1Qc9R<{%<Wz89ogz<y1nJ$删7Nzމ߯ /L~һS_M2އlLhLjd!`U%j<-C!fI3Cp t咑2]Tj뫈cs2_y,䷓J>}\D};p<9ogz/ҟғw )~;,-XqK0տ)+NKۆapӹ'̻P!%W@d~3KpsprCYPyؗt+ =t)QEμT1v^ɇ#Osըosٟ%l,0?!zp5P6G_WbUQ4=($K{M{͔pQf)BbBb2|IE? {D ( (ș53^߷7$8nqܽZ[_]`] gw)/.e:df=_Uv,M-AWTX>SJ}S1[yG\zFJ17/Ε;+4Q*0@k-ʁ,Nq wKXo'|8d8y5۩cv8ϸAXF软l;tXcAR;W7T?+ZZkl"x譾ǥs])};k.YzpÍ߯9yGfu7>Kjͼ%{ܠ:JTяv^ɇ#Oϟc^v?g9"f3Fu@SoMJٱsr/-|2?ZuՊ3-L9z9?4%sk|n>]uS@Huj (6祜@R<>GꏖҺWNTяv^ɇ#OWz8Yog~<ݵig:Ȏfo.3R=o NNy|'˗N>Tz9+H]Ӯ7[8%Qctz]_hܫ}́i-Vm/$p`:ځ=r29RSSMCª ,Ik-O#WgZ,(3~W]}GTJs_~,䷓J>y2?ñz;s硞渃\/PWNo`4YφNrB L!%7{ M.ޯ5J ]i%_Ovh7A~ٍ}|K }!:cIzߧWeym_ɳޟ9 z/v^ɇ#OWz8Yog~<'Gˢvωt̸i]\F5XO/Rb^F <+jxIϴ\;q$Nck\̻E%kWa{/zCٱY_K bW=$1I\;ݫnֵ8A0yrnKXo'0y2~jзS9_ -$ Hڴ %-R8%= y̆ +C9=:g*7dĜ/}+9g.{=/ym k\AEzM>~Y ߅jzsz5yÑ'sΫQN=笷3?y>vmRޤ\mj8?|Sy Oyߞ[d>L}{6o޹h7=YoWZzӣM>Z|Ւߍ {+C2M/,)BOZd糬Iqr~|'&xs_~,䷓J>y2~jԷS稷3?y{l>I6K5-vr#0ysH$Q |N|$aNrƦC\Kb&?*G8o(^kt쓧SO74)>vs)rNTяv^ɇ#OWz8cO賋{I8c κΜ ]޹lp tD ߫Uï&-~5ٯn)] oℰe#,'-a99,o BZV j!Z-DhBzV!Z=DhCzV!Z#Dkh5BF!Z#D4o¥mv>9Uo?oՊ]h_̗3gX%i?7جape/data/carnivora.csv.gz0000644000176200001440000000673014164530667015072 0ustar liggesusersZr8}`T@R|rTefR>-q&Ux=rƱ)9H6%G tW*L总SN?W뺢/%>}W?uG~oJW]]{ַ]W7WiQ3 oJLCLiWLMh[[*BRK`ػ*+UJ<8JReiR{LH}B)jadVy?qx'ΠեMx#KR WSek׵G!kAk hߚ(Y m8< SLWc t65ZO+Sazf9Xypn_=LҫKM`isqbsj.^ýR'\N},mMŰTL%Iy)Mn]SfWI XEE_ܝn 53jj-ae~?222@Pa>0dIw%ݠ#EH}d d&9`%DY3#S;PvM#U ϟg(3]c&_e9.XH+͜^v\Oѿ'Nyvww o„2k VFbtH#qY?}~7o;$]52A+)8>}ɷ7X;Eu QʕbM;f9VBB1VH rOe#泤}oTRQ03 _o>SC1^f1MF\?96n G 2kXإYT֯Dvuۍ&|WU[Ip vxȮƗm߹Jۙm:rϠFwNbݦz R +) ;`] Gܩܠn;e 2.}]1As\)OI()T9J$ܳR=1RQ%th%jD\ƥ%<6E{gHyL?R3f.,C% ϰ5g~\;ޝQSodesp' ?Ű=ezr9vp+ЈeKgbl$[YJ]6([pS ?S>M@s(fOΨ+B7k :Rٺ+b4Ԫ,Xʩ%0IBMzp:A3xZC~%ul(I6~?|v.ape/data/bird.families.rda0000644000176200001440000000471514164530562015145 0ustar liggesuserse |UI[MCQئMӓCQt{bIdvggx}xZE***߾ߛd?ơxvjǁ-%" ] {OSd*^\9h5_yj_2c^FM@]([oW1W3om@yN]@]y^Ԙ2#c@$)] >ς1gcס ̗2 U|oe̷0wռ273?7@9ϙ[[-%skp~nw0(#Pys PwZ8npP}dNw/ iԹУQzY"pP%Ze3,`@?%>J3:JİB7b?R`_:BDAlh t}IkҚA$u̩$u!i5c)i89fI]x(RiHk2Қf ֌0iXIucYCZ3֒֌uzҚq6׍ flnlf֌Սm9ՍsHké ֌GԍG1fF1fN]ݨ|dv֌^Қq!Қ1#~FZ3KZ3H43\DZ3.&#Hk㩫0O O$O"OfB]x*uubfIkMZ35!Ik f<֌֌fD55#&~hF´Ѥg@3ɴne̳fгfsfsffZ3Z3 fЋnЋfK2/c^0QŴ^_05uPOk^xuAgߔdnVe^k~ }CÛu`LK: 7!vFnW?x"W0ape/data/hivtree.table.txt.gz0000644000176200001440000000200714164530667015657 0ustar liggesusersuM$' ]HB,&§w~f {Y*JDVoo_|+2뿿*>=PZGfCyL X~bz g{Cπ #"7\%6[U~r֑񛻟RpcOk:ulT?'T'w (8[+ƈ[,1[jNAe. 1˧=ZO4;an9y2':wNKuJ;3_S3 mwB[>PxWj[G#eր(ӷd`n?JF`+}='vH5m~Tm˵Rhlc󕈻+P쉦+IIDŽ;1k]OUoOZP Y Lۊ?^$+y s`uF0,0^*lD%Ȓթ+rEճȊ3&W.uc*\'ƞz+󻱭̕"yc{b+ӟ< +͒W(%{.|fJ[,ڤ^K!ؙz+{6p{g/63>exGG6*3`YF1gYKgY:ttF!r8䌼KټNݕqq[Tޛa8hIKpqcĆOtV4 Nq[9یZ_i] \a@\Sn͍lߍ\lvWP Cf.<r\hW4kn#Ƽi6͈n~(ЫjkE!)zee3a_~TaRB;ko@ d nvg/V$O"]}i|yͻkƗ߯0|?u v ; {˾OYQžvagy*w*#*IS {>9gݹ͟aO\6M13 `o{GМ/<BRHqoz9kyXS οz1Uo/U0Z/#~|zm2܈ռ)sMk~m6l^}Ye9:i"Ff\%M3c4^_'j/oV[.˺'@+A?zrD =[E_jcU;<'_bҕpe)^=Y<'W`ZX}rf-o8^$0;)[YvMwhci3O{OWǡY0x~Ə`>\v)4*|5||eR*oWRֆ魆Lgqc}knRWCa`f*Yۣ?P_c z߷{'._&ބS;xok? VWWI-URv]Js.W7$4o^+SGM=F7nU{nt}ܟr1q .5:$4ؿTU'dgx8%9 m9}5])UMȿ3sZ\fV8y nY/.}/oU8U}=BwZ> .'B'*dj1|O?}⏏a-ҳךr Aim.?:uܻCa$)݂a{6/j;aE; T.=}s`-4T0%^`""tǠ;XD>3pO%pٮ*~+zx\~Zž7mW{W-E{dk 쁟dHh|}m_.Mq$g~<v>x'FtҀ߲4c?=mun/)eBP`|hIF;ϼ }EJNm-V|u ΀%J^VN{3|&[Jmxuhg޺DӚ o5?9N#xaGŜcْ&ݣ´6.VcO'Y^AWb{h_A~,}0;X6 _b\C%|<"vwUF<-Uf iWǗxH%nY d24W۟Gu(I5q ?!nuZ?{Ď*8'tp;w(!XĞa2+O%d"ק^OYi]#5Y=#-Oϩ |_Gu#ooGl[qؓzʰ$/~b#4:W:So 0S{n4V^q[*fY_f~jvyXU~*83쐯hg.>=p~?88F(0^jw$B2NhevRNH9Џso+ 2F,?~gW>=n"EԦC?WO~YMWMKL C,C:X^d =G(? nev۔ua桁#`ST^1:YuEn+'ܦ04 2()_uo7s,qT=>Ιvf??!˻fu!":DžX3$Ңg_a? 83_\p6:{x:̓Ӯ&=w}s2:;ۢ<ֶjNڄ px7NOo#Ч73;_\}gy y-ߙO^ aߢ/6MWU?.Ň!.AGwIVA+V+mCv R$N8'Ec%#pL+qmI}~hwé΀0k3~>ybkግ]p hGٹ B~;r,_3թ"xWe=]> ]`ֵ(\J-fáϡ>e-s7w:tC1aj.jkӹj08m[:Z?Ǝ]g:_kM٫KŽY,p~<0A*8^~<9p݆mںNim mp⽂sr9aL>' {2z +m|;r#k`tı-U;Y[O=P=ke6G\myAxGiO\f&7rQS{DQ޹~X~쳱:k1D3V_1Y=>{.[J]`}- A %l?Iﰃ3-l~|t=wYǝV[b/Xʷk97{azSOT53?S?|Z~ nABи4 }S> 8g:&ܕָgj+|N<2DW *wn[h 2 8FQTR/pŇ#p;cy:5wMQ9KG}&(PK;ʺ}]QxT=_L DۢY-V?͙d|_59o-@ +)yc=&+=j!C&1ٜqWY^ey5_5.-O(:$6Wzf 5 6qEuqU 80t- 1Sk]pUn϶s+#V='ʾ Чr''%fݲ鞮5\5nش^#YS+B|lN:js cO AM?|;x'?Xq0iSXڜ]Jj0ku()?q~MVh x*JXꕚFFV̅#^=BEe|~j߾+'>H]W|TϓOKΞ0=I-]~|;0}\짜и ) -췎?>}:sn, I+|ﾯ=3Upn6|gw-P4pqջfֻFӟ}aCJp.H>>'=wpqZ+XXi#/s9Y79HYQx`nq4ER7և39;8,a i0 ̤_ Êz5 "|T#E,,^WM >>y/^U{'Qee-4ǖA;yʼnp+H>a f ‚X`=ö'\wOm\>5)I;(8¡}Gy#OU'ѼC>zhVpO<@soR8f3  LDp:߰}e oܗN! lAoOKuGȝiSb/d9zO/WqMZҼz*<+XW?b%'_O u-i~3Vy+ϥb!lj;E bR/>׺Atj*ʏFwa+CW>B[ȕ0>tG'q4q* oH6||_=Zσ.;߲_rwNtvFx[B/zQn2" BeK7moWy2(`Og_ϻY'" 3zg5G /׬q> !9N+軔{x?z\JΓPa>=c#+$^kd zahdzǪK?C(h~a-O՝^vs^)azZSp.pۼp3tvJuٹ:[ X ;!-WB'/1د ]|Vc}s"u]߮9V(~ýka v..+r>Ι+ Gs7a( 'F-xkC2 6!^"s7ZbUv-YħFo,.l/tdonanhm3O 8|bs h`48Щ6ݩX7+b')\*Ƥ9avb0?t2|ҹ9zpec}8lihnkqmVb\TQ|؏ ^o<Նl}Se!m!s'7d'["|fX}J7:XM|| QwY a;Y3s )0; W 0oo߉m(hbl01ģ0qhI]틳N0zsh^7?+<Q4&wz]&y)N\64yW?1"2?W|T#E; x-ABg Pgo> ex~^ `8o7  ~7j]zQ:1o7h5l +ʥYNxT?  Lc叡$l'!sOvGW;4Pp*I~IuSF@jmpv7ڴb_m~? vOAú{5<N^Ϋ__#H v#^v#Lph/_aMk!<3Άt[_ wy&b0 l®'둝ec3N΁!/8ěz\{4ie_BwIY.k] OfJȜx},Ŗf8-cwbe]w 4[;-忽{]Yأf(7gdHO'£ ^'V=^I)M~?i$t5ncգ.rh/a,v[0H`[-0u`){o`(\Ʋ]&lGQ{)Xaᤚ yCt&Q{,q7X ;s?éKaŏA'G]k)hpj~vϩ'[_ z)6gz kAe+>xjh#s#;PpU;b;@ \ex!vZֻzB'1M`%a}?M:p_ nsQ>(w~y$߭+^L^A#c΃hDMNem|'-hߗ\E`غ Kݡ+t:&#L<.`zN߮9dc_`)*:b O~FeH/đX{|Z;3;3"^s"| ! ;Owxݲ>[kۯӿY _ X_sڐHmApzexT{\\-:`oapH|=: uUNfy~MY]zZ?nPŪ-) :{w4s[ݰ>&7snܮ$Ssŷ+|N<<.N ZI51&9#n%q{?ap$/=!X?64uh*J\Is]JE‘kbQ8s!@}+rӡO~5_օ)E`Єl,.StSMRtT034Tl$LAOue -X{J߮pj~vϩGWYjH-17zf.9z~fۂZ9U\h ՗=e-Y0sqavbcg pzaoz a I^)C_1Mߞ T`uŬ!GWpA3 +I4]j328~>.߆Ӑc6@ڮ#vi]nܚ[+⶚ufӑ9xh;YYABoWz85?W|T#롯;aIXC.zi UoՀ~k_~+ji¤bs/am ~{1n{N88: zW-]뉅`}lܧ:qZh^vלp4WJ hn-趁Ѕu;1½VY*}.͹,_B/Y~D߮pj~vϩ'@-\'e)N6bVB4ͧ礿ps&ݽ\# ƻ%XbĐ,@k-EA!WȷYBPNj!(YhG>#W@Cy>O:FWFL?.o->X}/a2o?@΁H8Ex.Mn_/hRvSsŷ+|NK"Iu"g9sY%__(_Tߧs.4A7buE,skoz}V4߿>QΝ51~}Uݍ ,g e]"/|3h!6BmzCE"u]"vé>zO8 Eݟ L\6}f7lvT]^9`/&%Ϗ[o',t'UC#>n\; CеF4  &k]0Hc>+H|KzY6f)@xA\|O]j/;\wsf1-^aD殍J``#@]N[lTy!)}A#01ݖ.{/ATHgܲm+hafߐuy-<8}Mb1 V^ ioEjJ߮pj~vϩG#Qg>ޔ~o8{@憮_>)e@W֬eݼ:_ywgoi ^R7~ =}9qAK)H* {Yx$v lA+%҅Dټ]3uӵ#%9=*?ku`\'K/$ZsҾ?sKE~%WSNNyd=/}p'O83Rgx9h6AVz.? ڦ,q9M]9NeW7X%?/_AeEaF!dC`ԣ•!ꔈ H_AFICp-!e?ä.(`] jP&8u%ke:pr6v.I])XWOx`(BWyH/aϗvāybp{+)}é9>zY¤_K WdH.N]0vMɋ':ЮK*?W~5oWz85?W|Tϓ;/oDx8[{_];A ;k E[Dry d:5 K :ς`)JjM#TBPm{ ObDl3;UaO_^rzEݗ~,?W~5oWz85?ϩG#WN9e᎑:7K8M>`7P]F^ ✐|s@4Ǭ PvAn~af |? ba:5!'r=ro*O&?'ҷ+=+]stLS)v5 QK8^'k0k4 08î"ɏ5=kh|^Ƕ+9<h/|Oz:n5\5|9r~WQg8 c\oh$47;b-+$r h324H(ٸ^'\)Yc+Ty2jJ߮pj~vϩG`҅ca>,΁7pz61Wj|"]A'lq+IΫ2( wϐ t.o ƔswfU/~c&lMb7Dv8IY-n0AEmo<* L.__s$OFϕ_-o'=+]s+~ :OɔpYY"竏OG)zjCOGj7  igAnTy)o^Q c=$;pi!S؛vA.ϫz>w3ӥ.!ߋ̋7C1 ;Jhn慻)M/o@+.}wOuX+<H+ҷGp4?W|Tϓ+e)0f Wr{iw~`TO{>2@~^t)D#C_ƃMsk䁂Kx.sRbIGK~33ؐ]FHwq*+; 좨³~ X'8J,>\&}h/4>tQtn<?W~5oWz85?W|Tϓ_QR&zHu72+A"cD19gA,BMD<yNxKWyW˶ <ҵI땼O<^$]w>]?76oB"[ ?đ{R?pYsz ms;!A<Vs#砡 %oH\Ք]<·>zY{X˓b}H9H mnf.ͯqE| 8)hjc M>Lؠ8 nG:ofVd}nE~f F5bI}!Vque| ԧBP c+7]QnL .]=" 6Ǧ`D[ aM1֘wS #"p*OFϕ_MەN߮9~Vz¦$I åG{04>)pe}y0Ki\ƭ ?O4hnワ?'g``AQ)6uA![黳iP2|px_S $&/05ET+ҷ+=+]sI-(.c\H?72Qx!lIY'8<0;0 k.CL| Zpm$GQպKHR4zvCL}]xOX d(: em 'l썝RL>FdCwb34_xsi*8F"y24R~5oWz85?W|TϓFʱ`hi4hrA\6w $\/INǠQMNM:h#V-4}3@Qz~CwY- Hpcm0B\A YmS1/{<7_QSz L:'ȹc].é<?W~5oWz85?W|Tϓ_n{P Eq7yV/!^2!P ;iNO}o\G6MWpO`['}9V=vOC֎ CyOAVGx\*:L^k~Y֟[ ^VØ.swBd~|&'!-yH> v{+Z>{~Mq !9_Q+ZtɃ/M9v|xz7{Up*OFϕ_MەN߮9\% [s .炤&IͿ/ pL 4i3i} I7:km8[#B4 ~"L tr4A3WE>+XMyA_+ ,ʇXka YcH~M,S(Ué<?W~5oWz85?W|{zY\Ug )_j.C2LRyoƬװ2H'hQm7wcf>yfYAp#[pH4O9,xO0hn 3u^*?FEUj$ߣ|nA“TޫʇSy2jJ߮pj~vϩ'.gi ƧY񤻊%_Ny(0t>-),.NGLt'!_Isx!?D@ ?cbO{m;9. ~=߈!} ATEcq#jĐ9|\qğx+&_ F^U>ʓQsWSŷ+|N<A9u/_Y? Zk?$u&4o8O,>.""t*O2NOy~szbpi^|dibeE<;8dXnckCJҡH_OadN*Ué<?W~5s߮9yual]֕'1}R.Hk8n\S.Gi 9Wp6\\c|K[Szx%̕Jc\ [@x ]A"tφ㇗`}C%RNWKUAyA';kj?ۙ,oWy*N()}{DGspŷ+|Nt:v] j)_y+ 4J.maqh7m߮^U>ʓQsWSvSsŷ+|N<-%=m{RO+`EO5pE3 p`_|}F)]Y<ر0s]  :AO725L!G>vRGT-LR1Ѐ(]彪|8'ʯ?SsŷG|m OS.W=[^!.܁y/ʅsi;;xaMgOݍImn y wbK2OecGxpcQ~ՙ\19b_uJRkz*/vC;YWtӥ|zʁU۩vT+ҷ+=\d~N|{z?6B^̝vᒞ׹$!mv-YomIoX".HĠ\:tTk:+v\Յ-v뷹1SOh'rafc<3쉲2 0s$Om /N7芄{'ݞWy:DjuuoWy*N()}éyo'|N<>ܨ[ &s}}pHh\S;D1n:92цc 3gpm%WE1I/Z9hr_o "( X!WVK!%o&=0˜NSlwMb;OBIIx EZéÃL\| wTOvD|ny7,UʝёWSvT+ҷ+=+]sI+Za,ݹxty=JqCҫ VY&s44<[OeޑY| ?K84r\7),s-h:]h~qĵaῼ ٤k yM f#g('ܷ@已P{P_MǢUޫʇSy2jJ߮pj~vϩG=&/ϕ}J<>:-yd=|k.«-sYd> ;nspW]{\a:⢻oAdke!]^]CW3DS[_QnFx7~W_G"ۼ<9EA#i"}_-r 巫Wd\Ք]\ S=mM~+b(R x|r>'rc5@`p"߆!^ͤ}d&tclua u4TGsH㐾ޞ$}qgC\TCdަz/MZӼLݯcQ*Ué<?W~5oWz85?W|Tϓ`Mik O3czЊ %bI_FxӽU¢|ܠ爁b9wG27Gķ+h0hќsB +qY(;IDw]ZG]uajdFKxLC~5uoWy*N()}é>z\߉*I?+d?B?/̰KM0CN:'|&_Mz+h x-#9цC5n(J`p{AzV欪DL8x0Cqx2s[?=D:,.[-sTuE巫Wd\Ք]\ S=g~%^3A 2!\ÿzEXk""A; Iȭ!a H|& UHi V a!pFBe6iT/Ҽ/R~5[:TڢQ)#BWO=2O#NGs.3r]tFWTuE巫Wd\Ք]\ S={*A;x a2d^m4'+s߮^U>ʓQsWSvSsŷ+|N+"93Iy5c/C4 S~CzPg^_1} ugN9t*] T>ʓQsWSvSsŷ+|N Þ'u `"HFsbb 1F{4w)H8Rs38LdPtSĹiF/-u )Ԡ{o >낔ӭ?WFWX"T+ҷ+=+]s\(DXpx-oB<(W;> 8n!|dN"v̿q7ݘ,pg\{Cn+͈8ү"LbpĞ9gL~}*_ww֜HPGK},*]彪|8'ҷN߮9 @~}QMB>M.A`VTTϑ3eO/)صrfN3kbY}M\MW0͵7EIQR.xydz`אs2[w,`1Wrpi8S6+x}~5uoWy*N()}é#\ =R)أܣu:㖒/O@xC(a}^'1߮^U>ʓQsWSvSsŷ+|N<+l!~gŵԐ>C>mҘK0#[rIQ_6K ࡫{Cɗo_ܪ *[9J!ƺ&?K{@%sW L0)YU"u=k-}~},߮^U>ʓQsWIoWyQ# .g-FrhN7k%q  ifd%]ʋs|`ߐ],:K&:ǨIGWvSX?@sK=q=4vn&6vw?7^sF~p*-tGTuE巫Wd"s)}éyo'|N<J#N&lr8h?:G(ʟI^GgDDX%G掁_M<|#Jo8>k+ p&shǥ?Y(0IEs۳b=w!@WKUXT~{Up*OFϕ_MەN߮9xCO⍊ _X^P1'ex샣T6hsO{|1x|o.۩)G~&mP۰_1Hx2ӯF};pܟsy<&N}tQ1d\Aǣ)o|ÓI}%n<%Q rs9gwInZzY85WN2薻1z×nWá<1zZ_t]*0³xɑk|3/jc!Wȓ~5۩vʠw8=r3És$?Ԁ;~y\o\X_7Th"S4e])mHW^P`‡xʷIcK-$19=7*gzݳeւyKM9R<{%<Wzfy{ӟ}e[VEгI\(^ĝa(/.ήwЏ__ǜ$ȹyN/r¡Nؾ(JP*sP\Pc%of](INc9Vy27~5۩?ycsɡg#/o<4ۥ rvK.XWsbOo02l=T$[s3V H{H yEp[^KRaO[KBy?$rklrf޹9T\>7yWc 佒G O5>?缝9yx#)|qMRrU[0?s:N*qfПpKN[wu}s[dw#cW[HR4\A9l?uV!L7CJ fxZ^jZ:J[J)W`s2_y,䷓J>y2ӯF};pvϛ#<=׾?-ż/J>- kqc)p? EWgJ׻zC_`!+PM_qy5Ô #C>iTb?./~]< vސS)(3/jc!Wȓ~5۩vWpyls8֓y()ttmPR$+H#eה4ISMSĿT!t%rOTH+ %ZEA'A$CW뎿0W:TT_~qw\okyJ][ZyI2=( )8?g^*ըK&Wȓ~5۩vC۱~HaۣyM1a1ە`O$A( r,23U:A`>0m֪ϫYRĤlNUȇ4fPGr.,c {7)/ҁ$E?g^j<{%<Wz89ogC"aZ^\-[~CR'$eYH~n2T=_` q׫?g^*՘B~;yÑ'C9jԷS9q7#_-/k{(z?vCZoÎ9{8 [C񋚿*t>CԥAOҿ@ wXh%Hxm@]Lbi`U4ô`SgW \/-lq3/jc!Wȓ~5۩v-p"w1LUϭj܈Oս|8~= @ <xCˇq?{kk>7oP.9.-?*+8 N+ϙ|54v^ɇ#OïF};pv1>&Ge#KnRTU?MMp' UL>vu&x~/mCb']Ǯ R>.Jy z5}[[)Z9ܱʅm^a`s2_y,䷓iQN=眷71Z9uo|*tqx %tF0lxIcx$eo$sKgOksE.Іjؖ@Tc^6y2ӯF};pܟsy<"컙K 55W҂} 1bXo'|'9jԷSy3oG/>:j^<{A0u cv999̱F}RSOU$'O_csHJ;N]g/L0)yQM|a7O~5iϙ|5汐N+pNqџ>?=l'?}e?u?k|r-f:AK[TiB9 =oN?|s߂+>rqFw>&,tеuױ﹜.U*|8Gvdqz3]#ϙ|5汐NpNZoǼٟcy0?FA_a?>ʽ ;{\s2_y,䷓J>\C~5۩vϛA]\9կ*`?J]lneӣ_ o#ᇘf: >;1-2ΐ{<\,]3 __6.^AwT8.Dž?KDk sP=`>e3/Z汐N+pNqy{ӟ}?E8C/'| mS aݐ 'p4E2c^ n7Y.+jJ8&s/?̡S 0oNw}mOd[8H^"d9R<{%<W"眷?}>N2ߗjРG>g8wfRR {/B*Q/Kep l?_c1<_qEЁ*CWW`.06x*9]c,ίi|lNm+6j&yWc 佒G QN=眷?}>M}o [KDc2g>B87>縠N{{\r{7;};7!/솾6RGf,ė2P7u[u.ο,J1_y,䷓J>y2ӯF};pܟsy{.d1~~D(`KRL cE/ Nr9Nx1/ Osεa<&ݻgiݍcYw%}cf\4c[{*У&U ߆z>2_y,+pNqџ>[Ћvm@.] eJʃ$/4PI`X$ӵA_% Ե|O!W{Fָ%x:/++!18?Yϙ|&v^ɇ#Osըosٟ>_2ޟJ@頢:~gU'b=|Ӹ|KeXooxÑ'Cz89ogyc^Q:smh s)Js+4NwRrH:\*!^l,EIRБvxNs2_y,䷓J>y2\~5۩vߋy.88ZW_|bq)Wԅc:Þi+'~]>nqtѧ_RgsνVUs0 8k.$GV7ˑq'8= 5-L%W 8)/K_j뒁%kϛT䫱#Wȓ~5۩v~9Ƌ,`^INa7_ХQdo$@N7v.YGARd]~I57>TuDx IyD=Jn0$%sOٯCSk^_@uD?1櫑B~;yÑ'C9jԷS9q7#5,ߖy%ɫ+h)E_@y: yRC=c%Ryҁ.itV}?/=.I1_wIn1~IK/sJG.1x]yꂤ~Y 'ϙ|&v^ɇ#Osըosٟ>oG ~J=st\vvg|9F|$KH抻eJmvh|k~))UA/TW=;[5B3z8 x:XG|H\t _U7q+QAfs2/jc!Wȓ~5۩vr xNP1`n1Ǩ~a Dmu_Us-1ߑ!O:t18O^qHJ Z}Gyݖ+ǜo :5D | ( 7y1v^ɇ#Osըoop؟7vv|ynORW:W.+SKڑRg|RT^-x7_Y9XJrĊЅ.suh{"n.% \j;K}j-{嘟>,nUo?iϙ|+汐N+pNqy;s jB}RI2=ƸӐ͇xpg2"-J6PEfI_^Y :]#+œ{wUuV7KȷtGwA?So? | έGEM|3/jc!Wɓ~5۩vةW7n>u& ~:;CDg?ŸouNFk݇ؗd3лUZf+jܖ5:뎞șN.3d̍ܰbp9?Gȏpctt@F_a?g^*՘ByÑ'C9jnz89og?o|qp=j]O7}O;/q;\$?ĦKP$؛ONQ9uXmtd ;a˴A̍cp2䗶B<ٵ$e|v~1tYRp2[ۍk]Yr{_jR}f&yWc 佒G QN=眷?}<{"YV'xWݥCtA-N%?n!m ù莘t~6H }uXܡriw w-,X|ߓ 8(D~{о{3/jc!Wȓ~5=眷?}?0њǝ9q[-ϵxYa^ZP\~hRB/k .}o->)[j\w7g9zAd\\߹NR|WWkϙ|5汐N+pNsٟ>[/=so+dk#7 k'#a·${!QXCh$nϡ0$Qtwq<\|g<BGLW}ջ3KQ2=_۶Y{y2ӯF};pܟsy<4A4cz? ?.|:: XGw5@.J)#ږUE}l۽s[>WW^-1g27DNJ{]7):Yո*]5NzC4ٟ1/jc!Wȓ~5۩v8*hѷBrڊ?$R%sCaA*vrI>r&}h98#4n{r5z|z\͆ubm㗓hS͊9 wSc{μT1y24~5۩vϛ3xG3KgioM~9rzb}˭^m֐t!u\ ,sGdfL! KDc6=As*ˇϼdN>W|{z=c $ ]?4KeXo':8d?_v?缝9~SAU%8b,B8~ {U5~m!p߂j#T<$o"%-w*{]tT~~m5RK`Xx-BЅOcUq՟87Ŧ+逫?g^*՘B~;yÑ'C9jԷS9q7ϣkˠiAOGr"<*DsHSdy%^ͽqA46 N:0YS"ZiuɄ2]wK6KeXooxÑ'C9jԷS9q[!N>Εü"5n{W  >= F_⾲H尛I-IiU9WQ];2YqR3 dȝI07*QԂmb]'H6 X#nQM9|Wc 佒G QN=g؟>Bᥒ>y:q1tY96_B>eX]%ksOJ0^yRp.vq~jKKZ˞n d> SGd $޿aIU~y[bQ2pn*9rܲaKɃb)."`+%3/j䯒N+pՠosٟ>oO|K]>o!Cޤ h'/cuZxmyշ oNqJ\$^Nr`8CR}nuc'4ҿ"Yyz|iJWKQ`9R<{%<Wz89ogyml &u5MHr.n%½+5 ϓaw!=Ucz||i?YpKܑ`K3;Uh+m5}Az?=tM Jq#}(ޛ0m!yGL}~ڑRYM9R<{%<Wz89ogy=pOYaڼC P$.[˷z y]'= ϡLOq{g`: e +GVZ,#8B6GcMwRL׈0.I ە=?]q/ae9R<{%<Wz89og?D?Pqᵩ8yYapX;r<_ˎoO 9hjp&9.r(ݲ6#7uX_g~~# \{O,r)Bgѱĝ<7s2_y,䷓J>\Ó~F=眷?}޿ߑ<$w/_?|/mx;t(>z# ._uBpj7eII?_U!~Wyי>9{[V[D2Hh S%KRQrp `9R<{%<Wqy;sypn@ 녥C/"nztu][ZqtUS|33>ޤѦ4z1rOb9R<۩[opNZaN9q7c*ȗωV@ot}L잋 >0TOmx%*(}]Rpt:椩VSJR@/㙓LO8~b[>BxMu]cuos[ӹ6|e.%|s5KeZ~;yÑ'C9jԷS9Mny~(GMy~О~{$#{6kbXV[T ՙJ!LRE!oV\YƊ_xEΟx-/>ur3-VsJg)>A8O3x'>=D6v0w?g^*՘B~;y5<QpyߋXƶwȕHvUEM]GY`ޱ櫽CTY^sx<9'ِ6dXeaS IG2u_>R׃#d9*.Qhy} BZҏ[-=k14k޶}\m1"]*,9dLB$buA}rĽo#6[[beZ{s2_y, Wɓ~5۩vϛCD 5)ǑĊM_rSn|ᴾO-4\Kܖec_]q^=G䈎VȿԷỮvU^~tw=O _/ϛT1v^ɇ#Osըosٟ>Km펝3tb k'"?VBOe5.n 0F{҅Tat@]~+w=>7U2NRbBvM*Wv/iLcf\_37${=;0G`^*՘B~;yÑ'CyWz89og/¿=-cW=,9/oW?7$z?=4` ~^x D.) ϸ<XIK-ZNwu8yV[w^,2+2 fƈ9Kwc5?g^*՘B~;yÑ'C9jԷS9q7cDdv0]/L=N7` =.t`#L'~s3wT,IyqS]W,chQٶΑ\QφܸKLos2_y,Mn xÑ'C9jԷS9q]KIU<<5[) Dשi$\b=Q?rf_o&yWkXo|8d?_v?缽>Sx\jqHA?ܰ|"%'ףOz2r<jz?0:଴ЏC`O6SؗK^$b^q.%R&?s2_y,䷓J>y2ӯF};pvI^jF_VciwЉA޺G/O5~c2i ۷vnaŦ ŷd{QU!x?capcGC8gK0R[jas2_y,䷓J>y2ӯF};pܟsyD[:ZKBn2~RM9R|5o'|8dѯF};pܟsy<>ay.і0?u~{P-o==G$rSVZ^+8 |s~p(u*k>5߮C`/Ck0?~H~zO j&)j`jϙ|5汐N+pNqy;s~yrQGLgn1`TxNa~iCH!]5*kXg;:vH\P0(I S9CFU˸1yi\~0MRc&Vw.{EAig]/! ?i>1 _y,7Wȓ~5۩vɹ6H¯JïeTdz//Eώyб%ƴRx;._V}&a’H[/>º ({a1ѫR0V{f} +@çs2_y,䷓J>\ÓAN=眷?}ޟmUio%S,os ^12~48u4RQ*~weЧ~v{Wc*~ ׭ύMQܦAn~-C^OP/vC]c:"R͞6}nnC;O?g^j<&pNqy;snXK,K ^_tL4te:[2Ť\K?K2_Ё BͽNND8Zf%-Do(>!-mbz}~:m]/vR`9XHs د1yWkXo'|8d?_v?oԷN뵣 Iqo3kݬݸccoŐ@ߓ * .* 8u&2:=O0sfV$1sχ%g~)t)%t7ӯCXs2_y,䷓?Nqy;sz n|"2AGq*O `Ѕ$ C{)!Ł1.g}qq*{!sR o -eƊVg!7+n͸ϚsΘ<{%<Wz89ogyPיX'`J5IK=#)q? Ǧ2>O\׽۾`jA-؟ho9S܈g*xQ샻zv;{UR4}?M9R<{%<Wz89ogy;OMe@bݟ\`cI <{⴯J0dL=rpژgC]a !Rlo9|(>~Y2p"L #>&o=+8K}Ζbm|˩[s2_y,䷓J>y2ӯF};pܟsv? M]OE^_<5y(3KzG%^TכaSx6V&^cexG)i^̭M1+]rU읦YDR9eur#am}Q?^׈4KeXo'|8d?_v?缝9_hsJsZLRT)/0Q'B畩,~%Վdz~n4~m'N?6"18BQK._BlJEz>zagō'_5Qs2_zL{%<Wz8ϛy;sϛц2)_hAVߡ,_AV$n{_:sЁx+3NvlkIS$ 1bNob>6}Af8_](?ZEKn3ms㙶SaT3/WCKo|8d[_v?缝9}]i {7T çҲiAoku]mЙL_ O%+Mוt0dTrk65nC cDƇː> |kkZɺ#@Q.3Jy3/jc!Wȓ~5۩v/1-Qw'wc,׈mrcޖSf/%^+ [mG.#.w0ʡ+0W ϷX]Gͷa }z/|$+"OyX3/jc!Wȓ~5۩v?qsSCK ]lt38Dž]~=twQesS@ %|8= /،%N2p,O=D'k$?'&/jc!ὒ QN=眷?}<&U+5B:F [Ht'NQM xZ@|t>' *1@8՞qD{ a]=AUƺy~>>.80 0g?G^*9c!Wȓ~5۩k瘷?}?oS/^c0a H MoaO,riǻ]jz{Ts`iéˤ1Ш bBn#y.i_n3 L~9ϙ|5o'|8d?ojзS9MnQ<:ػpӶezdũC qpepNToY]xoHJ<ߑWkRLG< zsJFE$AOKVʒ+pO1`9R<{%<Wz89ogzD( BC~\&2?l$yDPX:r̡WL%80U~sBP0Xu SǁZU__=3/jN+pNqy;s&B˹H /b/2ao=|cuf(J>jvCUJ{?@=kM7P-w=>%P0TOǽ sOiϙ|5汐N+p Osըosٟ>?j/t?]5Ʃ.[^ kV&],q1,*t2`cL(pMԖ|%D#t+t8[ό1Z Jk&1᷃J>y2ӯF};pܟsyŹ-rВUŻ\s/8>wwl#ћ6#/anSL_2%ɿe>n_@#̐#(ߦ{>-C(ųxJȒk羓r>I諒.$Ky,䷓J>y2ӯF};pܟsy>=x++HVM $ES1gVKiˁLyic?Q{!ӉI Ԧn)C`N!_8q#.f p0C6|\%1xvŅ#WiD|VZs2_y,䷓J>y2ӯF};pܟsykE~֘\d?Vn&Kn=;M*}xO$n~aJN$z0wO:<яMSѩ2Rs>'m7_t!!V8d=c?[ʗH5`]ܥp9(v9pH/ @0Ksjݰx~,?Ѻ?g^*՘B~;yÑ'C9jԷS9qϯ'PrƳ2rc8Α̛uhpL?|%MUg: C=ZMb#upçӿiYg\'9Vc}[h8Ȼ؋CoR(ODN7ϙ|5汐N+p Osըosٟ>/h)_O0N졓#RivN?l}YyI>uV$AnȞjȐOdP/ IW͹sտ?5oڪ]Wȍ/؃ ?HW1Ȍ%MpPnd*9q"LܞKeXo'|8d?_v?缝9y"m%Cl6ƤgnP9SẈ*e/On^pO<>/m(lS߫wBG3\D"pbga1&yWkrNo'|8d?_v?缝9y3 sw|#ΠQ-?}rq:JmpRǸ@KsK T^OceCzOww^v X[<lh%]4KeXo'|8rA?_v?oq+ӡvOh1I!ggztw?HSRs*$gokA${bAG+fPq+\qԸSi^F1}9@9xkn8<#H1+=txѶjϙ|&v^>>ӯF};pܟ7v}s2~8rw-+s&77l(}])ײ9 i-cI)ƛ~S'y;IwHaR.]2 ԁUX%E^V3,oo]5,X;0yWc 佒G QN=眷?}?+(m*RT~q=?X۴S^i|"`vTv؃OO0L2$y|*E-X3;?*,1tWyRFLYlj}xny%)MXκq_QZNG{Z|ߏ>};/+J2P7'/|cl.R34 f$&wwlW#[{]U?wE令 8e$^KeXo'Á'CyWz89og?W†2wk]ExtEPS|)Fπ>d5=%RA3T*!j)^g4> ]H\y mB])F_[[[^J<7nSD_9?g^*՘B~;y $Wzfy;sy#om'c>cktq 3uμTQM~;yÑ'C9jԷS9qm)~_}6F,BƆ_ߩNhO M mT$xOR%<8&^Eb3S/q|INV' &yWc 佒G_>_ s 8_缝9~=~'"oekt-heJT7 =i(?n(8@]f@g AqG-y? w涹ӱb5Wh@t_ Y=ϙ|5汐N+pNqy;sHp_ǀ܂=4Lj]<}Wo4'e?(oxKWKAX QIM?tG9lN/nݱ-:(qμT1v^ɇ#Osըosٟ>oG|X~Ka;TK_׉]/+i,'{69ԩV#9TmJz1MGްO0_rͱmK0XFJHv6Yv Lŝb(G9 ؃iZ&-䟓;|5汐N+pNqy;?T6Gq?ztGdp$`ޱ}YswT}]7Yp.ǙoaR῰ r ]K|+U gx}Yle.)KeXooxÑ'C9jԷS9q;ެ_=ΧVcw ='ggw7?79$A~u%$ |1p>I0˸_-w x(9U]WD'GIkL2NH;ϙ|5;"|8?_vxsy9U>:xg9 Þ-n~GOHW t=uQ/Ӟ|DrCu9+kc%ݙk3$e]xi] O D[휿.L}Dܹap< W &yWc 佒G 5v?缽>o0meF=8GnHm9+KKeu6-Ϧ{B_]>E"3!zm[w2v}Bn"~9g(>7nT]i QK[s?!.$ӴB"?g^*՘B~;yÑ'C9jԷS:vC_9& 숓_[$IB(hiaA_W~mh>Svs3R:Qfg/8{{;T^D3zh}c sߞi|4]G9N|˻p)H*}z[*P]Ke䷓~5۩v- *pp{Wi!$ rO'iK:Z{[һ,u˕gW҃^t&CU5nt]GN ”UN qe(n];.zAy^ۈ:g&I:KE[HA}[VBc14{Klk}b$7c-wb=:GBUs2_y, WȓaEqy;s/҆A"oR[,/c-mYDt1$)}tF@{7YQGu` !M!G3揔\KYS䧴5d7Gm`\-1?g^*՘B~;yÑ'C9j ?z89ogyCOZѯȥqR )X\ >V'C$O=luQIspWնTN-k9: 7_Q|5TYRu}q[ΫC~觘μT1v^ɇ#Osըosٟ>ﳐ'e!b\b̅x~|D]%GşG )[{S}\>#ݶݷ]ظ%yzп-7.[V_d̩μTBN;yÑ'C9jԷS9q7ϣ*\q7#-hD [Dc+nhѧ%ѵ6=^ȟz<$CK]:2n +}E}eP}ݘIzbv9 Ivί_?ѐμT1v^ɇ#Osըosٟ>o 2rc& Njͽ?2vNfNE_rsq"kA`unöYv x)aXܘϗûGBYtCN|5汐N+pNZ㳄sٟ>`yZ2p?rna/g odrIz֪KqX +ns^w]&1c\juzs'QtmNC eŽnz~hovrt~0xw&^KWZnO5[m/ӡJ_TÛíB @9rɼW֔!lR^b~OW8S ցZ(xqmϑG QN=眷?}_aO ?<٥ᾏx7c0 J}}O|=Yb=;N7})@'mRCuugJ=|:^4KeXo'|8d?_v?缝9~1FnXN :V߫|ɑbtvzK|(<`~HQwЧS=t#0O602)?%\i}Ѥ9H_On T;x AQwp ~$\JtS Ue\21v^ɇ#Osըosٟ>@|׫m_IJ_p8b m9so_.4E'YݛC.^8QIïojpo,/y2ӯF};psȘs&w$g{;b F-d+ݷŃT0UPȥO /x5U{٥!#":CO|JmJϙ|5汐N+pNq9 sy 򊪵zz+؜7>p|=GWc%d{xJN-_` cӵ 9L4Ym>}+quuS$G_VPҗT/2ߝ_z\?g^*՘B~;yÑ'C9jԷS9Mny<һh(Ek}h@duClgll?R;8yH*f' (SaLZyB|pw=$&#){K9#S,Gb:"ȑ3#Pa_f!A eVA^tNU̥kZq2rݯ]+՘B~;yÑ'C9jԷS9qw|9f =9J^\[h7ɰw*xJ2R])wc./Dd0:1l˭xyd.ߤEcvx_)|w{/Uf?/O5pjGμT1v^ɇ#Osըosٟ>/pO>#u[R§}q7%).H \|'':XOr>^J,'#eQ|?;.,ckjGݨ~Bz¯Io2?羟jc!Wȓ~5۩k眷?}S_J׎υa}qmo;s7O5$ z }/5n_uGb+IݖqVySʽHW KAFC'M.[@ݒG}s2_y,䷓{G>y2ӯF};pܟsyނ0vfϋUx3R3ſZ}gQgWwHKqN>H^9Xce%87 ޑyڟa>1!בTuK_YI>| =:yFOUAMᑯ<{%Nqy;sy#Ӱ?H+c%oWlqp^#0u'w3oܩt]dv#dh%jXrk/MS~qnMJ<ưYY_V.^ ӯK%ָ$ s2_y,䷓J>y2ӯF};pܟs% ˤ?3=o|S9Η6(@"̇@<[/:1wra~MNV~@}os'MgQH~uk'.vMu= ~?:{sCK_׷A6-oϑ|&+yÑ'C9jԷS9q7ǁLX§^MX9:4@sЎ.A'N+EtTVxD^zRHz/%"[A4?;ݙ̗R!'2k{OUXP\J1ϙ䫡&:,ȓAN=\?Ǽ>oG>cG([8cmO݂<5})ۯWY?SAVR[kcS艓 ۺc/Ӂy\m{#!m!> qBcunNecs2_y,䷓J>y2)۩vot'KJjdZ4T9[z;S)JCt%R /fN x"e_7v:"-"YXǎ ?L}WiV +w)sd޻w)?сCs2_y,䷓J>y2ӯF}{cy;sO}|Հk@X[fvE. Ct9ўpwsbgaCWOor}BG+ t$`(s9X>AS@W%< @4K*[԰'3/jc!Wȓ~5۩vϛ1 C ʚ{re%ߣ G-?b&TQMMR3ٗ>aZ߷V803?o}Wb>Q'M 9tԋ*VU~%+ \ Q]e]$'vOZVQ:nwcu2#p/VX6sSp?9RF?SpNOՈowx89og|Edct4ߴz.I}jyLـKnVֻ}V1C:>KX;I_XH [С;$Ǿ+,oiS0go4ki^-~KXNW9=W#x8?Gf|,@8_ƌ ҷCRF3>gb -'\ezX 5d&%eя%_z%,Y[5%y긧ʿ>}s?K;7 bGL :)=D5Pzԇ N<眷?G>z i=˿mCU3DI9t2GR2C{tՕl`Sk vۀo}i ًMv4JB5;k/Kl`~Y*Levh^'!pcXSs8s_~,o+'C9jߎ9[5seYo6r6ɿt|y}La"JQЯ ?h*ڸ'N_، sٽK{Z\W5}7 ";ϡnM_8+'As_~,o+'C9jġ9ϑaSK5гSF  x1qF~PϤ2ZRC7 B2Z,|‹UFBx9a#p0?")+jַZ9gmbO8b/#fMYbr/jc~;^G=W#x8ݼ9> LԽ@ ~Ty,{H"#]Ƃ&3zmkՠe/Iz~XS/ؾq~@|s#5rx ~3䵍`?HէɆ14Wiw+^"9RF?Spԓ!|5ۉv~lʐ%~[[){$g~ļجDi(".fI|W>gl$Ğ*-;${07>yloan$W/ݮL?GD5Pzԇ 9?y?w6ϑMX>aDUO1'͡ЄCb.9ݩ83yBZ^Z֫}0r?Z6 ]Ь)nQ aYY#(#ЋT3B$?Z=2l12t w*c~W ۩J}8ɐNqy;ss|_azf%aiCN9s6p:uK %ERwj?X =~ IWl_M+<s~)1=wL vQ4Zp=,urNTя{>d?'_v?wzl5]{5L2O?6w^he;*Tuwueܝ4N^c㏽hhhhhV*>ZGhU|V*>ZGhUU}VѪ>ZGh=K/s<ѿw_xS Muް.lsM1999u^ 'ape/data/bird.orders.rda0000644000176200001440000000106714164530562014647 0ustar liggesusersen@K&q(Rwhҋ`a uSPEֱx$c;^^׀w@BĂ Vg!>?cWA0Q5Zz.bh:RyJ y1 .7`1up nt]p#nOJ>\tsZi[Ӏ&тN:Wsimg6ܮgowξy[[^_J\ɕB<[*877nŹKef+o9NO}cpww+qU~k[nj8|C}'nP|Ǭ' ~TÉߎpw}紻W{<'?#[S}o+V3K89A^i/~x/NT/yzpEB7>9yaaPꯌ?o;wćv0o/C&~~ ?~Ol~ڡ޼opc=}F1?8|Ss.~f5IK*K!馤[nKc(LvaQ~l^/h(?Fape/data/woodmouse.rda0000644000176200001440000000221014164530562014442 0ustar liggesusersNP](ABMK'P J]xŢݰR! T,>yTq}2Qb|sΙq|r=;>β ;8˃~]>~_OwYv8ɲ?jcbE,-˭-G3ޛ7;ޮuw\qN,`z$,/K2Сj84x8 4/+: p x xb@<\:1`a<\^^'wˤw\:ʝwt[ĸUna0?Q=j2Í[]7 N&4doMoP@zn#&mT/o?خ _z @0:IoJ:ݯieyhj/&4W!{`,^Cܟ@WO rw6{xͣ{ xGv 4=L *J%L.`< L%Ij7t8,Z f3kkk3%lFktG,f^b/z:_d: ]_s%ft["%}LmL E4d;ZjCZ,=e!b2 YJp?j"d[l [W%L.=[@F)6RDd[񨭅P,$ܖND4V(q5y&cyR8"J[(M~eRM*vg?n+`-XE&W01m>xnUJ{V%pt6X2 vd#.Ǿ:FIgPOĈav6Nvps=;Zc_$>b|zZϩK tVwYe'ndNs-%< 'ſ%{ape/data/cynipids.rda0000644000176200001440000000132114164530562014245 0ustar liggesusersj0l0vQ lvӻ؎+؎8ic Tׄ6$P8/j?yQJ |qG?Ue^yُWe 4A! B*:)ZI6{Ie&/i,SC)r70vH]F-T)Y"EنK/+#0C IlR$Y0KU,f$2ϫM td|x6碻!qld;sĝox?<8RcKreOCi j {cDW|h OԖi?YdJA uR{Zv m`̫0eb^q/}dO'7={H<0G/s8# MO z|k/܂!wjX{ 87sKHyÃ|P WUQqyn'Tf#0hл>?~wǛ i?v^If%hcEwÜ6 yhj eJO/CzX `0uA>(KwN?{%eR1^^0jػx48"H>(Km7;뇆H wڀ}qbE@Wpf ;~ynAdEtɏBCD?P`sjO1cȀ/ V {lBS-;Pܮ( lTPZ'n*2Ŭౢhn1/S|P Ix؉%`:ߨHWդi_ߍ u&xNi, LSVo,߿F [)8ĞkksK, e=Asya>@]=8DI6V+P.]ljsš=7uSc?0)B8D\q6v-Pr鈖D}ܷp`>=rK>e0>zp\)O}ܷp`cba`n1/S|{[땤JV T}Z)c&ɗMr6i"&ɟN6J8G'8O'8Q *5>tXJQyL'Z gAEj.?ye ape/data/lmorigin.ex2.rda0000644000176200001440000000070714164530562014747 0ustar liggesusers r0b```b`bbf H020pi< #faZ> _$ 'NJ6΃y8<,y_%OOʊ22Ykśc-x"9|_Hvfm!ˣo ~Of}J{6u*S0m㏚2kޚ68O߫nM JO{1_3oU۹!.<ơ%7Ǻ,uWD8i;sïBR[W4JN- YsS H=Ln ̪Tt900AĒD"h9m 8%bac`bacX`XBE.4222229._Mx&ape/data/gopher.D.rda0000644000176200001440000000234714164530562014102 0ustar liggesuserseU PTe^xL8.<0N a@;@$ X(jZ(!% j>>p5@+@`@Qv߲;s={gg;8e%fm̖&|aYoL*؁m6=wA+n4nfjAKׯN^R[T)SzBs_ o)(%j0'Es|Oyh;d}D>K:TiA7TCaﯶo)>i_ jq^M FELظ^+՗MkY <LQ7NJ| .kGhcz4::Zu:>_W2BKoXTMBAU8 LHXO(, >8sFC43Zʅ>il3,i(orۀit,ZLbQ>(}zR;A|-b&op8gKpiDGYפ9Tn1L 0wWfu3чeο`K}"!G_8gKpi c#SXpqپ5|PT)nK^h]bPL7¿"仺LÖnarB}qȗ>Aip8A^e {nލ= K[}d{7u,JNqW/\GA&^]t=t{_yN2 _:嚭z#K(>/}✑/}tzn=T ];4WՑCwv^򺞾R| dP_3%Vcѩ =0(dWW X\pWb}xV/TsAB}qȗ>.վn Ҙc3r`T<'9yEs/3sF!5*{4 ͘7mOӺ&dŧ9I ywG+| .CƈG(-8OgI+ _GWD_3%.΂.GKϘ; _#3 9#?i蝤,{|(}JH+Z*VAZF &q/Wq+2+l|[( ǏE"LxO\ =^?ɾ6Өape/data/hivtree.newick.rda0000644000176200001440000000421514164530562015355 0ustar liggesusersuXMEm/p@ c2##=1ciYY!q@+Ffj`^Uf狗g/Oӫ?;\~|vz}BϏwEޟ~h{ҷ\Ko{xek!Ny_ZVj~Dum£RKvBy?v= [[ $ )aϹrOy=C7;ԗYDfh"nok -p4;T~=CIIykkYm[revCi}q [(Tq&3mj=mya2ey-7USOmB-{4_l{q{=g{!AaFqk@IFAVFi_>3{KZ8ມ4-BkHOoc-LIÄjk]g2bu. 6oQehyZfnk`P@5 ЄY$9} +'63t6qAu:?O>˳+bE])*hO˲n:h].%76|̴"Ktsz̽,t$pJ}OF5wdKfE;ww3q(B<*x4JI`vOMN-q:"^+^MZl/#~ۣZD[%ձ"dn/@G>zC1[8K ^ON5NHc#@Kg^s۶V;cEr%s\SdzHOB}Ue02a#zZo+Mʐo,}/ ZcIik*mry5ݿ 2 R-;F<)Ts`f*+0&^8CH %5EF== 0, variation below this value are considered non-significant.} \item{option}{an integer (1 or 2; see details).} \item{\dots}{arguments passed among methods.} } \details{ The test is based on the distances from each tip to the root and a criterion: if \code{option = 1}, the criterion is the scaled range ((max - min/max)), if \code{option = 2}, the variance is used (this was the method used until ape 3.5). The default criterion is invariant to linear changes of the branch lengths. } \value{ a logical vector. } \author{Emmanuel Paradis} \seealso{ \code{\link{is.binary}}, \code{\link[base]{.Machine}} } \examples{ is.ultrametric(rtree(10)) is.ultrametric(rcoal(10)) } \keyword{utilities} ape/man/trex.Rd0000644000176200001440000000501014164530562013045 0ustar liggesusers\name{trex} \alias{trex} \title{Tree Explorer With Multiple Devices} \description{ This function requires a plotted tree: the user is invited to click close to a node and the corresponding subtree (or clade) is plotted on a new window. } \usage{ trex(phy, title = TRUE, subbg = "lightyellow3", return.tree = FALSE, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{title}{a logical or a character string (see details).} \item{subbg}{a character string giving the background colour for the subtree.} \item{return.tree}{a logical: if \code{TRUE}, the subtree is returned after being plotted and the operation is stopped.} \item{\dots}{further arguments to pass to \code{plot.phylo}.} } \details{ This function works with a tree (freshly) plotted on an interactive graphical device (i.e., not a file). After calling \code{trex}, the user clicks close to a node of the tree, then the clade from this node is plotted on a \emph{new} window. The user can click as many times on the main tree: the clades are plotted successively on the \emph{same} new window. The process is stopped by a right-click. If the user clicks too close to the tips, a message ``Try again!'' is printed. Each time \code{trex} is called, the subtree is plotted on a new window without closing or deleting those possibly already plotted. They may be distinguished with the options \code{title} and/or \code{subbg}. In all cases, the device where \code{phy} is plotted is the active window after the operation. It should \emph{not} be closed during the whole process. If \code{title = TRUE}, a default title is printed on the new window using the node label, or the node number if there are no node labels in the tree. If \code{title = FALSE}, no title is printed. If \code{title} is a character string, it is used for the title. } \value{ an object of class \code{"phylo"} if \code{return.tree = TRUE} } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{identify.phylo}} } \examples{ \dontrun{ tr <- rcoal(1000) plot(tr, show.tip.label = FALSE) trex(tr) # left-click as many times as you want, then right-click tr <- makeNodeLabel(tr) trex(tr, subbg = "lightgreen") # id. ## generate a random colour with control on the darkness: rRGB <- function(a, b) rgb(runif(1, a, b), runif(1, a, b), runif(1, a, b)) ### with a random pale background: trex(tr, subbg = rRGB(0.8, 1)) ## the above can be called many times... graphics.off() # close all graphical devices }} \keyword{hplot} ape/man/unique.multiPhylo.Rd0000644000176200001440000000243214164530562015543 0ustar liggesusers\name{unique.multiPhylo} \alias{unique.multiPhylo} \title{Revomes Duplicate Trees} \description{ This function scans a list of trees, and returns a list with the duplicate trees removed. By default the labelled topologies are compared. } \usage{ \method{unique}{multiPhylo}(x, incomparables = FALSE, use.edge.length = FALSE, use.tip.label = TRUE, ...) } \arguments{ \item{x}{an object of class \code{"multiPhylo"}.} \item{incomparables}{unused (for compatibility with the generic).} \item{use.edge.length}{a logical specifying whether to consider the edge lengths in the comparisons; the default is \code{FALSE}.} \item{use.tip.label}{a logical specifying whether to consider the tip labels in the comparisons; the default is \code{TRUE}.} \item{\dots}{further arguments passed to or from other methods.} } \value{ an object of class \code{"multiPhylo"} with an attribute \code{"old.index"} indicating which trees of the original list are similar (the tree of smaller index is taken as reference). } \author{Emmanuel Paradis} \seealso{ \code{all.equal.phylo}, \code{\link[base]{unique}} for the generic R function, \code{read.tree}, \code{read.nexus} } \examples{ TR <- rmtree(50, 4) length(unique(TR)) # not always 15... howmanytrees(4) } \keyword{manip} ape/man/checkValidPhylo.Rd0000644000176200001440000000125214164530562015140 0ustar liggesusers\name{checkValidPhylo} \alias{checkValidPhylo} \title{Check the Structure of a "phylo" Object} \description{ This function takes as single argument an object (phy), checks its elements, and prints a diagnostic. All problems are printed with a label: FATAL (will likely cause an error or a crash) or MODERATE (may cause some problems). This function is mainly intended for developers creating \code{"phylo"} objects from scratch. } \usage{ checkValidPhylo(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \value{ NULL. } \author{Emmanuel Paradis} \examples{ tr <- rtree(3) checkValidPhylo(tr) tr$edge[1] <- 0 checkValidPhylo(tr) } \keyword{manip} ape/man/rTraitDisc.Rd0000644000176200001440000000756714164530562014156 0ustar liggesusers\name{rTraitDisc} \alias{rTraitDisc} \title{Discrete Character Simulation} \usage{ rTraitDisc(phy, model = "ER", k = if (is.matrix(model)) ncol(model) else 2, rate = 0.1, states = LETTERS[1:k], freq = rep(1/k, k), ancestor = FALSE, root.value = 1, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{model}{a character, a square numeric matrix, or a function specifying the model (see details).} \item{k}{the number of states of the character.} \item{rate}{the rate of change used if \code{model} is a character; it is \emph{not} recycled if \code{model = "ARD"} of \code{model = "SYM"}.} \item{states}{the labels used for the states; by default ``A'', ``B'', \dots} \item{freq}{a numeric vector giving the equilibrium relative frequencies of each state; by default the frequencies are equal.} \item{ancestor}{a logical value specifying whether to return the values at the nodes as well (by default, only the values at the tips are returned).} \item{root.value}{an integer giving the value at the root (by default, it's the first state). To have a random value, use \code{root.value = sample(k)}.} \item{\dots}{further arguments passed to \code{model} if it is a function.} } \description{ This function simulates the evolution of a discrete character along a phylogeny. If \code{model} is a character or a matrix, evolution is simulated with a Markovian model; the transition probabilities are calculated for each branch with \eqn{P = e^{Qt}} where \eqn{Q} is the rate matrix given by \code{model} and \eqn{t} is the branch length. The calculation is done recursively from the root. See Paradis (2006, p. 101) for a general introduction applied to evolution. } \details{ There are three possibilities to specify \code{model}: \itemize{ \item{A matrix:}{it must be a numeric square matrix; the diagonal is always ignored. The arguments \code{k} and \code{rate} are ignored.} \item{A character:}{these are the same short-cuts than in the function \code{\link{ace}}: \code{"ER"} is an equal-rates model, \code{"ARD"} is an all-rates-different model, and \code{"SYM"} is a symmetrical model. Note that the argument \code{rate} must be of the appropriate length, i.e., 1, \eqn{k(k - 1)}, or \eqn{k(k - 1)/2} for the three models, respectively. The rate matrix \eqn{Q} is then filled column-wise.} \item{A function:}{it must be of the form \code{foo(x, l)} where \code{x} is the trait of the ancestor and \code{l} is the branch length. It must return the value of the descendant as an integer.} }} \value{ A factor with names taken from the tip labels of \code{phy}. If \code{ancestor = TRUE}, the node labels are used if present, otherwise, ``Node1'', ``Node2'', etc. } \references{ Paradis, E. (2006) \emph{Analyses of Phylogenetics and Evolution with R.} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{rTraitCont}}, \code{\link{rTraitMult}}, \code{\link{ace}} } \examples{ data(bird.orders) ### the two followings are the same: rTraitDisc(bird.orders) rTraitDisc(bird.orders, model = matrix(c(0, 0.1, 0.1, 0), 2)) ### two-state model with irreversibility: rTraitDisc(bird.orders, model = matrix(c(0, 0, 0.1, 0), 2)) ### simple two-state model: tr <- rcoal(n <- 40, br = runif) x <- rTraitDisc(tr, ancestor = TRUE) plot(tr, show.tip.label = FALSE) nodelabels(pch = 19, col = x[-(1:n)]) tiplabels(pch = 19, col = x[1:n]) ### an imaginary model with stasis 0.5 time unit after a node, then ### random evolution: foo <- function(x, l) { if (l < 0.5) return(x) sample(2, size = 1) } tr <- rcoal(20, br = runif) x <- rTraitDisc(tr, foo, ancestor = TRUE) plot(tr, show.tip.label = FALSE) co <- c("blue", "yellow") cot <- c("white", "black") Y <- x[1:20] A <- x[-(1:20)] nodelabels(A, bg = co[A], col = cot[A]) tiplabels(Y, bg = co[Y], col = cot[Y]) } \keyword{datagen} ape/man/ape-package.Rd0000644000176200001440000000335614164530562014234 0ustar liggesusers\name{ape-package} \alias{ape-package} \alias{ape} \docType{package} \title{ Analyses of Phylogenetics and Evolution } \description{ \pkg{ape} provides functions for reading, writing, manipulating, analysing, and simulating phylogenetic trees and DNA sequences, computing DNA distances, translating into AA sequences, estimating trees with distance-based methods, and a range of methods for comparative analyses and analysis of diversification. Functionalities are also provided for programming new phylogenetic methods. The complete list of functions can be displayed with \code{library(help = ape)}. More information on \pkg{ape} can be found at \url{http://ape-package.ird.fr/}. } \author{ Emmanuel Paradis, Ben Bolker, Julien Claude, Hoa Sien Cuong, Richard Desper, Benoit Durand, Julien Dutheil, Olivier Gascuel, Christoph Heibl, Daniel Lawson, Vincent Lefort, Pierre Legendre, Jim Lemon, Yvonnick Noel, Johan Nylander, Rainer Opgen-Rhein, Andrei-Alin Popescu, Klaus Schliep, Korbinian Strimmer, Damien de Vienne Maintainer: Emmanuel Paradis } \references{ Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. Paradis, E., Claude, J. and Strimmer, K. (2004) APE: analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289--290. Popescu, A.-A., Huber, K. T. and Paradis, E. (2012) ape 3.0: new tools for distance based phylogenetics and evolutionary analysis in R. \emph{Bioinformatics}, \bold{28}, 1536--1537. Paradis, E. and Schliep, K. (2019) ape 5.0: an environment for modern phylogenetics and evolutionary analyses in R. \emph{Bioinformatics}, \bold{35}, 526--528. } \keyword{package} ape/man/apetools.Rd0000644000176200001440000000321614164530562013717 0ustar liggesusers\name{apetools} \alias{apetools} \alias{Xplorefiles} \alias{Xplor} \alias{editFileExtensions} \alias{bydir} \title{Tools to Explore Files} \description{ These functions help to find files on the local disk. } \usage{ Xplorefiles(from = "HOME", recursive = TRUE, ignore.case = TRUE) editFileExtensions() bydir(x) Xplor(from = "HOME") } \arguments{ \item{from}{the directory where to start the file search; by default, the `HOME' directory. Use \code{from = getwd()} to start from the current working directory.} \item{recursive}{whether to search the subdirectories; \code{TRUE} by default.} \item{ignore.case}{whether to ignore the case of the file extensions; \code{TRUE} by default.} \item{x}{a list returned by \code{Xplorefiles}.} } \details{ \code{Xplorefiles} looks for all files with a specified extension in their names. The default is to look for the following file types: CLUSTAL (.aln), FASTA (.fas, .fasta), FASTQ (.fq, .fastq), NEWICK (.nwk, .newick, .tre, .tree), NEXUS (.nex, .nexus), and PHYLIP (.phy). This list can be modified with \code{editFileExtensions}. \code{bydir} sorts the list of files by directories. \code{Xplor} combines the other operations and opens the results in a Web browser with clickable links to the directories and files. } \value{ \code{Xplorefiles} returns a list. \code{bydir} prints the file listings on the console. } \author{Emmanuel Paradis} \examples{ \dontrun{ x <- Xplorefiles() x # all data files on your disk bydir(x) # sorted by directories bydir(x["fasta"]) # only the FASTA files Xplorefiles(getwd(), recursive = FALSE) # look only in current dir Xplor() }} \keyword{manip} ape/man/mat3.Rd0000644000176200001440000000111314164530562012727 0ustar liggesusers\name{mat3} \alias{mat3} \title{Three Matrices} \description{ Three matrices respectively representing Serological (asymmetric), DNA hybridization (asymmetric) and Anatomical (symmetric) distances among 9 families. } \usage{ data(mat3) } \format{ A data frame with 27 observations and 9 variables. } \source{ Lapointe, F.-J., J. A. W. Kirsch and J. M. Hutcheon. 1999. Total evidence, consensus, and bat phylogeny: a distance-based approach. Molecular Phylogenetics and Evolution 11: 55-66. } \seealso{ \code{\link{mat5Mrand}}, \code{\link{mat5M3ID}} } \keyword{datasets} ape/man/mat5Mrand.Rd0000644000176200001440000000051014164530562013713 0ustar liggesusers\name{mat5Mrand} \alias{mat5Mrand} \title{Five Independent Trees} \description{ Five independent additive trees. } \usage{ data(mat5Mrand) } \format{ A data frame with 250 observations and 50 variables. } \source{ Data provided by V. Campbell. } \seealso{ \code{\link{mat5M3ID}}, \code{\link{mat3}} } \keyword{datasets} ape/man/subtrees.Rd0000644000176200001440000000205614164530562013726 0ustar liggesusers\name{subtrees} \alias{subtrees} \title{All subtrees of a Phylogenetic Tree} \usage{ subtrees(tree, wait=FALSE) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{wait}{a logical indicating whether the node beeing processed should be printed (useful for big phylogenies).} } \description{ This function returns a list of all the subtrees of a phylogenetic tree. } \author{Damien de Vienne \email{damien.de-vienne@u-psud.fr}} \seealso{ \code{\link{zoom}}, \code{\link{subtreeplot}} for functions extracting particular subtrees. } \value{ \code{subtrees} returns a list of trees of class \code{"phylo"} and returns invisibly for each subtree a list with the following components: \item{tip.label}{} \item{node.label}{} \item{Ntip}{} \item{Nnode}{} } \examples{ ### Random tree with 12 leaves phy<-rtree(12) par(mfrow=c(4,3)) plot(phy, sub="Complete tree") ### Extract the subtrees l<-subtrees(phy) ### plot all the subtrees for (i in 1:11) plot(l[[i]], sub=paste("Node", l[[i]]$node.label[1])) par(mfrow=c(1,1)) } \keyword{manip} ape/man/phydataplot.Rd0000644000176200001440000001452514164530562014427 0ustar liggesusers\name{phydataplot} \alias{phydataplot} \alias{ring} \title{Tree Annotation} \description{ \code{phydataplot} plots data on a tree in a way that adapts to the type of tree. \code{ring} does the same for circular trees. Both functions match the data with the labels of the tree. } \usage{ phydataplot(x, phy, style = "bars", offset = 1, scaling = 1, continuous = FALSE, width = NULL, legend = "below", funcol = rainbow, ...) ring(x, phy, style = "ring", offset = 1, ...) } \arguments{ \item{x}{a vector, a factor, a matrix, or a data frame.} \item{phy}{the tree (which must be already plotted).} \item{style}{a character string specifying the type of graphics; can be abbreviated (see details).} \item{offset}{the space between the tips of the tree and the plot.} \item{scaling}{the scaling factor to apply to the data.} \item{continuous}{(used if style="mosaic") a logical specifying whether to treat the values in \code{x} as continuous or not; can be an integer value giving the number of categories.} \item{width}{(used if style = "mosaic") the width of the cells; by default, all the available space is used.} \item{legend}{(used if style = "mosaic") the place where to draw the legend; one of \code{"below"} (the default), \code{"side"}, or \code{"none"}, or an unambiguous abbreviation of these.} \item{funcol}{(used if style = "mosaic") the function used to generate the colours (see details and examples).} \item{\dots}{further arguments passed to the graphical functions.} } \details{ The possible values for \code{style} are ``bars'', ``segments'', ``image'', ``arrows'', ``boxplot'', ``dotchart'', or ``mosaic'' for \code{phydataplot}, and ``ring'', ``segments'', or ``arrows'' for \code{ring}. \code{style = "image"} works only with square matrices (e.g., similarities). If you want to plot a DNA alignment in the same way than \code{\link{image.DNAbin}}, try \code{style = "mosaic"}. \code{style = "mosaic"} can plot any kind of matrices, possibly after discretizing its values (using \code{continuous}). The default colour palette is taken from the function \code{\link[grDevices]{rainbow}}. If you want to use specified colours, a function simply returning the vector of colours must be used, possibly with names if you want to assign a specific colour to each value (see examples). } \note{ For the moment, only rightwards trees are supported (does not apply to circular trees). } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{nodelabels}}, \code{\link{fancyarrows}} } \examples{ ## demonstrates matching with names: tr <- rcoal(n <- 10) x <- 1:n names(x) <- tr$tip.label plot(tr, x.lim = 11) phydataplot(x, tr) ## shuffle x but matching names with tip labels reorders them: phydataplot(sample(x), tr, "s", lwd = 3, lty = 3) ## adapts to the tree: plot(tr, "f", x.l = c(-11, 11), y.l = c(-11, 11)) phydataplot(x, tr, "s") ## leave more space with x.lim to show a barplot and a dotchart: plot(tr, x.lim = 22) phydataplot(x, tr, col = "yellow") phydataplot(x, tr, "d", offset = 13) ts <- rcoal(N <- 100) X <- rTraitCont(ts) # names are set dd <- dist(X) op <- par(mar = rep(0, 4)) plot(ts, x.lim = 10, cex = 0.4, font = 1) phydataplot(as.matrix(dd), ts, "i", offset = 0.2) par(xpd = TRUE, mar = op$mar) co <- c("blue", "red"); l <- c(-2, 2) X <- X + abs(min(X)) # move scale so X >= 0 plot(ts, "f", show.tip.label = FALSE, x.lim = l, y.lim = l, open.angle = 30) phydataplot(X, ts, "s", col = co, offset = 0.05) ring(X, ts, "ring", col = co, offset = max(X) + 0.1) # the same info as a ring ## as many rings as you want... co <- c("blue", "yellow") plot(ts, "r", show.tip.label = FALSE, x.l = c(-1, 1), y.l = c(-1, 1)) for (o in seq(0, 0.4, 0.2)) { co <- rev(co) ring(0.2, ts, "r", col = rep(co, each = 5), offset = o) } lim <- c(-5, 5) co <- rgb(0, 0.4, 1, alpha = 0.1) y <- seq(0.01, 1, 0.01) plot(ts, "f", x.lim = lim, y.lim = lim, show.tip.label = FALSE) ring(y, ts, offset = 0, col = co, lwd = 0.1) for (i in 1:3) { y <- y + 1 ring(y, ts, offset = 0, col = co, lwd = 0.1) } ## rings can be in the background plot(ts, "r", plot = FALSE) ring(1, ts, "r", col = rainbow(100), offset = -1) par(new = TRUE) plot(ts, "r", font = 1, edge.color = "white") ## might be more useful: co <- c("lightblue", "yellow") plot(ts, "r", plot = FALSE) ring(0.1, ts, "r", col = sample(co, size = N, rep = TRUE), offset = -.1) par(new = TRUE) plot(ts, "r", font = 1) ## if x is matrix: tx <- rcoal(m <- 20) X <- runif(m, 0, 0.5); Y <- runif(m, 0, 0.5) X <- cbind(X, Y, 1 - X - Y) rownames(X) <- tx$tip.label plot(tx, x.lim = 6) co <- rgb(diag(3)) phydataplot(X, tx, col = co) ## a variation: plot(tx, show.tip.label = FALSE, x.lim = 5) phydataplot(X, tx, col = co, offset = 0.05, border = NA) plot(tx, "f", show.tip.label = FALSE, open.angle = 180) ring(X, tx, col = co, offset = 0.05) Z <- matrix(rnorm(m * 5), m) rownames(Z) <- rownames(X) plot(tx, x.lim = 5) phydataplot(Z, tx, "bo", scaling = .5, offset = 0.5, boxfill = c("gold", "skyblue")) ## plot an alignment with a NJ tree: data(woodmouse) trw <- nj(dist.dna(woodmouse)) plot(trw, x.lim = 0.1, align.tip = TRUE, font = 1) phydataplot(woodmouse[, 1:50], trw, "m", 0.02, border = NA) ## use type = "mosaic" on a 30x5 matrix: tr <- rtree(n <- 30) p <- 5 x <- matrix(sample(3, size = n*p, replace = TRUE), n, p) dimnames(x) <- list(paste0("t", 1:n), LETTERS[1:p]) plot(tr, x.lim = 35, align.tip = TRUE, adj = 1) phydataplot(x, tr, "m", 2) ## change the aspect: plot(tr, x.lim = 35, align.tip = TRUE, adj = 1) phydataplot(x, tr, "m", 2, width = 2, border = "white", lwd = 3, legend = "side") ## user-defined colour: f <- function(n) c("yellow", "blue", "red") phydataplot(x, tr, "m", 18, width = 2, border = "white", lwd = 3, legend = "side", funcol = f) ## alternative colour function...: ## fb <- function(n) c("3" = "red", "2" = "blue", "1" = "yellow") ## ... but since the values are sorted alphabetically, ## both f and fb will produce the same plot. ## use continuous = TRUE with two different scales: x[] <- 1:(n*p) plot(tr, x.lim = 35, align.tip = TRUE, adj = 1) phydataplot(x, tr, "m", 2, width = 1.5, continuous = TRUE, legend = "side", funcol = colorRampPalette(c("white", "darkgreen"))) phydataplot(x, tr, "m", 18, width = 1.5, continuous = 5, legend = "side", funcol = topo.colors) } \keyword{aplot} ape/man/kronoviz.Rd0000644000176200001440000000166214164530562013755 0ustar liggesusers\name{kronoviz} \alias{kronoviz} \title{Plot Multiple Chronograms on the Same Scale} \description{ The main argument is a list of (rooted) trees which are plotted on the same scale. } \usage{ kronoviz(x, layout = length(x), horiz = TRUE, ...) } \arguments{ \item{x}{a list of (rooted) trees of class \code{"phylo"}.} \item{layout}{an integer giving the number of trees plotted simultaneously; by default all.} \item{horiz}{a logical specifying whether the trees should be plotted rightwards (the default) or upwards.} \item{\dots}{further arguments passed to \code{plot.phylo}.} } \details{ The size of the individual plots is proportional to the size of the trees. } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}} } \examples{ TR <- replicate(10, rcoal(sample(11:20, size = 1)), simplify = FALSE) kronoviz(TR) kronoviz(TR, horiz = FALSE, type = "c", show.tip.label = FALSE) } \keyword{hplot} ape/man/del.gaps.Rd0000644000176200001440000000326614164530562013573 0ustar liggesusers\name{del.gaps} \alias{del.gaps} \alias{del.colgapsonly} \alias{del.rowgapsonly} \title{Delete Alignment Gaps in DNA Sequences} \description{ These functions remove gaps (\code{"-"}) in a sample of DNA sequences. } \usage{ del.gaps(x) del.colgapsonly(x, threshold = 1, freq.only = FALSE) del.rowgapsonly(x, threshold = 1, freq.only = FALSE) } \arguments{ \item{x}{a matrix, a list, or a vector containing the DNA sequences; only matrices for \code{del.colgapsonly} and for \code{del.rowgapsonly}.} \item{threshold}{the largest gap proportion to delete the column or row.} \item{freq.only}{if \code{TRUE}, returns only the numbers of gaps for each column or row.} } \details{ \code{del.gaps} remove all gaps, so the returned sequences may not have all the same lengths and are therefore returned in a list. \code{del.colgapsonly} removes the columns with a proportion at least \code{threshold} of gaps. Thus by default, only the columns with gaps only are removed (useful when a small matrix is extracted from a large alignment). \code{del.rowgapsonly} does the same for the rows. The sequences can be either in \code{"DNAbin"} or in another format, but the returned object is always of class \code{"DNAbin"}. } \value{ \code{del.gaps} returns a vector (if there is only one input sequence) or a list of class \code{"DNAbin"}; \code{del.colgapsonly} and \code{del.rowgapsonly} return a matrix of class \code{"DNAbin"} or a numeric vector (with names for the second function) if \code{freq.only = TRUE}. } \author{Emmanuel Paradis} \seealso{ \code{\link{base.freq}}, \code{\link{seg.sites}}, \code{\link{image.DNAbin}}, \code{\link{checkAlignment}} } \keyword{univar} ape/man/bd.ext.Rd0000644000176200001440000000644414164530562013263 0ustar liggesusers\name{bd.ext} \alias{bd.ext} \title{Extended Version of the Birth-Death Models to Estimate Speciation and Extinction Rates} \usage{ bd.ext(phy, S, conditional = TRUE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{S}{a numeric vector giving the number of species for each tip.} \item{conditional}{whether probabilities should be conditioned on no extinction (mainly to compare results with previous analyses; see details).} } \description{ This function fits by maximum likelihood a birth-death model to the combined phylogenetic and taxonomic data of a given clade. The phylogenetic data are given by a tree, and the taxonomic data by the number of species for the its tips. } \details{ A re-parametrization of the birth-death model studied by Kendall (1948) so that the likelihood has to be maximized over \emph{d/b} and \emph{b - d}, where \emph{b} is the birth rate, and \emph{d} the death rate. The standard-errors of the estimated parameters are computed using a normal approximation of the maximum likelihood estimates. If the argument \code{S} has names, then they are matched to the tip labels of \code{phy}. The user must be careful here since the function requires that both series of names perfectly match, so this operation may fail if there is a typing or syntax error. If both series of names do not match, the values \code{S} are taken to be in the same order than the tip labels of \code{phy}, and a warning message is issued. Note that the function does not check that the tree is effectively ultrametric, so if it is not, the returned result may not be meaningful. If \code{conditional = TRUE}, the probabilities of the taxonomic data are calculated conditioned on no extinction (Rabosky et al. 2007). In previous versions of the present function (until ape 2.6-1), unconditional probabilities were used resulting in underestimated extinction rate. Though it does not make much sense to use \code{conditional = FALSE}, this option is provided to compare results from previous analyses: if the species richnesses are relatively low, both versions will give similar results (see examples). } \references{ Paradis, E. (2003) Analysis of diversification: combining phylogenetic and taxonomic data. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{270}, 2499--2505. Rabosky, D. L., Donnellan, S. C., Talaba, A. L. and Lovette, I. J. (2007) Exceptional among-lineage variation in diversification rates during the radiation of Australia's most diverse vertebrate clade. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{274}, 2915--2923. } \author{Emmanuel Paradis} \seealso{ \code{\link{birthdeath}}, \code{\link{branching.times}}, \code{\link{diversi.gof}}, \code{\link{diversi.time}}, \code{\link{ltt.plot}}, \code{\link{yule}}, \code{\link{yule.cov}}, \code{\link{bd.time}} } \examples{ ### An example from Paradis (2003) using the avian orders: data(bird.orders) ### Number of species in each order from Sibley and Monroe (1990): S <- c(10, 47, 69, 214, 161, 17, 355, 51, 56, 10, 39, 152, 6, 143, 358, 103, 319, 23, 291, 313, 196, 1027, 5712) bd.ext(bird.orders, S) bd.ext(bird.orders, S, FALSE) # same than older versions } \keyword{models} ape/man/reorder.phylo.Rd0000644000176200001440000000626514164530562014674 0ustar liggesusers\name{reorder.phylo} \alias{reorder.phylo} \alias{reorder.multiPhylo} \alias{cladewise} \alias{postorder} \title{Internal Reordering of Trees} \description{ \code{reorder} changes the internal structure of a phylogeny stored as an object of class \code{"phylo"}. The tree returned is the same than the one input, but the ordering of the edges could be different. \code{cladewise} and \code{postorder} are convenience functions to return only the indices of the reordered edge matrices (see examples). } \usage{ \method{reorder}{phylo}(x, order = "cladewise", index.only = FALSE, ...) \method{reorder}{multiPhylo}(x, order = "cladewise", ...) cladewise(x) postorder(x) } \arguments{ \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{order}{a character string: either \code{"cladewise"} (the default), \code{"postorder"}, \code{"pruningwise"}, or any unambiguous abbreviation of these.} \item{index.only}{should the function return only the ordered indices of the rows of the edge matrix?} \item{\dots}{further arguments passed to or from other methods.} } \details{ Because in a tree coded as an object of class \code{"phylo"} each branch is represented by a row in the element `edge', there is an arbitrary choice for the ordering of these rows. \code{reorder} allows to reorder these rows according to three rules: in the \code{"cladewise"} order each clade is formed by a series of contiguous rows. In the \code{"postorder"} order, the rows are arranged so that computations following pruning-like algorithm the tree (or postorder tree traversal) can be done by descending along these rows (conversely, a preorder tree traversal can be performed by moving from the last to the first row). The \code{"pruningwise"} order is an alternative ``pruning'' order which is actually a bottom-up traversal order (Valiente 2002). (This third choice might be removed in the future as it merely duplicates the second one which is more efficient.) The possible multichotomies and branch lengths are preserved. Note that for a given order, there are several possible orderings of the rows of `edge'. } \value{ an object of class \code{"phylo"} (with the attribute \code{"order"} set accordingly), or a numeric vector if \code{index.only = TRUE}; if \code{x} is of class \code{"multiPhylo"}, then an object of the same class. } \references{ Valiente, G. (2002) \emph{Algorithms on Trees and Graphs.} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}} to read tree files in Newick format, \code{\link[stats]{reorder}} for the generic function } \examples{ data(bird.families) tr <- reorder(bird.families, "postorder") all.equal(bird.families, tr) # uses all.equal.phylo actually all.equal.list(bird.families, tr) # bypasses the generic ## get the number of descendants for each tip or node: nr_desc <- function(x) { res <- numeric(max(x$edge)) res[1:Ntip(x)] <- 1L for (i in postorder(x)) { tmp <- x$edge[i,1] res[tmp] <- res[tmp] + res[x$edge[i, 2]] } res } ## apply it to a random tree: tree <- rtree(10) plot(tree, show.tip.label = FALSE) tiplabels() nodelabels() nr_desc(tree) } \keyword{manip} ape/man/as.matching.Rd0000644000176200001440000000436314164530562014271 0ustar liggesusers\name{as.matching} \alias{as.matching} \alias{matching} \alias{as.matching.phylo} \alias{as.phylo.matching} \title{Conversion Between Phylo and Matching Objects} \description{ These functions convert objects between the classes \code{"phylo"} and \code{"matching"}. } \usage{ as.matching(x, ...) \method{as.matching}{phylo}(x, labels = TRUE, ...) \method{as.phylo}{matching}(x, ...) } \arguments{ \item{x}{an object to convert as an object of class \code{"matching"} or of class \code{"phylo"}.} \item{labels}{a logical specifying whether the tip and node labels should be included in the returned matching.} \item{\dots}{further arguments to be passed to or from other methods.} } \details{ A matching is a representation where each tip and each node are given a number, and sibling groups are grouped in a ``matching pair'' (see Diaconis and Holmes 1998, for details). This coding system can be used only for binary (fully dichotomous) trees. Diaconis and Holmes (1998) gave some conventions to insure that a given tree has a unique representation as a matching. I have tried to follow them in the present functions. } \value{ \code{as.matching} returns an object of class \code{"matching"} with the following component: \item{matching}{a two-column numeric matrix where the columns represent the sibling pairs.} \item{tip.label}{(optional) a character vector giving the tip labels where the ith element is the label of the tip numbered i in \code{matching}.} \item{node.label}{(optional) a character vector giving the node labels in the same order than in \code{matching} (i.e. the ith element is the label of the node numbered i + n in \code{matching}, with n the number of tips).} \code{as.phylo.matching} returns an object of class \code{"phylo"}. } \note{ Branch lengths are not supported in the present version. } \author{Emmanuel Paradis} \references{ Diaconis, P. W. and Holmes, S. P. (1998) Matchings and phylogenetic trees. \emph{Proceedings of the National Academy of Sciences USA}, \bold{95}, 14600--14602. } \seealso{\code{\link{as.phylo}}} \examples{ data(bird.orders) m <- as.matching(bird.orders) str(m) m tr <- as.phylo(m) all.equal(tr, bird.orders, use.edge.length = FALSE) } \keyword{manip} ape/man/phymltest.Rd0000644000176200001440000001410714164530562014123 0ustar liggesusers\name{phymltest} \alias{phymltest} \alias{print.phymltest} \alias{summary.phymltest} \alias{plot.phymltest} \title{Fits a Bunch of Models with PhyML} \usage{ phymltest(seqfile, format = "interleaved", itree = NULL, exclude = NULL, execname = NULL, append = TRUE) \method{print}{phymltest}(x, ...) \method{summary}{phymltest}(object, ...) \method{plot}{phymltest}(x, main = NULL, col = "blue", ...) } \arguments{ \item{seqfile}{a character string giving the name of the file that contains the DNA sequences to be analysed by PhyML.} \item{format}{a character string specifying the format of the DNA sequences: either \code{"interleaved"} (the default), or \code{"sequential"}.} \item{itree}{a character string giving the name of a file with a tree in Newick format to be used as an initial tree by PhyML. If \code{NULL} (the default), PhyML uses a ``BIONJ'' tree.} \item{exclude}{a vector of mode character giving the models to be excluded from the analysis. These must be among those below, and follow the same syntax.} \item{execname}{a character string specifying the name of the PhyML executable. This argument can be left as \code{NULL} if PhyML's default names are used: \code{"phyml_3.0_linux32"}, \code{"phyml_3.0_macintel"}, or \code{"phyml_3.0_win32.exe"}, under Linux, MacOS, or Windows respectively.} \item{append}{a logical indicating whether to erase previous PhyML output files if present; the default is to not erase.} \item{x}{an object of class \code{"phymltest"}.} \item{object}{an object of class \code{"phymltest"}.} \item{main}{a title for the plot; if left \code{NULL}, a title is made with the name of the object (use \code{main = ""} to have no title).} \item{col}{a colour used for the segments showing the AIC values (blue by default).} \item{\dots}{further arguments passed to or from other methods.} } \description{ This function calls PhyML and fits successively 28 models of DNA evolution. The results are saved on disk, as PhyML usually does, and returned in \R as a vector with the log-likelihood value of each model. } \details{ The present function requires version 3.0.1 of PhyML; it won't work with older versions. The user must take care to set correctly the three different paths involved here: the path to PhyML's binary, the path to the sequence file, and the path to R's working directory. The function should work if all three paths are different. Obviously, there should be no problem if they are all the same. The following syntax is used for the models: "X[Y][Z]00[+I][+G]" where "X" is the first letter of the author of the model, "Y" and "Z" are possibly other co-authors of the model, "00" is the year of the publication of the model, and "+I" and "+G" indicates whether the presence of invariant sites and/or a gamma distribution of substitution rates have been specified. Thus, Kimura's model is denoted "K80" and not "K2P". The exception to this rule is the general time-reversible model which is simple denoted "GTR" model. The seven substitution models used are: "JC69", "K80", "F81", "F84", "HKY85", "TN93", and "GTR". These models are then altered by adding the "+I" and/or "+G", resulting thus in four variants for each of them (e.g., "JC69", "JC69+I", "JC69+G", "JC69+I+G"). Some of these models are described in the help page of \code{\link{dist.dna}}. When a gamma distribution of substitution rates is specified, four categories are used (which is PhyML's default behaviour), and the ``alpha'' parameter is estimated from the data. For the models with a different substition rate for transitions and transversions, these rates are left free and estimated from the data (and not constrained with a ratio of 4 as in PhyML's default). The option \code{path2exec} has been removed in the present version: the path to PhyML's executable can be specified with the option \code{execname}. } \note{ It is important to note that the models fitted by this function is only a small fraction of the models possible with PhyML. For instance, it is possible to vary the number of categories in the (discretized) gamma distribution of substitution rates, and many parameters can be fixed by the user. The results from the present function should rather be taken as indicative of a best model. } \value{ \code{phymltest} returns an object of class \code{"phymltest"}: a numeric vector with the models as names. The \code{print} method prints an object of class \code{"phymltest"} as matrix with the name of the models, the number of free parameters, the log-likelihood value, and the value of the Akaike information criterion (AIC = -2 * loglik + 2 * number of free parameters) The \code{summary} method prints all the possible likelihood ratio tests for an object of class \code{"phymltest"}. The \code{plot} method plots the values of AIC of an object of class \code{"phymltest"} on a vertical scale. } \references{ Posada, D. and Crandall, K. A. (2001) Selecting the best-fit model of nucleotide substitution. \emph{Systematic Biology}, \bold{50}, 580--601. Guindon, S. and Gascuel, O. (2003) A simple, fast, and accurate algorithm to estimate large phylogenies by maximum likelihood. \emph{Systematic Biology}, \bold{52}, 696--704. \url{http://www.atgc-montpellier.fr/phyml/} } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{write.tree}}, \code{\link{dist.dna}} } \examples{ ### A `fake' example with random likelihood values: it does not ### make sense, but does not need PhyML and gives you a flavour ### of what the output looks like: x <- runif(28, -100, -50) names(x) <- ape:::.phymltest.model class(x) <- "phymltest" x summary(x) plot(x) plot(x, main = "", col = "red") ### This example needs PhyML, copy/paste or type the ### following commands if you want to try them, eventually ### changing setwd() and the options of phymltest() \dontrun{ setwd("D:/phyml_v2.4/exe") # under Windows data(woodmouse) write.dna(woodmouse, "woodmouse.txt") X <- phymltest("woodmouse.txt") X summary(X) plot(X) } } \keyword{models} ape/man/dist.dna.Rd0000644000176200001440000002430214164530562013574 0ustar liggesusers\name{dist.dna} \alias{dist.dna} \title{Pairwise Distances from DNA Sequences} \usage{ dist.dna(x, model = "K80", variance = FALSE, gamma = FALSE, pairwise.deletion = FALSE, base.freq = NULL, as.matrix = FALSE) } \arguments{ \item{x}{a matrix or a list containing the DNA sequences; this must be of class \code{"DNAbin"} (use \code{\link{as.DNAbin}} is they are stored as character).} \item{model}{a character string specifying the evolutionary model to be used; must be one of \code{"raw"}, \code{"N"}, \code{"TS"}, \code{"TV"}, \code{"JC69"}, \code{"K80"} (the default), \code{"F81"}, \code{"K81"}, \code{"F84"}, \code{"BH87"}, \code{"T92"}, \code{"TN93"}, \code{"GG95"}, \code{"logdet"}, \code{"paralin"}, \code{"indel"}, or \code{"indelblock"}.} \item{variance}{a logical indicating whether to compute the variances of the distances; defaults to \code{FALSE} so the variances are not computed.} \item{gamma}{a value for the gamma parameter possibly used to apply a correction to the distances (by default no correction is applied).} \item{pairwise.deletion}{a logical indicating whether to delete the sites with missing data in a pairwise way. The default is to delete the sites with at least one missing data for all sequences (ignored if \code{model = "indel"} or \code{"indelblock"}).} \item{base.freq}{the base frequencies to be used in the computations (if applicable). By default, the base frequencies are computed from the whole set of sequences.} \item{as.matrix}{a logical indicating whether to return the results as a matrix. The default is to return an object of class \link[stats]{dist}.} } \description{ This function computes a matrix of pairwise distances from DNA sequences using a model of DNA evolution. Eleven substitution models (and the raw distance) are currently available. } \details{ The molecular evolutionary models available through the option \code{model} have been extensively described in the literature. A brief description is given below; more details can be found in the references. \itemize{ \item{\code{raw}, \code{N}: }{This is simply the proportion or the number of sites that differ between each pair of sequences. This may be useful to draw ``saturation plots''. The options \code{variance} and \code{gamma} have no effect, but \code{pairwise.deletion} can.} \item{\code{TS}, \code{TV}: }{These are the numbers of transitions and transversions, respectively.} \item{\code{JC69}: }{This model was developed by Jukes and Cantor (1969). It assumes that all substitutions (i.e. a change of a base by another one) have the same probability. This probability is the same for all sites along the DNA sequence. This last assumption can be relaxed by assuming that the substition rate varies among site following a gamma distribution which parameter must be given by the user. By default, no gamma correction is applied. Another assumption is that the base frequencies are balanced and thus equal to 0.25.} \item{\code{K80}: }{The distance derived by Kimura (1980), sometimes referred to as ``Kimura's 2-parameters distance'', has the same underlying assumptions than the Jukes--Cantor distance except that two kinds of substitutions are considered: transitions (A <-> G, C <-> T), and transversions (A <-> C, A <-> T, C <-> G, G <-> T). They are assumed to have different probabilities. A transition is the substitution of a purine (C, T) by another one, or the substitution of a pyrimidine (A, G) by another one. A transversion is the substitution of a purine by a pyrimidine, or vice-versa. Both transition and transversion rates are the same for all sites along the DNA sequence. Jin and Nei (1990) modified the Kimura model to allow for variation among sites following a gamma distribution. Like for the Jukes--Cantor model, the gamma parameter must be given by the user. By default, no gamma correction is applied.} \item{\code{F81}: }{Felsenstein (1981) generalized the Jukes--Cantor model by relaxing the assumption of equal base frequencies. The formulae used in this function were taken from McGuire et al. (1999)}. \item{\code{K81}: }{Kimura (1981) generalized his model (Kimura 1980) by assuming different rates for two kinds of transversions: A <-> C and G <-> T on one side, and A <-> T and C <-> G on the other. This is what Kimura called his ``three substitution types model'' (3ST), and is sometimes referred to as ``Kimura's 3-parameters distance''}. \item{\code{F84}: }{This model generalizes K80 by relaxing the assumption of equal base frequencies. It was first introduced by Felsenstein in 1984 in Phylip, and is fully described by Felsenstein and Churchill (1996). The formulae used in this function were taken from McGuire et al. (1999)}. \item{\code{BH87}: }{Barry and Hartigan (1987) developed a distance based on the observed proportions of changes among the four bases. This distance is not symmetric.} \item{\code{T92}: }{Tamura (1992) generalized the Kimura model by relaxing the assumption of equal base frequencies. This is done by taking into account the bias in G+C content in the sequences. The substitution rates are assumed to be the same for all sites along the DNA sequence.} \item{\code{TN93}: }{Tamura and Nei (1993) developed a model which assumes distinct rates for both kinds of transition (A <-> G versus C <-> T), and transversions. The base frequencies are not assumed to be equal and are estimated from the data. A gamma correction of the inter-site variation in substitution rates is possible.} \item{\code{GG95}: }{Galtier and Gouy (1995) introduced a model where the G+C content may change through time. Different rates are assumed for transitons and transversions.} \item{\code{logdet}: }{The Log-Det distance, developed by Lockhart et al. (1994), is related to BH87. However, this distance is symmetric. Formulae from Gu and Li (1996) are used. \code{dist.logdet} in \pkg{phangorn} uses a different implementation that gives substantially different distances for low-diverging sequences.} \item{\code{paralin}: }{Lake (1994) developed the paralinear distance which can be viewed as another variant of the Barry--Hartigan distance.} \item{\code{indel}: }{this counts the number of sites where there is an insertion/deletion gap in one sequence and not in the other.} \item{\code{indelblock}: }{same than before but contiguous gaps are counted as a single unit. Note that the distance between \code{-A-} and \code{A--} is 3 because there are three different blocks of gaps, whereas the ``indel'' distance will be 2.} }} \note{ If the sequences are very different, most evolutionary distances are undefined and a non-finite value (Inf or NaN) is returned. You may do \code{dist.dna(, model = "raw")} to check whether some values are higher than 0.75. } \value{ an object of class \link[stats]{dist} (by default), or a numeric matrix if \code{as.matrix = TRUE}. If \code{model = "BH87"}, a numeric matrix is returned because the Barry--Hartigan distance is not symmetric. If \code{variance = TRUE} an attribute called \code{"variance"} is given to the returned object. } \references{ Barry, D. and Hartigan, J. A. (1987) Asynchronous distance between homologous DNA sequences. \emph{Biometrics}, \bold{43}, 261--276. Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a maximum likelihood approach. \emph{Journal of Molecular Evolution}, \bold{17}, 368--376. Felsenstein, J. and Churchill, G. A. (1996) A Hidden Markov model approach to variation among sites in rate of evolution. \emph{Molecular Biology and Evolution}, \bold{13}, 93--104. Galtier, N. and Gouy, M. (1995) Inferring phylogenies from DNA sequences of unequal base compositions. \emph{Proceedings of the National Academy of Sciences USA}, \bold{92}, 11317--11321. Gu, X. and Li, W.-H. (1996) Bias-corrected paralinear and LogDet distances and tests of molecular clocks and phylogenies under nonstationary nucleotide frequencies. \emph{Molecular Biology and Evolution}, \bold{13}, 1375--1383. Jukes, T. H. and Cantor, C. R. (1969) Evolution of protein molecules. in \emph{Mammalian Protein Metabolism}, ed. Munro, H. N., pp. 21--132, New York: Academic Press. Kimura, M. (1980) A simple method for estimating evolutionary rates of base substitutions through comparative studies of nucleotide sequences. \emph{Journal of Molecular Evolution}, \bold{16}, 111--120. Kimura, M. (1981) Estimation of evolutionary distances between homologous nucleotide sequences. \emph{Proceedings of the National Academy of Sciences USA}, \bold{78}, 454--458. Jin, L. and Nei, M. (1990) Limitations of the evolutionary parsimony method of phylogenetic analysis. \emph{Molecular Biology and Evolution}, \bold{7}, 82--102. Lake, J. A. (1994) Reconstructing evolutionary trees from DNA and protein sequences: paralinear distances. \emph{Proceedings of the National Academy of Sciences USA}, \bold{91}, 1455--1459. Lockhart, P. J., Steel, M. A., Hendy, M. D. and Penny, D. (1994) Recovering evolutionary trees under a more realistic model of sequence evolution. \emph{Molecular Biology and Evolution}, \bold{11}, 605--602. McGuire, G., Prentice, M. J. and Wright, F. (1999). Improved error bounds for genetic distances from DNA sequences. \emph{Biometrics}, \bold{55}, 1064--1070. Tamura, K. (1992) Estimation of the number of nucleotide substitutions when there are strong transition-transversion and G + C-content biases. \emph{Molecular Biology and Evolution}, \bold{9}, 678--687. Tamura, K. and Nei, M. (1993) Estimation of the number of nucleotide substitutions in the control region of mitochondrial DNA in humans and chimpanzees. \emph{Molecular Biology and Evolution}, \bold{10}, 512--526. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.GenBank}}, \code{\link{read.dna}}, \code{\link{write.dna}}, \code{\link{DNAbin}}, \code{\link{dist.gene}}, \code{\link{cophenetic.phylo}}, \code{\link[stats]{dist}} } \keyword{manip} \keyword{multivariate} \keyword{cluster} ape/man/weight.taxo.Rd0000644000176200001440000000146014164530562014331 0ustar liggesusers\name{weight.taxo} \alias{weight.taxo} \alias{weight.taxo2} \title{Define Similarity Matrix} \usage{ weight.taxo(x) weight.taxo2(x, y) } \arguments{ \item{x, y}{a vector or a factor.} } \description{ \code{weight.taxo} computes a matrix whose entries [i, j] are set to 1 if x[i] == x[j], 0 otherwise. \code{weight.taxo2} computes a matrix whose entries [i, j] are set to 1 if x[i] == x[j] AND y[i] != y[j], 0 otherwise. The diagonal [i, i] is always set to 0. The returned matrix can be used as a weight matrix in \code{\link{Moran.I}}. \code{x} and \code{y} may be vectors of factors. See further details in \code{vignette("MoranI")}. } \value{ a square numeric matrix. } \author{Emmanuel Paradis} \seealso{ \code{\link{Moran.I}}, \code{\link{correlogram.formula}} } \keyword{manip} ape/man/slowinskiguyer.test.Rd0000644000176200001440000000462114164530562016146 0ustar liggesusers\name{slowinskiguyer.test} \alias{slowinskiguyer.test} \title{Slowinski-Guyer Test of Homogeneous Diversification} \description{ This function performs the Slowinski--Guyer test that a trait or variable does not increase diversification rate. } \usage{ slowinskiguyer.test(x, detail = FALSE) } \arguments{ \item{x}{a matrix or a data frame with at least two columns: the first one gives the number of species in clades with a trait supposed to increase diversification rate, and the second one the number of species in the corresponding sister-clade without the trait. Each row represents a pair of sister-clades.} \item{detail}{if \code{TRUE}, the individual P-values are appended.} } \details{ The Slowinski--Guyer test compares a series of sister-clades where one of the two is characterized by a trait supposed to increase diversification rate. The null hypothesis is that the trait does not affect diversification. If the trait decreased diversification rate, then the null hypothesis cannot be rejected. The present function has mainly a historical interest. The Slowinski--Guyer test generally performs poorly: see Paradis (2012) alternatives and the functions cited below. } \value{ a data frame with the \eqn{\chi^2}{chi2}, the number of degrees of freedom, and the \emph{P}-value. If \code{detail = TRUE}, a list is returned with the data frame and a vector of individual \emph{P}-values for each pair of sister-clades. } \references{ Paradis, E. (2012) Shift in diversification in sister-clade comparisons: a more powerful test. \emph{Evolution}, \bold{66}, 288--295. Slowinski, J. B. and Guyer, C. (1993) Testing whether certain traits have caused amplified diversification: an improved method based on a model of random speciation and extinction. \emph{American Naturalist}, \bold{142}, 1019--1024. } \author{Emmanuel Paradis} \seealso{ \code{\link{balance}}, \code{\link{mcconwaysims.test}}, \code{\link{diversity.contrast.test}}, \code{\link{richness.yule.test}}, \code{rc} in \pkg{geiger}, \code{shift.test} in \pkg{apTreeshape} } \examples{ ### from Table 1 in Slowinski and Guyer(1993): viviparous <- c(98, 8, 193, 36, 7, 128, 2, 3, 23, 70) oviparous <- c(234, 17, 100, 4, 1, 12, 6, 1, 481, 11) x <- data.frame(viviparous, oviparous) slowinskiguyer.test(x, TRUE) # 'P ~ 0.32' in the paper xalt <- x xalt[3, 2] <- 1 slowinskiguyer.test(xalt) } \keyword{htest} ape/man/drop.tip.Rd0000644000176200001440000001077514164530562013640 0ustar liggesusers\name{drop.tip} \alias{drop.tip} \alias{keep.tip} \alias{extract.clade} \title{Remove Tips in a Phylogenetic Tree} \description{ \code{drop.tip} removes the terminal branches of a phylogenetic tree, possibly removing the corresponding internal branches. \code{keep.tip} does the opposite operation (i.e., returns the induced tree). \code{extract.clade} does the inverse operation: it keeps all the tips from a given node, and deletes all the other tips. } \usage{ drop.tip(phy, tip, trim.internal = TRUE, subtree = FALSE, root.edge = 0, rooted = is.rooted(phy), collapse.singles = TRUE, interactive = FALSE) keep.tip(phy, tip) extract.clade(phy, node, root.edge = 0, collapse.singles = TRUE, interactive = FALSE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{tip}{a vector of mode numeric or character specifying the tips to delete.} \item{trim.internal}{a logical specifying whether to delete the corresponding internal branches.} \item{subtree}{a logical specifying whether to output in the tree how many tips have been deleted and where.} \item{root.edge}{an integer giving the number of internal branches to be used to build the new root edge. This has no effect if \code{trim.internal = FALSE}.} \item{rooted}{a logical indicating whether the tree must be treated as rooted or not. This allows to force the tree to be considered as unrooted (see examples). See details about a possible root.edge element in the tree.} \item{collapse.singles}{a logical specifying whether to delete the internal nodes of degree 2.} \item{node}{a node number or label.} \item{interactive}{if \code{TRUE} the user is asked to select the tips or the node by clicking on the tree which must be plotted.} } \details{ The argument \code{tip} can be either character or numeric. In the first case, it gives the labels of the tips to be deleted; in the second case the numbers of these labels in the vector \code{phy$tip.label} are given. This also applies to \code{node}, but if this argument is character and the tree has no node label, this results in an error. If more than one value is given with \code{node} (i.e., a vector of length two or more), only the first one is used with a warning. If \code{trim.internal = FALSE}, the new tips are given \code{"NA"} as labels, unless there are node labels in the tree in which case they are used. If \code{subtree = TRUE}, the returned tree has one or several terminal branches indicating how many tips have been removed (with a label \code{"[x_tips]"}). This is done for as many monophyletic groups that have been deleted. Note that \code{subtree = TRUE} implies \code{trim.internal = TRUE}. To undestand how the option \code{root.edge} works, see the examples below. If \code{rooted = FALSE} and the tree has a root edge, the latter is removed in the output. } \value{an object of class \code{"phylo"}.} \author{Emmanuel Paradis, Klaus Schliep, Joseph Brown} \seealso{\code{\link{bind.tree}}, \code{\link{root}}} \examples{ data(bird.families) tip <- c( "Eopsaltriidae", "Acanthisittidae", "Pittidae", "Eurylaimidae", "Philepittidae", "Tyrannidae", "Thamnophilidae", "Furnariidae", "Formicariidae", "Conopophagidae", "Rhinocryptidae", "Climacteridae", "Menuridae", "Ptilonorhynchidae", "Maluridae", "Meliphagidae", "Pardalotidae", "Petroicidae", "Irenidae", "Orthonychidae", "Pomatostomidae", "Laniidae", "Vireonidae", "Corvidae", "Callaeatidae", "Picathartidae", "Bombycillidae", "Cinclidae", "Muscicapidae", "Sturnidae", "Sittidae", "Certhiidae", "Paridae", "Aegithalidae", "Hirundinidae", "Regulidae", "Pycnonotidae", "Hypocoliidae", "Cisticolidae", "Zosteropidae", "Sylviidae", "Alaudidae", "Nectariniidae", "Melanocharitidae", "Paramythiidae","Passeridae", "Fringillidae") plot(drop.tip(bird.families, tip)) plot(drop.tip(bird.families, tip, trim.internal = FALSE)) data(bird.orders) plot(drop.tip(bird.orders, 6:23, subtree = TRUE)) plot(drop.tip(bird.orders, c(1:5, 20:23), subtree = TRUE)) plot(drop.tip(bird.orders, c(1:20, 23), subtree = TRUE)) plot(drop.tip(bird.orders, c(1:20, 23), subtree = TRUE, rooted = FALSE)) ### Examples of the use of `root.edge' tr <- read.tree(text = "(A:1,(B:1,(C:1,(D:1,E:1):1):1):1):1;") drop.tip(tr, c("A", "B"), root.edge = 0) # = (C:1,(D:1,E:1):1); drop.tip(tr, c("A", "B"), root.edge = 1) # = (C:1,(D:1,E:1):1):1; drop.tip(tr, c("A", "B"), root.edge = 2) # = (C:1,(D:1,E:1):1):2; drop.tip(tr, c("A", "B"), root.edge = 3) # = (C:1,(D:1,E:1):1):3; } \keyword{manip} ape/man/varCompPhylip.Rd0000644000176200001440000000536714164530562014677 0ustar liggesusers\name{varCompPhylip} \alias{varCompPhylip} \title{Variance Components with Orthonormal Contrasts} \description{ This function calls Phylip's contrast program and returns the phylogenetic and phenotypic variance-covariance components for one or several traits. There can be several observations per species. } \usage{ varCompPhylip(x, phy, exec = NULL) } \arguments{ \item{x}{a numeric vector, a matrix (or data frame), or a list.} \item{phy}{an object of class \code{"phylo"}.} \item{exec}{a character string giving the name of the executable contrast program (see details).} } \details{ The data \code{x} can be in several forms: (i) a numeric vector if there is single trait and one observation per species; (ii) a matrix or data frame if there are several traits (as columns) and a single observation of each trait for each species; (iii) a list of vectors if there is a single trait and several observations per species; (iv) a list of matrices or data frames: same than (ii) but with several traits and the rows are individuals. If \code{x} has names, its values are matched to the tip labels of \code{phy}, otherwise its values are taken to be in the same order than the tip labels of \code{phy}. Phylip (version 3.68 or higher) must be accessible on your computer. If you have a Unix-like operating system, the executable name is assumed to be \code{"phylip contrast"} (as in Debian); otherwise it is set to \code{"contrast"}. If this doesn't suit your system, use the option \code{exec} accordingly. If the executable is not in the path, you may need to specify it, e.g., \code{exec = "C:/Program Files/Phylip/contrast"}. } \value{ a list with elements \code{varA} and \code{varE} with the phylogenetic (additive) and phenotypic (environmental) variance-covariance matrices. If a single trait is analyzed, these contains its variances. } \references{ Felsenstein, J. (2004) Phylip (Phylogeny Inference Package) version 3.68. Department of Genetics, University of Washington, Seattle, USA. \url{http://evolution.genetics.washington.edu/phylip/phylip.html}. Felsenstein, J. (2008) Comparative methods with sampling error and within-species variation: Contrasts revisited and revised. \emph{American Naturalist}, \bold{171}, 713--725. } \author{Emmanuel Paradis} \seealso{ \code{\link{pic}}, \code{\link{pic.ortho}}, \code{\link{compar.lynch}} } \examples{ \dontrun{ tr <- rcoal(30) ### Five traits, one observation per species: x <- replicate(5, rTraitCont(tr, sigma = 1)) varCompPhylip(x, tr) # varE is small x <- replicate(5, rnorm(30)) varCompPhylip(x, tr) # varE is large ### Five traits, ten observations per species: x <- replicate(30, replicate(5, rnorm(10)), simplify = FALSE) varCompPhylip(x, tr) }} \keyword{regression} ape/man/updateLabel.Rd0000644000176200001440000000517114164530562014315 0ustar liggesusers\name{updateLabel} \alias{updateLabel} \alias{updateLabel.DNAbin} \alias{updateLabel.AAbin} \alias{updateLabel.character} \alias{updateLabel.phylo} \alias{updateLabel.evonet} \alias{updateLabel.data.frame} \alias{updateLabel.matrix} \title{Update Labels} \description{ This function changes labels (names or rownames) giving two vectors (\code{old} and \code{new}). It is a generic function with several methods as described below. } \usage{ updateLabel(x, old, new, ...) \method{updateLabel}{character}(x, old, new, exact = TRUE, ...) \method{updateLabel}{DNAbin}(x, old, new, exact = TRUE, ...) \method{updateLabel}{AAbin}(x, old, new, exact = TRUE, ...) \method{updateLabel}{phylo}(x, old, new, exact = TRUE, nodes = FALSE, ...) \method{updateLabel}{evonet}(x, old, new, exact = TRUE, nodes = FALSE, ...) \method{updateLabel}{data.frame}(x, old, new, exact = TRUE, ...) \method{updateLabel}{matrix}(x, old, new, exact = TRUE, ...) } \arguments{ \item{x}{an object where to change the labels.} \item{old, new}{two vectors of mode character (must be of the same length).} \item{exact}{a logical value (see details).} \item{nodes}{a logical value specifying whether to also update the node labels of the tree or network.} \item{\dots}{further arguments passed to and from methods.} } \details{ This function can be used to change some of the labels (see examples) or all of them if their ordering is not sure. If \code{exact = TRUE} (the default), the values in \code{old} are matched exactly with the labels; otherwise (\code{exact = FALSE}), the values in \code{old} are considered as regular expressions and searched in the labels with \code{\link{grep}}. } \value{ an object of the same class than \code{x}. } \author{Emmanuel Paradis} \seealso{ \code{\link{makeLabel}}, \code{\link{makeNodeLabel}}, \code{\link{mixedFontLabel}}, \code{\link{stripLabel}}, \code{\link{checkLabel}} } \examples{ \dontrun{ ## the tree by Nyakatura & Bininda-Emonds (2012, BMC Biology) x <- "https://static-content.springer.com/esm/art" y <- "3A10.1186" z <- "2F1741-7007-10-12/MediaObjects/12915_2011_534_MOESM5_ESM.NEX" ## The commande below may not print correctly in HTML because of the ## percentage symbol; see the text or PDF help page. url <- paste(x, y, z, sep = "%") TC <- read.nexus(url) tr <- TC$carnivoreST_bestEstimate old <- c("Uncia_uncia", "Felis_manul", "Leopardus_jacobitus") new <- c("Panthera_uncia", "Otocolobus_manul", "Leopardus_jacobita") tr.updated <- updateLabel(tr, old, new) } tr <- rtree(6) ## the order of the labels are randomized by this function old <- paste0("t", 1:6) new <- paste0("x", 1:6) updateLabel(tr, old, new) tr } \keyword{manip} ape/man/yule.time.Rd0000644000176200001440000000636314164530562014012 0ustar liggesusers\name{yule.time} \alias{yule.time} \title{Fits the Time-Dependent Yule Model} \usage{ yule.time(phy, birth, BIRTH = NULL, root.time = 0, opti = "nlm", start = 0.01) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{birth}{a (vectorized) function specifying how the birth (speciation) probability changes through time (see details).} \item{BIRTH}{a (vectorized) function giving the primitive of \code{birth}.} \item{root.time}{a numeric value giving the time of the root node (time is measured from the past towards the present).} \item{opti}{a character string giving the function used for optimisation of the likelihood function. Three choices are possible: \code{"nlm"}, \code{"nlminb"}, or \code{"optim"}, or any unambiguous abbreviation of these.} \item{start}{the initial values used in the optimisation.} } \description{ This function fits by maximum likelihood the time-dependent Yule model. The time is measured from the past (\code{root.time}) to the present. } \details{ The model fitted is a straightforward extension of the Yule model with covariates (see \code{\link{yule.cov}}). Rather than having heterogeneity among lineages, the speciation probability is the same for all lineages at a given time, but can change through time. The function \code{birth} \emph{must} meet these two requirements: (i) the parameters to be estimated are the formal arguments; (ii) time is named \code{t} in the body of the function. However, this is the opposite for the primitive \code{BIRTH}: \code{t} is the formal argument, and the parameters are used in its body. See the examples. It is recommended to use \code{BIRTH} if possible, and required if speciation probability is constant on some time interval. If this primitive cannot be provided, a numerical integration is done with \code{\link[stats]{integrate}}. The standard-errors of the parameters are computed with the Hessian of the log-likelihood function. } \value{ An object of class \code{"yule"} (see \code{\link{yule}}). } \author{Emmanuel Paradis} \references{ Hubert, N., Paradis, E., Bruggemann, H. and Planes, S. (2011) Community assembly and diversification in Indo-Pacific coral reef fishes. \emph{Ecology and Evolution}, \bold{1}, 229--277. } \seealso{ \code{\link{branching.times}}, \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{yule}}, \code{\link{yule.cov}}, \code{\link{bd.time}} } \examples{ ### define two models... birth.logis <- function(a, b) 1/(1 + exp(-a*t - b)) # logistic birth.step <- function(l1, l2, Tcl) { # 2 rates with one break-point ans <- rep(l1, length(t)) ans[t > Tcl] <- l2 ans } ### ... and their primitives: BIRTH.logis <- function(t) log(exp(-a*t) + exp(b))/a + t BIRTH.step <- function(t) { out <- numeric(length(t)) sel <- t <= Tcl if (any(sel)) out[sel] <- t[sel] * l1 if (any(!sel)) out[!sel] <- Tcl * l1 + (t[!sel] - Tcl) * l2 out } data(bird.families) ### fit both models: yule.time(bird.families, birth.logis) yule.time(bird.families, birth.logis, BIRTH.logis) # same but faster \dontrun{yule.time(bird.families, birth.step)} # fails yule.time(bird.families, birth.step, BIRTH.step, opti = "nlminb", start = c(.01, .01, 100)) } \keyword{models} ape/man/chronopl.Rd0000644000176200001440000001257114164530562013721 0ustar liggesusers\name{chronopl} \alias{chronopl} \title{Molecular Dating With Penalized Likelihood} \description{ This function estimates the node ages of a tree using a semi-parametric method based on penalized likelihood (Sanderson 2002). The branch lengths of the input tree are interpreted as mean numbers of substitutions (i.e., per site). } \usage{ chronopl(phy, lambda, age.min = 1, age.max = NULL, node = "root", S = 1, tol = 1e-8, CV = FALSE, eval.max = 500, iter.max = 500, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{lambda}{value of the smoothing parameter.} \item{age.min}{numeric values specifying the fixed node ages (if \code{age.max = NULL}) or the youngest bound of the nodes known to be within an interval.} \item{age.max}{numeric values specifying the oldest bound of the nodes known to be within an interval.} \item{node}{the numbers of the nodes whose ages are given by \code{age.min}; \code{"root"} is a short-cut for the root.} \item{S}{the number of sites in the sequences; leave the default if branch lengths are in mean number of substitutions.} \item{tol}{the value below which branch lengths are considered effectively zero.} \item{CV}{whether to perform cross-validation.} \item{eval.max}{the maximal number of evaluations of the penalized likelihood function.} \item{iter.max}{the maximal number of iterations of the optimization algorithm.} \item{\dots}{further arguments passed to control \code{nlminb}.} } \details{ The idea of this method is to use a trade-off between a parametric formulation where each branch has its own rate, and a nonparametric term where changes in rates are minimized between contiguous branches. A smoothing parameter (lambda) controls this trade-off. If lambda = 0, then the parametric component dominates and rates vary as much as possible among branches, whereas for increasing values of lambda, the variation are smoother to tend to a clock-like model (same rate for all branches). \code{lambda} must be given. The known ages are given in \code{age.min}, and the correponding node numbers in \code{node}. These two arguments must obviously be of the same length. By default, an age of 1 is assumed for the root, and the ages of the other nodes are estimated. If \code{age.max = NULL} (the default), it is assumed that \code{age.min} gives exactly known ages. Otherwise, \code{age.max} and \code{age.min} must be of the same length and give the intervals for each node. Some node may be known exactly while the others are known within some bounds: the values will be identical in both arguments for the former (e.g., \code{age.min = c(10, 5), age.max = c(10, 6), node = c(15, 18)} means that the age of node 15 is 10 units of time, and the age of node 18 is between 5 and 6). If two nodes are linked (i.e., one is the ancestor of the other) and have the same values of \code{age.min} and \code{age.max} (say, 10 and 15) this will result in an error because the medians of these values are used as initial times (here 12.5) giving initial branch length(s) equal to zero. The easiest way to solve this is to change slightly the given values, for instance use \code{age.max = 14.9} for the youngest node, or \code{age.max = 15.1} for the oldest one (or similarly for \code{age.min}). The input tree may have multichotomies. If some internal branches are of zero-length, they are collapsed (with a warning), and the returned tree will have less nodes than the input one. The presence of zero-lengthed terminal branches of results in an error since it makes little sense to have zero-rate branches. The cross-validation used here is different from the one proposed by Sanderson (2002). Here, each tip is dropped successively and the analysis is repeated with the reduced tree: the estimated dates for the remaining nodes are compared with the estimates from the full data. For the \eqn{i}{i}th tip the following is calculated: \deqn{\sum_{j=1}^{n-2}{\frac{(t_j - t_j^{-i})^2}{t_j}}}{SUM[j = 1, ..., n-2] (tj - tj[-i])^2/tj}, where \eqn{t_j}{tj} is the estimated date for the \eqn{j}{j}th node with the full phylogeny, \eqn{t_j^{-i}}{tj[-i]} is the estimated date for the \eqn{j}{j}th node after removing tip \eqn{i}{i} from the tree, and \eqn{n}{n} is the number of tips. The present version uses the \code{\link[stats]{nlminb}} to optimise the penalized likelihood function: see its help page for details on parameters controlling the optimisation procedure. } \value{ an object of class \code{"phylo"} with branch lengths as estimated by the function. There are three or four further attributes: \item{ploglik}{the maximum penalized log-likelihood.} \item{rates}{the estimated rates for each branch.} \item{message}{the message returned by \code{nlminb} indicating whether the optimisation converged.} \item{D2}{the influence of each observation on overall date estimates (if \code{CV = TRUE}).} } \note{ The new function \code{\link{chronos}} replaces the present one which is no more maintained. } \references{ Sanderson, M. J. (2002) Estimating absolute rates of molecular evolution and divergence times: a penalized likelihood approach. \emph{Molecular Biology and Evolution}, \bold{19}, 101--109. } \author{Emmanuel Paradis} \seealso{ \code{\link{chronos}}, \code{\link{chronoMPL}} } \keyword{models} ape/man/compar.cheverud.Rd0000644000176200001440000000476614164530562015171 0ustar liggesusers\name{compar.cheverud} \alias{compar.cheverud} \title{Cheverud's Comparative Method} \description{ This function computes the phylogenetic variance component and the residual deviation for continous characters, taking into account the phylogenetic relationships among species, following the comparative method described in Cheverud et al. (1985). The correction proposed by Rholf (2001) is used. } \usage{ compar.cheverud(y, W, tolerance = 1e-06, gold.tol = 1e-04) } \arguments{ \item{y}{A vector containing the data to analyse.} \item{W}{The phylogenetic connectivity matrix. All diagonal elements will be ignored.} \item{tolerance}{Minimum difference allowed to consider eigenvalues as distinct.} \item{gold.tol}{Precision to use in golden section search alogrithm.} } \details{ Model: \deqn{y = \rho W y + e}{y = rho.W.y + e} where \eqn{e}{e} is the error term, assumed to be normally distributed. \eqn{\rho}{rho} is estimated by the maximum likelihood procedure given in Rohlf (2001), using a golden section search algorithm. The code of this function is indeed adapted from a MatLab code given in appendix in Rohlf's article, to correct a mistake in Cheverud's original paper. } \value{ A list with the following components: \item{rhohat}{The maximum likelihood estimate of \eqn{\rho}{rho}} \item{Wnorm}{The normalized version of \code{W}} \item{residuals}{Error terms (\eqn{e}{e})} } \references{ Cheverud, J. M., Dow, M. M. and Leutenegger, W. (1985) The quantitative assessment of phylogenetic constraints in comparative analyses: sexual dimorphism in body weight among primates. \emph{Evolution}, \bold{39}, 1335--1351. Rohlf, F. J. (2001) Comparative methods for the analysis of continuous variables: geometric interpretations. \emph{Evolution}, \bold{55}, 2143--2160. Harvey, P. H. and Pagel, M. D. (1991) \emph{The Comparative Method in Evolutionary Biology}. Oxford University Press. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}} \seealso{\code{\link{compar.lynch}}} \examples{ ### Example from Harvey and Pagel's book: y<-c(10,8,3,4) W <- matrix(c(1,1/6,1/6,1/6,1/6,1,1/2,1/2,1/6,1/2,1,1,1/6,1/2,1,1), 4) compar.cheverud(y,W) ### Example from Rohlf's 2001 article: W<- matrix(c( 0,1,1,2,0,0,0,0, 1,0,1,2,0,0,0,0, 1,1,0,2,0,0,0,0, 2,2,2,0,0,0,0,0, 0,0,0,0,0,1,1,2, 0,0,0,0,1,0,1,2, 0,0,0,0,1,1,0,2, 0,0,0,0,2,2,2,0 ),8) W <- 1/W W[W == Inf] <- 0 y<-c(-0.12,0.36,-0.1,0.04,-0.15,0.29,-0.11,-0.06) compar.cheverud(y,W) } \keyword{regression} ape/man/corBlomberg.Rd0000644000176200001440000000544314164530562014332 0ustar liggesusers\name{corBlomberg} \alias{corBlomberg} \alias{coef.corBlomberg} \alias{corMatrix.corBlomberg} \title{Blomberg et al.'s Correlation Structure} \usage{ corBlomberg(value, phy, form = ~1, fixed = FALSE) \method{corMatrix}{corBlomberg}(object, covariate = getCovariate(object), corr = TRUE, ...) \method{coef}{corBlomberg}(object, unconstrained = TRUE, \dots) } \arguments{ \item{value}{the (initial) value of the parameter \eqn{g}{g}.} \item{phy}{an object of class \code{"phylo"}.} \item{form}{a one sided formula of the form ~ t, or ~ t | g, specifying the taxa covariate t and, optionally, a grouping factor g. A covariate for this correlation structure must be character valued, with entries matching the tip labels in the phylogenetic tree. When a grouping factor is present in form, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to ~ 1, which corresponds to using the order of the observations in the data as a covariate, and no groups.} \item{fixed}{a logical specifying whether \code{gls} should estimate \eqn{\gamma}{gamma} (the default) or keep it fixed.} \item{object}{an (initialized) object of class \code{"corBlomberg"}.} \item{covariate}{an optional covariate vector (matrix), or list of covariate vectors (matrices), at which values the correlation matrix, or list of correlation matrices, are to be evaluated. Defaults to getCovariate(object).} \item{corr}{a logical value specifying whether to return the correlation matrix (the default) or the variance-covariance matrix.} \item{unconstrained}{a logical value. If \code{TRUE} (the default), the coefficients are returned in unconstrained form (the same used in the optimization algorithm). If \code{FALSE} the coefficients are returned in ``natural'', possibly constrained, form.} \item{\dots}{further arguments passed to or from other methods.} } \description{ The ``ACDC'' (accelerated/decelerated) model assumes that continuous traits evolve under a Brownian motion model which rates accelerates (if \eqn{g}{g} < 1) or decelerates (if \eqn{g}{g} > 1) through time. If \eqn{g}{g} = 1, then the model reduces to a Brownian motion model. } \value{ an object of class \code{"corBlomberg"}, the coefficients from an object of this class, or the correlation matrix of an initialized object of this class. In most situations, only \code{corBlomberg} will be called by the user. } \author{Emmanuel Paradis} \references{ Blomberg, S. P., Garland, Jr, T., and Ives, A. R. (2003) Testing for phylogenetic signal in comparative data: behavioral traits are more labile. \emph{Evolution}, \bold{57}, 717--745. } \keyword{models} ape/man/dist.gene.Rd0000644000176200001440000000365614164530562013761 0ustar liggesusers\name{dist.gene} \alias{dist.gene} \title{Pairwise Distances from Genetic Data} \usage{ dist.gene(x, method = "pairwise", pairwise.deletion = FALSE, variance = FALSE) } \arguments{ \item{x}{a matrix or a data frame (will be coerced as a matrix).} \item{method}{a character string specifying the method used to compute the distances; two choices are available: \code{"pairwise"} and \code{"percentage"}, or any unambiguous abbreviation of these.} \item{pairwise.deletion}{a logical indicating whether to delete the columns with missing data on a pairwise basis. The default is to delete the columns with at least one missing observation.} \item{variance}{a logical, indicates whether the variance of the distances should be returned (default to \code{FALSE}).} } \description{ This function computes a matrix of distances between pairs of individuals from a matrix or a data frame of genetic data. } \details{ This function is meant to be very general and accepts different kinds of data (alleles, haplotypes, SNP, DNA sequences, \dots). The rows of the data matrix represent the individuals, and the columns the loci. In the case of the pairwise method, the distance \eqn{d} between two individuals is the number of loci for which they differ, and the associated variance is \eqn{d(L - d)/L}, where \eqn{L} is the number of loci. In the case of the percentage method, this distance is divided by \eqn{L}, and the associated variance is \eqn{d(1 - d)/L}. For more elaborate distances with DNA sequences, see the function \code{dist.dna}. } \note{ Missing data (\code{NA}) are coded and treated in R's usual way. } \value{ an object of class \code{dist}. If \code{variance = TRUE} an attribute called \code{"variance"} is given to the returned object. } \author{Emmanuel Paradis} \seealso{ \code{\link{dist.dna}}, \code{\link{cophenetic.phylo}}, \code{\link[stats]{dist}} } \keyword{manip} ape/man/makeLabel.Rd0000644000176200001440000000544314164530562013752 0ustar liggesusers\name{makeLabel} \alias{makeLabel} \alias{makeLabel.character} \alias{makeLabel.phylo} \alias{makeLabel.multiPhylo} \alias{makeLabel.DNAbin} \title{Label Management} \description{ This is a generic function with methods for character vectors, trees of class \code{"phylo"}, lists of trees of class \code{"multiPhylo"}, and DNA sequences of class \code{"DNAbin"}. All options for the class character may be used in the other methods. } \usage{ makeLabel(x, ...) \method{makeLabel}{character}(x, len = 99, space = "_", make.unique = TRUE, illegal = "():;,[]", quote = FALSE, ...) \method{makeLabel}{phylo}(x, tips = TRUE, nodes = TRUE, ...) \method{makeLabel}{multiPhylo}(x, tips = TRUE, nodes = TRUE, ...) \method{makeLabel}{DNAbin}(x, ...) } \arguments{ \item{x}{a vector of mode character or an object for which labels are to be changed.} \item{len}{the maximum length of the labels: those longer than `len' will be truncated.} \item{space}{the character to replace spaces, tabulations, and linebreaks.} \item{make.unique}{a logical specifying whether duplicate labels should be made unique by appending numerals; \code{TRUE} by default.} \item{illegal}{a string specifying the characters to be deleted.} \item{quote}{a logical specifying whether to quote the labels; \code{FALSE} by default.} \item{tips}{a logical specifying whether tip labels are to be modified; \code{TRUE} by default.} \item{nodes}{a logical specifying whether node labels are to be modified; \code{TRUE} by default.} \item{\dots}{further arguments to be passed to or from other methods.} } \details{ The option \code{make.unique} does not work exactly in the same way then the function of the same name: numbers are suffixed to all labels that are identical (without separator). See the examples. If there are 10--99 identical labels, the labels returned are "xxx01", "xxx02", etc, or "xxx001", "xxx002", etc, if they are 100--999, and so on. The number of digits added preserves the option `len'. The default for `len' makes labels short enough to be read by PhyML. Clustal accepts labels up to 30 character long. } \note{ The current version does not perform well when trying to make very short unique labels (e.g., less than 5 character long). } \value{ An object of the appropriate class. } \author{Emmanuel Paradis} \seealso{ \code{\link{makeNodeLabel}}, \code{\link[base]{make.unique}}, \code{\link[base]{make.names}}, \code{\link[base]{abbreviate}}, \code{\link{mixedFontLabel}}, \code{\link{label2table}}, \code{\link{updateLabel}}, \code{\link{checkLabel}} } \examples{ x <- rep("a", 3) makeLabel(x) make.unique(x) # <- from R's base x <- rep("aaaaa", 2) makeLabel(x, len = 3) # made unique and of length 3 makeLabel(x, len = 3, make.unique = FALSE) } \keyword{manip} ape/man/correlogram.formula.Rd0000644000176200001440000000363414164530562016055 0ustar liggesusers\name{correlogram.formula} \alias{correlogram.formula} \title{Phylogenetic Correlogram} \usage{ correlogram.formula(formula, data = NULL, use = "all.obs") } \arguments{ \item{formula}{a formula of the type \code{y1+..+yn ~ g1/../gn}, where the \code{y}'s are the data to analyse and the \code{g}'s are the taxonomic levels.} \item{data}{a data frame containing the variables specified in the formula. If \code{NULL}, the variables are sought in the user's workspace.} \item{use}{a character string specifying how to handle missing values (i.e., \code{NA}). This must be one of "all.obs", "complete.obs", or "pairwise.complete.obs", or any unambiguous abbrevation of these. In the first case, the presence of missing values produces an error. In the second case, all rows with missing values will be removed before computation. In the last case, missing values are removed on a case-by-case basis.} } \description{ This function computes a correlogram from taxonomic levels. } \details{ See the vignette in R: \code{vignette("MoranI")}. } \value{ An object of class \code{correlogram} which is a data frame with three columns: \item{obs}{the computed Moran's I} \item{p.values}{the corresponding P-values} \item{labels}{the names of each level} or an object of class \code{correlogramList} containing a list of objects of class \code{correlogram} if several variables are given as response in \code{formula}. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de} and Emmanuel Paradis} \seealso{ \code{\link{plot.correlogram}, \link{Moran.I}} } \examples{ data(carnivora) ### Using the formula interface: co <- correlogram.formula(SW ~ Order/SuperFamily/Family/Genus, data=carnivora) co plot(co) ### Several correlograms on the same plot: cos <- correlogram.formula(SW + FW ~ Order/SuperFamily/Family/Genus, data=carnivora) cos plot(cos) } \keyword{regression} ape/man/rTraitMult.Rd0000644000176200001440000000407114164530562014200 0ustar liggesusers\name{rTraitMult} \alias{rTraitMult} \title{Multivariate Character Simulation} \description{ This function simulates the evolution of a multivariate set of traits along a phylogeny. The calculation is done recursively from the root. } \usage{ rTraitMult(phy, model, p = 1, root.value = rep(0, p), ancestor = FALSE, asFactor = NULL, trait.labels = paste("x", 1:p, sep = ""), ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{model}{a function specifying the model (see details).} \item{p}{an integer giving the number of traits.} \item{root.value}{a numeric vector giving the values at the root.} \item{ancestor}{a logical value specifying whether to return the values at the nodes as well (by default, only the values at the tips are returned).} \item{asFactor}{the indices of the traits that are returned as factors (discrete traits).} \item{trait.labels}{a vector of mode character giving the names of the traits.} \item{\dots}{further arguments passed to \code{model} if it is a function.} } \details{ The model is specified with an \R function of the form \code{foo(x, l)} where \code{x} is a vector of the traits of the ancestor and \code{l} is the branch length. Other arguments may be added. The function must return a vector of length \code{p}. } \value{ A data frame with \code{p} columns whose names are given by \code{trait.labels} and row names taken from the labels of the tree. } \author{Emmanuel Paradis} \seealso{ \code{\link{rTraitCont}}, \code{\link{rTraitDisc}}, \code{\link{ace}} } \examples{ ## correlated evolution of 2 continuous traits: mod <- function(x, l) { y1 <- rnorm(1, x[1] + 0.5*x[2], 0.1) y2 <- rnorm(1, 0.5*x[1] + x[2], 0.1) c(y1, y2) } set.seed(11) tr <- makeNodeLabel(rcoal(20)) x <- rTraitMult(tr, mod, 2, ancestor = TRUE) op <- par(mfcol = c(2, 1)) plot(x, type = "n") text(x, labels = rownames(x), cex = 0.7) oq <- par(mar = c(0, 1, 0, 1), xpd = TRUE) plot(tr, font = 1, cex = 0.7) nodelabels(tr$node.label, cex = 0.7, adj = 1) par(c(op, oq)) } \keyword{datagen} ape/man/ace.Rd0000644000176200001440000003060614164530562012624 0ustar liggesusers\name{ace} \alias{ace} \alias{print.ace} \alias{logLik.ace} \alias{deviance.ace} \alias{AIC.ace} \alias{anova.ace} \title{Ancestral Character Estimation} \description{ \code{ace} estimates ancestral character states, and the associated uncertainty, for continuous and discrete characters. If \code{marginal = TRUE}, a marginal estimation procedure is used. With this method, the likelihood values at a given node are computed using only the information from the tips (and branches) descending from this node. The present implementation of marginal reconstruction for discrete characters does not calculate the most likely state for each node, integrating over all the possible states, over all the other nodes in the tree, in proportion to their probability. For more details, see the Note below. \code{logLik}, \code{deviance}, and \code{AIC} are generic functions used to extract the log-likelihood, the deviance, or the Akaike information criterion of a fitted object. If no such values are available, \code{NULL} is returned. \code{anova} is another generic function which is used to compare nested models: the significance of the additional parameter(s) is tested with likelihood ratio tests. You must ensure that the models are effectively nested (if they are not, the results will be meaningless). It is better to list the models from the smallest to the largest. } \usage{ ace(x, phy, type = "continuous", method = if (type == "continuous") "REML" else "ML", CI = TRUE, model = if (type == "continuous") "BM" else "ER", scaled = TRUE, kappa = 1, corStruct = NULL, ip = 0.1, use.expm = FALSE, use.eigen = TRUE, marginal = FALSE) \method{print}{ace}(x, digits = 4, ...) \method{logLik}{ace}(object, ...) \method{deviance}{ace}(object, ...) \method{AIC}{ace}(object, ..., k = 2) \method{anova}{ace}(object, ...) } \arguments{ \item{x}{a vector or a factor; an object of class \code{"ace"} in the case of \code{print}.} \item{phy}{an object of class \code{"phylo"}.} \item{type}{the variable type; either \code{"continuous"} or \code{"discrete"} (or an abbreviation of these).} \item{method}{a character specifying the method used for estimation. Four choices are possible: \code{"ML"}, \code{"REML"}, \code{"pic"}, or \code{"GLS"}.} \item{CI}{a logical specifying whether to return the 95\% confidence intervals of the ancestral state estimates (for continuous characters) or the likelihood of the different states (for discrete ones).} \item{model}{a character specifying the model (ignored if \code{method = "GLS"}), or a numeric matrix if \code{type = "discrete"} (see details).} \item{scaled}{a logical specifying whether to scale the contrast estimate (used only if \code{method = "pic"}).} \item{kappa}{a positive value giving the exponent transformation of the branch lengths (see details).} \item{corStruct}{if \code{method = "GLS"}, specifies the correlation structure to be used (this also gives the assumed model).} \item{ip}{the initial value(s) used for the ML estimation procedure when \code{type == "discrete"} (possibly recycled).} \item{use.expm}{a logical specifying whether to use the package \pkg{expm} to compute the matrix exponential (relevant only if \code{type = "d"}). If \code{FALSE}, the function \code{matexpo} from \pkg{ape} is used (see details). This option is ignored if \code{use.eigen = TRUE} (see next).} \item{use.eigen}{a logical (relevant if \code{type = "d"}); if \code{TRUE} then the probability matrix is computed with an eigen decomposition instead of a matrix exponential (see details).} \item{marginal}{a logical (relevant if \code{type = "d"}). By default, the joint reconstruction of the ancestral states are done. Set this option to \code{TRUE} if you want the marginal reconstruction (see details.)} \item{digits}{the number of digits to be printed.} \item{object}{an object of class \code{"ace"}.} \item{k}{a numeric value giving the penalty per estimated parameter; the default is \code{k = 2} which is the classical Akaike information criterion.} \item{\dots}{further arguments passed to or from other methods.} } \details{ If \code{type = "continuous"}, the default model is Brownian motion where characters evolve randomly following a random walk. This model can be fitted by residual maximum likelihood (the default), maximum likelihood (Felsenstein 1973, Schluter et al. 1997), least squares (\code{method = "pic"}, Felsenstein 1985), or generalized least squares (\code{method = "GLS"}, Martins and Hansen 1997, Cunningham et al. 1998). In the last case, the specification of \code{phy} and \code{model} are actually ignored: it is instead given through a correlation structure with the option \code{corStruct}. In the setting \code{method = "ML"} and \code{model = "BM"} (this used to be the default until \pkg{ape} 3.0-7) the maximum likelihood estimation is done simultaneously on the ancestral values and the variance of the Brownian motion process; these estimates are then used to compute the confidence intervals in the standard way. The REML method first estimates the ancestral value at the root (aka, the phylogenetic mean), then the variance of the Brownian motion process is estimated by optimizing the residual log-likelihood. The ancestral values are finally inferred from the likelihood function giving these two parameters. If \code{method = "pic"} or \code{"GLS"}, the confidence intervals are computed using the expected variances under the model, so they depend only on the tree. It could be shown that, with a continous character, REML results in unbiased estimates of the variance of the Brownian motion process while ML gives a downward bias. Therefore the former is recommanded. For discrete characters (\code{type = "discrete"}), only maximum likelihood estimation is available (Pagel 1994) (see \code{\link{MPR}} for an alternative method). The model is specified through a numeric matrix with integer values taken as indices of the parameters. The numbers of rows and of columns of this matrix must be equal, and are taken to give the number of states of the character. For instance, \code{matrix(c(0, 1, 1, 0), 2)} will represent a model with two character states and equal rates of transition, \code{matrix(c(0, 1, 2, 0), 2)} a model with unequal rates, \code{matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3)} a model with three states and equal rates of transition (the diagonal is always ignored). There are short-cuts to specify these models: \code{"ER"} is an equal-rates model (e.g., the first and third examples above), \code{"ARD"} is an all-rates-different model (the second example), and \code{"SYM"} is a symmetrical model (e.g., \code{matrix(c(0, 1, 2, 1, 0, 3, 2, 3, 0), 3)}). If a short-cut is used, the number of states is determined from the data. By default, the likelihood of the different ancestral states of discrete characters are computed with a joint estimation procedure using a procedure similar to the one described in Pupko et al. (2000). If \code{marginal = TRUE}, a marginal estimation procedure is used (this was the only choice until ape 3.1-1). With this method, the likelihood values at a given node are computed using only the information from the tips (and branches) descending from this node. With the joint estimation, all information is used for each node. The difference between these two methods is further explained in Felsenstein (2004, pp. 259-260) and in Yang (2006, pp. 121-126). The present implementation of the joint estimation uses a ``two-pass'' algorithm which is much faster than stochastic mapping while the estimates of both methods are very close. With discrete characters it is necessary to compute the exponential of the rate matrix. The only possibility until \pkg{ape} 3.0-7 was the function \code{\link{matexpo}} in \pkg{ape}. If \code{use.expm = TRUE} and \code{use.eigen = FALSE}, the function \code{\link[expm]{expm}}, in the package of the same name, is used. \code{matexpo} is faster but quite inaccurate for large and/or asymmetric matrices. In case of doubt, use the latter. Since \pkg{ape} 3.0-10, it is possible to use an eigen decomposition avoiding the need to compute the matrix exponential; see details in Lebl (2013, sect. 3.8.3). This is much faster and is now the default. Since version 5.2 of \pkg{ape}, \code{ace} can take state uncertainty for discrete characters into account: this should be coded with \R's \code{\link[base]{NA}} only. More details: \url{https://www.mail-archive.com/r-sig-phylo@r-project.org/msg05286.html} } \note{ Liam Revell points out that for discrete characters the ancestral likelihood values returned with \code{marginal = FALSE} are actually the marginal estimates, while setting \code{marginal = TRUE} returns the conditional (scaled) likelihoods of the subtree: \url{http://blog.phytools.org/2015/05/about-how-acemarginaltrue-does-not.html} } \value{ an object of class \code{"ace"} with the following elements: \item{ace}{if \code{type = "continuous"}, the estimates of the ancestral character values.} \item{CI95}{if \code{type = "continuous"}, the estimated 95\% confidence intervals.} \item{sigma2}{if \code{type = "continuous"}, \code{model = "BM"}, and \code{method = "ML"}, the maximum likelihood estimate of the Brownian parameter.} \item{rates}{if \code{type = "discrete"}, the maximum likelihood estimates of the transition rates.} \item{se}{if \code{type = "discrete"}, the standard-errors of estimated rates.} \item{index.matrix}{if \code{type = "discrete"}, gives the indices of the \code{rates} in the rate matrix.} \item{loglik}{if \code{method = "ML"}, the maximum log-likelihood.} \item{lik.anc}{if \code{type = "discrete"}, the scaled likelihoods of each ancestral state.} \item{call}{the function call.} } \references{ Cunningham, C. W., Omland, K. E. and Oakley, T. H. (1998) Reconstructing ancestral character states: a critical reappraisal. \emph{Trends in Ecology & Evolution}, \bold{13}, 361--366. Felsenstein, J. (1973) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, \bold{25}, 471--492. Felsenstein, J. (1985) Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1--15. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sunderland: Sinauer Associates. Lebl, J. (2013) \emph{Notes on Diffy Qs: Differential Equations for Engineers}. \url{https://www.jirka.org/diffyqs/}. Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative method: a general approach to incorporating phylogenetic information into the analysis of interspecific data. \emph{American Naturalist}, \bold{149}, 646--667. Pagel, M. (1994) Detecting correlated evolution on phylogenies: a general method for the comparative analysis of discrete characters. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{255}, 37--45. Pupko, T., Pe'er, I, Shamir, R., and Graur, D. (2000) A fast algorithm for joint reconstruction of ancestral amino acid sequences. \emph{Molecular Biology and Evolution}, \bold{17}, 890--896. Schluter, D., Price, T., Mooers, A. O. and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution}, \bold{51}, 1699--1711. Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford: Oxford University Press. } \author{Emmanuel Paradis, Ben Bolker} \seealso{ \code{\link{MPR}}, \code{\link{corBrownian}}, \code{\link{compar.ou}}, \code{\link[stats]{anova}} Reconstruction of ancestral sequences can be done with the package \pkg{phangorn} (see function \code{?ancestral.pml}). } \examples{ ### Some random data... data(bird.orders) x <- rnorm(23) ### Compare the three methods for continuous characters: ace(x, bird.orders) ace(x, bird.orders, method = "pic") ace(x, bird.orders, method = "GLS", corStruct = corBrownian(1, bird.orders)) ### For discrete characters: x <- factor(c(rep(0, 5), rep(1, 18))) ans <- ace(x, bird.orders, type = "d") #### Showing the likelihoods on each node: plot(bird.orders, type = "c", FALSE, label.offset = 1) co <- c("blue", "yellow") tiplabels(pch = 22, bg = co[as.numeric(x)], cex = 2, adj = 1) nodelabels(thermo = ans$lik.anc, piecol = co, cex = 0.75) } \keyword{models} ape/man/alex.Rd0000644000176200001440000000263614164530562013027 0ustar liggesusers\name{alex} \alias{alex} \title{Alignment Explorer With Multiple Devices} \description{ This function helps to explore DNA alignments by zooming in. The user clicks twice defining the opposite corners of the portion which is extracted and drawned on a new window. } \usage{ alex(x, ...) } \arguments{ \item{x}{an object of class \code{"DNAbin"}.} \item{\dots}{further arguments to pass to \code{image.DNAbin}.} } \details{ This function works with a DNA alignment (freshly) plotted on an interactive graphical device (i.e., not a file) with \code{image}. After calling \code{alex}, the user clicks twice defining a rectangle in the alignment, then this portion of the alignment is extacted and plotted on a \emph{new} window. The user can click as many times on the alignment. The process is stopped by a right-click. If the user clicks twice outside the alignment, a message ``Try again!'' is printed. Each time \code{alex} is called, the alignment is plotted on a new window without closing or deleting those possibly already plotted. In all cases, the device where \code{x} is plotted is the active window after the operation. It should \emph{not} be closed during the whole process. } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{image.DNAbin}}, \code{\link{trex}}, \code{\link{alview}} } \examples{ \dontrun{ data(woodmouse) image(woodmouse) alex(woodmouse) }} \keyword{hplot} ape/man/plot.phylo.Rd0000644000176200001440000003135714164530562014210 0ustar liggesusers\name{plot.phylo} \alias{plot.phylo} \alias{plot.multiPhylo} \title{Plot Phylogenies} \description{ These functions plot phylogenetic trees on the current graphical device. } \usage{ \method{plot}{phylo}(x, type = "phylogram", use.edge.length = TRUE, node.pos = NULL, show.tip.label = TRUE, show.node.label = FALSE, edge.color = NULL, edge.width = NULL, edge.lty = NULL, node.color = NULL, node.width = NULL, node.lty = NULL, font = 3, cex = par("cex"), adj = NULL, srt = 0, no.margin = FALSE, root.edge = FALSE, label.offset = 0, underscore = FALSE, x.lim = NULL, y.lim = NULL, direction = "rightwards", lab4ut = NULL, tip.color = par("col"), plot = TRUE, rotate.tree = 0, open.angle = 0, node.depth = 1, align.tip.label = FALSE, ...) \method{plot}{multiPhylo}(x, layout = 1, ...) } \arguments{ \item{x}{an object of class \code{"phylo"} or of class \code{"multiPhylo"}.} \item{type}{a character string specifying the type of phylogeny to be drawn; it must be one of "phylogram" (the default), "cladogram", "fan", "unrooted", "radial" or any unambiguous abbreviation of these.} \item{use.edge.length}{a logical indicating whether to use the edge lengths of the phylogeny to draw the branches (the default) or not (if \code{FALSE}). This option has no effect if the object of class \code{"phylo"} has no `edge.length' element.} \item{node.pos}{a numeric taking the value 1 or 2 which specifies the vertical position of the nodes with respect to their descendants. If \code{NULL} (the default), then the value is determined in relation to `type' and `use.edge.length' (see details).} \item{show.tip.label}{a logical indicating whether to show the tip labels on the phylogeny (defaults to \code{TRUE}, i.e. the labels are shown).} \item{show.node.label}{a logical indicating whether to show the node labels on the phylogeny (defaults to \code{FALSE}, i.e. the labels are not shown).} \item{edge.color}{a vector of mode character giving the colours used to draw the branches of the plotted phylogeny. These are taken to be in the same order than the component \code{edge} of \code{phy}. If fewer colours are given than the length of \code{edge}, then the colours are recycled.} \item{edge.width}{a numeric vector giving the width of the branches of the plotted phylogeny. These are taken to be in the same order than the component \code{edge} of \code{phy}. If fewer widths are given than the length of \code{edge}, then these are recycled.} \item{edge.lty}{same as the previous argument but for line types; 1: plain, 2: dashed, 3: dotted, 4: dotdash, 5: longdash, 6: twodash.} \item{node.color}{a vector of mode character giving the colours used to draw the perpendicular lines associated with each node of the plotted phylogeny. These are taken to be in the same order than the component \code{node} of \code{phy}. If fewer colours are given than the length of \code{node}, then the colours are recycled.} \item{node.width}{as the previous argument, but for line widths.} \item{node.lty}{as the previous argument, but for line types; 1: plain, 2: dashed, 3: dotted, 4: dotdash, 5: longdash, 6: twodash.} \item{font}{an integer specifying the type of font for the labels: 1 (plain text), 2 (bold), 3 (italic, the default), or 4 (bold italic).} \item{cex}{a numeric value giving the factor scaling of the tip and node labels (Character EXpansion). The default is to take the current value from the graphical parameters.} \item{adj}{a numeric specifying the justification of the text strings of the labels: 0 (left-justification), 0.5 (centering), or 1 (right-justification). This option has no effect if \code{type = "unrooted"}. If \code{NULL} (the default) the value is set with respect of \code{direction} (see details).} \item{srt}{a numeric giving how much the labels are rotated in degrees (negative values are allowed resulting in clock-like rotation); the value has an effect respectively to the value of \code{direction} (see Examples). This option has no effect if \code{type = "unrooted"}.} \item{no.margin}{a logical. If \code{TRUE}, the margins are set to zero and the plot uses all the space of the device (note that this was the behaviour of \code{plot.phylo} up to version 0.2-1 of `ape' with no way to modify it by the user, at least easily).} \item{root.edge}{a logical indicating whether to draw the root edge (defaults to FALSE); this has no effect if `use.edge.length = FALSE' or if `type = "unrooted"'.} \item{label.offset}{a numeric giving the space between the nodes and the tips of the phylogeny and their corresponding labels. This option has no effect if \code{type = "unrooted"}.} \item{underscore}{a logical specifying whether the underscores in tip labels should be written as spaces (the default) or left as are (if \code{TRUE}).} \item{x.lim}{a numeric vector of length one or two giving the limit(s) of the x-axis. If \code{NULL}, this is computed with respect to various parameters such as the string lengths of the labels and the branch lengths. If a single value is given, this is taken as the upper limit.} \item{y.lim}{same than above for the y-axis.} \item{direction}{a character string specifying the direction of the tree. Four values are possible: "rightwards" (the default), "leftwards", "upwards", and "downwards".} \item{lab4ut}{(= labels for unrooted trees) a character string specifying the display of tip labels for unrooted trees (can be abbreviated): either \code{"horizontal"} where all labels are horizontal (the default if \code{type = "u"}), or \code{"axial"} where the labels are displayed in the axis of the corresponding terminal branches. This option has an effect if \code{type = "u"}, \code{"f"}, or \code{"r"}.} \item{tip.color}{the colours used for the tip labels, eventually recycled (see examples).} \item{plot}{a logical controlling whether to draw the tree. If \code{FALSE}, the graphical device is set as if the tree was plotted, and the coordinates are saved as well.} \item{rotate.tree}{for "fan", "unrooted", or "radial" trees: the rotation of the whole tree in degrees (negative values are accepted).} \item{open.angle}{if \code{type = "f"} or \code{"r"}, the angle in degrees left blank. Use a non-zero value if you want to call \code{\link{axisPhylo}} after the tree is plotted.} \item{node.depth}{an integer value (1 or 2) used if branch lengths are not used to plot the tree; 1: the node depths are proportional to the number of tips descending from each node (the default and was the only possibility previously), 2: they are evenly spaced.} \item{align.tip.label}{a logical value or an integer. If \code{TRUE}, the tips are aligned and dotted lines are drawn between the tips of the tree and the labels. If an integer, the tips are aligned and this gives the type of the lines (\code{lty}).} \item{layout}{the number of trees to be plotted simultaneously.} \item{\dots}{further arguments to be passed to \code{plot} or to \code{plot.phylo}.} } \details{ If \code{x} is a list of trees (i.e., an object of class \code{"multiPhylo"}), then any further argument may be passed with \code{...} and could be any one of those listed above for a single tree. The font format of the labels of the nodes and the tips is the same. If \code{no.margin = TRUE}, the margins are set to zero and are not restored after plotting the tree, so that the user can access the coordinates system of the plot. The option `node.pos' allows the user to alter the vertical position (i.e., ordinates) of the nodes. If \code{node.pos = 1}, then the ordinate of a node is the mean of the ordinates of its direct descendants (nodes and/or tips). If \code{node.pos = 2}, then the ordinate of a node is the mean of the ordinates of all the tips of which it is the ancestor. If \code{node.pos = NULL} (the default), then its value is determined with respect to other options: if \code{type = "phylogram"} then `node.pos = 1'; if \code{type = "cladogram"} and \code{use.edge.length = FALSE} then `node.pos = 2'; if \code{type = "cladogram"} and \code{use.edge.length = TRUE} then `node.pos = 1'. Remember that in this last situation, the branch lengths make sense when projected on the x-axis. If \code{adj} is not specified, then the value is determined with respect to \code{direction}: if \code{direction = "leftwards"} then \code{adj = 1} (0 otherwise). If the arguments \code{x.lim} and \code{y.lim} are not specified by the user, they are determined roughly by the function. This may not always give a nice result: the user may check these values with the (invisibly) returned list (see ``Value:''). If you use \code{align.tip.label = TRUE} with \code{type = "fan"}, you will have certainly to set \code{x.lim} and \code{y.lim} manually. If you resize manually the graphical device (windows or X11) you may need to replot the tree. } \note{ The argument \code{asp} cannot be passed with \code{\dots}. } \value{ \code{plot.phylo} returns invisibly a list with the following components which values are those used for the current plot: \item{type}{} \item{use.edge.length}{} \item{node.pos}{} \item{node.depth}{} \item{show.tip.label}{} \item{show.node.label}{} \item{font}{} \item{cex}{} \item{adj}{} \item{srt}{} \item{no.margin}{} \item{label.offset}{} \item{x.lim}{} \item{y.lim}{} \item{direction}{} \item{tip.color}{} \item{Ntip}{} \item{Nnode}{} \item{root.time}{} \item{align.tip.label}{} } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{trex}}, \code{\link{kronoviz}}, \code{\link{add.scale.bar}}, \code{\link{axisPhylo}}, \code{\link{nodelabels}}, \code{\link{edges}}, \code{\link[graphics]{plot}} for the basic plotting function in R } \examples{ ### An extract from Sibley and Ahlquist (1990) cat("(((Strix_aluco:4.2,Asio_otus:4.2):3.1,", "Athene_noctua:7.3):6.3,Tyto_alba:13.5);", file = "ex.tre", sep = "\n") tree.owls <- read.tree("ex.tre") plot(tree.owls) unlink("ex.tre") # delete the file "ex.tre" ### Show the types of trees. layout(matrix(1:6, 3, 2)) plot(tree.owls, main = "With branch lengths") plot(tree.owls, type = "c") plot(tree.owls, type = "u") plot(tree.owls, use.edge.length = FALSE, main = "Without branch lengths") plot(tree.owls, type = "c", use.edge.length = FALSE) plot(tree.owls, type = "u", use.edge.length = FALSE) layout(1) data(bird.orders) ### using random colours and thickness plot(bird.orders, edge.color = sample(colors(), length(bird.orders$edge)/2), edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE)) title("Random colours and branch thickness") ### rainbow colouring... X <- c("red", "orange", "yellow", "green", "blue", "purple") plot(bird.orders, edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE), edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE)) title("Rainbow colouring") plot(bird.orders, type = "c", use.edge.length = FALSE, edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE), edge.width = rep(5, length(bird.orders$edge)/2)) segments(rep(0, 6), 6.5:1.5, rep(2, 6), 6.5:1.5, lwd = 5, col = X) text(rep(2.5, 6), 6.5:1.5, paste(X, "..."), adj = 0) title("Character mapping...") plot(bird.orders, "u", font = 1, cex = 0.75) data(bird.families) plot(bird.families, "u", lab4ut = "axial", font = 1, cex = 0.5) plot(bird.families, "r", font = 1, cex = 0.5) ### cladogram with oblique tip labels plot(bird.orders, "c", FALSE, direction = "u", srt = -40, x.lim = 25.5) ### facing trees with different informations... tr <- bird.orders tr$tip.label <- rep("", 23) layout(matrix(1:2, 1, 2), c(5, 4)) plot(bird.orders, "c", FALSE, adj = 0.5, no.margin = TRUE, label.offset = 0.8, edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE), edge.width = rep(5, length(bird.orders$edge)/2)) text(7.5, 23, "Facing trees with\ndifferent informations", font = 2) plot(tr, "p", direction = "l", no.margin = TRUE, edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE)) ### Recycling of arguments gives a lot of possibilities ### for tip labels: plot(bird.orders, tip.col = c(rep("red", 5), rep("blue", 18)), font = c(rep(3, 5), rep(2, 17), 1)) plot(bird.orders, tip.col = c("blue", "green"), cex = 23:1/23 + .3, font = 1:3) co <- c(rep("blue", 9), rep("green", 35)) plot(bird.orders, "f", edge.col = co) plot(bird.orders, edge.col = co) layout(1) } \keyword{hplot} ape/man/chronoMPL.Rd0000644000176200001440000000477514164530562013745 0ustar liggesusers\name{chronoMPL} \alias{chronoMPL} \title{Molecular Dating With Mean Path Lengths} \usage{ chronoMPL(phy, se = TRUE, test = TRUE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{se}{a logical specifying whether to compute the standard-errors of the node ages (\code{TRUE} by default).} \item{test}{a logical specifying whether to test the molecular clock at each node (\code{TRUE} by default).} } \description{ This function estimates the node ages of a tree using the mean path lengths method of Britton et al. (2002). The branch lengths of the input tree are interpreted as (mean) numbers of substitutions. } \details{ The mean path lengths (MPL) method estimates the age of a node with the mean of the distances from this node to all tips descending from it. Under the assumption of a molecular clock, standard-errors of the estimates node ages can be computed (Britton et al. 2002). The tests performed if \code{test = TRUE} is a comparison of the MPL of the two subtrees originating from a node; the null hypothesis is that the rate of substitution was the same in both subtrees (Britton et al. 2002). The test statistic follows, under the null hypothesis, a standard normal distribution. The returned \emph{P}-value is the probability of observing a greater absolute value (i.e., a two-sided test). No correction for multiple testing is applied: this is left to the user. Absolute dating can be done by multiplying the edge lengths found by calibrating one node age. } \note{ The present version requires a dichotomous tree. } \value{ an object of class \code{"phylo"} with branch lengths as estimated by the function. There are, by default, two attributes: \item{stderr}{the standard-errors of the node ages.} \item{Pval}{the \emph{P}-value of the test of the molecular clock for each node.} } \references{ Britton, T., Oxelman, B., Vinnersten, A. and Bremer, K. (2002) Phylogenetic dating with confidence intervals using mean path lengths. \emph{Molecular Phylogenetics and Evolution}, \bold{24}, 58--65. } \author{Emmanuel Paradis} \seealso{ \code{\link{chronopl}} } \examples{ tr <- rtree(10) tr$edge.length <- 5*tr$edge.length chr <- chronoMPL(tr) layout(matrix(1:4, 2, 2, byrow = TRUE)) plot(tr) title("The original tree") plot(chr) axisPhylo() title("The dated MPL tree") plot(chr) nodelabels(round(attr(chr, "stderr"), 3)) title("The standard-errors") plot(tr) nodelabels(round(attr(chr, "Pval"), 3)) title("The tests") layout(1) } \keyword{models} ape/man/AAbin.Rd0000644000176200001440000001214714164530562013046 0ustar liggesusers\name{AAbin} \alias{AAbin} \alias{print.AAbin} \alias{[.AAbin} \alias{as.character.AAbin} \alias{labels.AAbin} \alias{image.AAbin} \alias{as.AAbin} \alias{as.AAbin.AAString} \alias{as.AAbin.AAStringSet} \alias{as.AAbin.AAMultipleAlignment} \alias{as.AAbin.character} \alias{as.phyDat.AAbin} \alias{dist.aa} \alias{AAsubst} \alias{c.AAbin} \alias{cbind.AAbin} \alias{rbind.AAbin} \alias{as.AAbin.list} \alias{as.list.AAbin} \alias{as.matrix.AAbin} \title{Amino Acid Sequences} \description{ These functions help to create and manipulate AA sequences. } \usage{ \method{print}{AAbin}(x, \dots) \method{[}{AAbin}(x, i, j, drop = FALSE) \method{c}{AAbin}(..., recursive = FALSE) \method{rbind}{AAbin}(\dots) \method{cbind}{AAbin}(\dots, check.names = TRUE, fill.with.Xs = FALSE, quiet = FALSE) \method{as.character}{AAbin}(x, \dots) \method{labels}{AAbin}(object, \dots) \method{image}{AAbin}(x, what, col, bg = "white", xlab = "", ylab = "", show.labels = TRUE, cex.lab = 1, legend = TRUE, grid = FALSE, show.aa = FALSE, aa.cex = 1, aa.font = 1, aa.col = "black",\dots) as.AAbin(x, \dots) \method{as.AAbin}{character}(x, \dots) \method{as.AAbin}{list}(x, ...) \method{as.AAbin}{AAString}(x, ...) \method{as.AAbin}{AAStringSet}(x, ...) \method{as.AAbin}{AAMultipleAlignment}(x, ...) \method{as.list}{AAbin}(x, ...) \method{as.matrix}{AAbin}(x, ...) \method{as.phyDat}{AAbin}(x, \dots) dist.aa(x, pairwise.deletion = FALSE, scaled = FALSE) AAsubst(x) } \arguments{ \item{x, object}{an object of class \code{"AAbin"} (or else depending on the function).} \item{i, j}{indices of the rows and/or columns to select or to drop. They may be numeric, logical, or character (in the same way than for standard \R objects).} \item{drop}{logical; if \code{TRUE}, the returned object is of the lowest possible dimension.} \item{recursive}{logical; whether to go down lists and concatenate its elements.} \item{check.names}{a logical specifying whether to check the rownames before binding the columns (see details).} \item{fill.with.Xs}{a logical indicating whether to keep all possible individuals as indicating by the rownames, and eventually filling the missing data with insertion gaps (ignored if \code{check.names = FALSE}).} \item{quiet}{a logical to switch off warning messages when some rows are dropped.} \item{what}{a vector of characters specifying the amino acids to visualize. Currently, the only possible choice is to show the three categories hydrophobic, small, and hydrophilic.} \item{col}{a vector of colours. If missing, this is set to ``red'', ``yellow'' and ``blue''.} \item{bg}{the colour used for AA codes not among \code{what} (typically X and *).} \item{xlab}{the label for the \emph{x}-axis; none by default.} \item{ylab}{Idem for the \emph{y}-axis. Note that by default, the labels of the sequences are printed on the \emph{y}-axis (see next option).} \item{show.labels}{a logical controlling whether the sequence labels are printed (\code{TRUE} by default).} \item{cex.lab}{a single numeric controlling the size of the sequence labels. Use \code{cex.axis} to control the size of the annotations on the \emph{x}-axis.} \item{legend}{a logical controlling whether the legend is plotted (\code{TRUE} by default).} \item{grid}{a logical controlling whether to draw a grid (\code{FALSE} by default).} \item{show.aa}{a logical controlling whether to show the AA symbols (\code{FALSE} by default).} \item{aa.cex, aa.font, aa.col}{control the aspect of the AA symbols (ignored if the previous is \code{FALSE}).} \item{pairwise.deletion}{a logical indicating whether to delete the sites with missing data in a pairwise way. The default is to delete the sites with at least one missing data for all sequences.} \item{scaled}{a logical value specifying whether to scale the number of AA differences by the sequence length.} \item{\dots}{further arguments to be passed to or from other methods.} } \details{ These functions help to manipulate amino acid sequences of class \code{"AAbin"}. These objects are stored in vectors, matrices, or lists which can be manipulated with the usual \code{[} operator. There is a conversion function to and from characters. The function \code{dist.aa} computes the number of AA differences between each pair of sequences in a matrix; this can be scaled by the sequence length. See the function \code{\link[phangorn]{dist.ml}} in \pkg{phangorn} for evolutionary distances with AA sequences. The function \code{AAsubst} returns the indices of the polymorphic sites (similar to \code{\link{seg.sites}} for DNA sequences; see examples below). The two functions \code{cbind.AAbin} and \code{rbind.AAbin} work in the same way than the similar methods for the class \code{"DNAbin"}: see \code{\link{cbind.DNAbin}} for more explanations about their respective behaviours. } \value{ an object of class \code{"AAbin"}, \code{"character"}, \code{"dist"}, or \code{"numeric"}, depending on the function. } \author{Emmanuel Paradis, Franz Krah} \seealso{ \code{\link{read.FASTA}}, \code{\link{trans}}, \code{\link{alview}} } \examples{ data(woodmouse) AA <- trans(woodmouse, 2) seg.sites(woodmouse) AAsubst(AA) } \keyword{manip} ape/man/as.alignment.Rd0000644000176200001440000000567114164530562014460 0ustar liggesusers\name{as.alignment} \alias{as.alignment} \alias{as.DNAbin} \alias{as.DNAbin.character} \alias{as.DNAbin.list} \alias{as.DNAbin.alignment} \alias{as.character.DNAbin} \alias{as.DNAbin.DNAString} \alias{as.DNAbin.DNAStringSet} \alias{as.DNAbin.PairwiseAlignmentsSingleSubject} \alias{as.DNAbin.DNAMultipleAlignment} \title{Conversion Among DNA Sequence Internal Formats} \description{ These functions transform a set of DNA sequences among various internal formats. } \usage{ as.alignment(x) as.DNAbin(x, ...) \method{as.DNAbin}{character}(x, ...) \method{as.DNAbin}{list}(x, ...) \method{as.DNAbin}{alignment}(x, ...) \method{as.DNAbin}{DNAString}(x, ...) \method{as.DNAbin}{DNAStringSet}(x, ...) \method{as.DNAbin}{PairwiseAlignmentsSingleSubject}(x, ...) \method{as.DNAbin}{DNAMultipleAlignment}(x, ...) \method{as.character}{DNAbin}(x, ...) } \arguments{ \item{x}{a matrix or a list containing the DNA sequences, or an object of class \code{"alignment"}.} \item{\dots}{further arguments to be passed to or from other methods.} } \details{ For \code{as.alignment}, the sequences given as argument should be stored as matrices or lists of single-character strings (the format used in \pkg{ape} before version 1.10). The returned object is in the format used in the package \pkg{seqinr} to store aligned sequences. \code{as.DNAbin} is a generic function with methods so that it works with sequences stored into vectors, matrices, or lists. It can convert some S4 classes from the package \pkg{Biostrings} in BioConductor. For consistency within \pkg{ape}, this uses an S3-style syntax. To convert objects of class \code{"DNAStringSetList"}, see the examples. \code{as.character} is a generic function: the present method converts objects of class \code{"DNAbin"} into the format used before \pkg{ape} 1.10 (matrix of single characters, or list of vectors of single characters). This function must be used first to convert objects of class \code{"DNAbin"} into the class \code{"alignment"}. } \value{ an object of class \code{"alignment"} in the case of \code{"as.alignment"}; an object of class \code{"DNAbin"} in the case of \code{"as.DNAbin"}; a matrix of mode character or a list containing vectors of mode character in the case of \code{"as.character"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{read.dna}}, \code{\link{read.GenBank}}, \code{\link{write.dna}} } \examples{ data(woodmouse) x <- as.character(woodmouse) x[, 1:20] str(as.alignment(x)) identical(as.DNAbin(x), woodmouse) ### conversion from BioConductor: \dontrun{ if (require(Biostrings)) { data(phiX174Phage) X <- as.DNAbin(phiX174Phage) ## base frequencies: base.freq(X) # from ape alphabetFrequency(phiX174Phage) # from Biostrings ### for objects of class "DNAStringSetList" X <- lapply(x, as.DNAbin) # a list of lists ### to put all sequences in a single list: X <- unlist(X, recursive = FALSE) class(X) <- "DNAbin" } } } \keyword{manip} ape/man/bind.tree.Rd0000644000176200001440000001021014164530562013733 0ustar liggesusers\name{bind.tree} \alias{bind.tree} \alias{+.phylo} \title{Binds Trees} \usage{ bind.tree(x, y, where = "root", position = 0, interactive = FALSE) \special{x + y} } \arguments{ \item{x}{an object of class \code{"phylo"}.} \item{y}{an object of class \code{"phylo"}.} \item{where}{an integer giving the number of the node or tip of the tree \code{x} where the tree \code{y} is binded (\code{"root"} is a short-cut for the root).} \item{position}{a numeric value giving the position from the tip or node given by \code{node} where the tree \code{y} is binded; negative values are ignored.} \item{interactive}{if \code{TRUE} the user is asked to choose the tip or node of \code{x} by clicking on the tree which must be plotted.} } \description{ This function binds together two phylogenetic trees to give a single object of class \code{"phylo"}. } \details{ The argument \code{x} can be seen as the receptor tree, whereas \code{y} is the donor tree. The root of \code{y} is then grafted on a location of \code{x} specified by \code{where} and, possibly, \code{position}. If \code{y} has a root edge, this is added as in internal branch in the resulting tree. \code{x + y} is a shortcut for: \preformatted{ bind.tree(x, y, position = if (is.null(x$root.edge)) 0 else x$root.edge) } If only one of the trees has no branch length, the branch lengths of the other one are ignored with a warning. If one (or both) of the trees has no branch length, it is possible to specify a value of 'position' to graft 'y' below the node of 'x' specified by 'where'. In this case, the exact value of 'position' is not important as long as it is greater than zero. The new node will be multichotomous if 'y' has no root edge. This can be solved by giving an arbitrary root edge to 'y' beforehand (e.g., \code{y$root.edge <- 1}): it will be deleted during the binding operation. } \value{ an object of class \code{"phylo"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{drop.tip}}, \code{\link{root}} } \examples{ ### binds the two clades of bird orders cat("((Struthioniformes:21.8,Tinamiformes:21.8):4.1,", "((Craciformes:21.6,Galliformes:21.6):1.3,Anseriformes:22.9):3.0):2.1;", file = "ex1.tre", sep = "\n") cat("(Turniciformes:27.0,(Piciformes:26.3,((Galbuliformes:24.4,", "((Bucerotiformes:20.8,Upupiformes:20.8):2.6,", "(Trogoniformes:22.1,Coraciiformes:22.1):1.3):1.0):0.6,", "(Coliiformes:24.5,(Cuculiformes:23.7,(Psittaciformes:23.1,", "(((Apodiformes:21.3,Trochiliformes:21.3):0.6,", "(Musophagiformes:20.4,Strigiformes:20.4):1.5):0.6,", "((Columbiformes:20.8,(Gruiformes:20.1,Ciconiiformes:20.1):0.7):0.8,", "Passeriformes:21.6):0.9):0.6):0.6):0.8):0.5):1.3):0.7):1.0;", file = "ex2.tre", sep = "\n") tree.bird1 <- read.tree("ex1.tre") tree.bird2 <- read.tree("ex2.tre") unlink(c("ex1.tre", "ex2.tre")) # clean-up (birds <- tree.bird1 + tree.bird2) layout(matrix(c(1, 2, 3, 3), 2, 2)) plot(tree.bird1) plot(tree.bird2) plot(birds) ### examples with random trees x <- rtree(4, tip.label = LETTERS[1:4]) y <- rtree(4, tip.label = LETTERS[5:8]) x <- makeNodeLabel(x, prefix = "x_") y <- makeNodeLabel(y, prefix = "y_") x$root.edge <- y$root.edge <- .2 z <- bind.tree(x, y, po=.2) plot(y, show.node.label = TRUE, font = 1, root.edge = TRUE) title("y") plot(x, show.node.label = TRUE, font = 1, root.edge = TRUE) title("x") plot(z, show.node.label = TRUE, font = 1, root.edge = TRUE) title("z <- bind.tree(x, y, po=.2)") ## make sure the terminal branch length is long enough: x$edge.length[x$edge[, 2] == 2] <- 0.2 z <- bind.tree(x, y, 2, .1) plot(y, show.node.label = TRUE, font = 1, root.edge = TRUE) title("y") plot(x, show.node.label = TRUE, font = 1, root.edge = TRUE) title("x") plot(z, show.node.label = TRUE, font = 1, root.edge = TRUE) title("z <- bind.tree(x, y, 2, .1)") x <- rtree(50) y <- rtree(50) x$root.edge <- y$root.edge <- .2 z <- x + y plot(y, show.tip.label = FALSE, root.edge = TRUE); axisPhylo() title("y") plot(x, show.tip.label = FALSE, root.edge = TRUE); axisPhylo() title("x") plot(z, show.tip.label = FALSE, root.edge = TRUE); axisPhylo() title("z <- x + y") layout(1) } \keyword{manip} ape/man/gammaStat.Rd0000644000176200001440000000273714164530562014016 0ustar liggesusers\name{gammaStat} \alias{gammaStat} \title{Gamma-Statistic of Pybus and Harvey} \usage{ gammaStat(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \description{ This function computes the gamma-statistic which summarizes the information contained in the inter-node intervals of a phylogeny. It is assumed that the tree is ultrametric. Note that the function does not check that the tree is effectively ultrametric, so if it is not, the returned result may not be meaningful. } \value{ a numeric vector of length one. } \details{ The gamma-statistic is a summary of the information contained in the inter-node intervals of a phylogeny; it follows, under the assumption that the clade diversified with constant rates, a normal distribution with mean zero and standard-deviation unity (Pybus and Harvey 2000). Thus, the null hypothesis that the clade diversified with constant rates may be tested with \code{2*(1 - pnorm(abs(gammaStat(phy))))} for a two-tailed test, or \code{1 - pnorm(abs(gammaStat(phy)))} for a one-tailed test, both returning the corresponding P-value. } \references{ Pybus, O. G. and Harvey, P. H. (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{267}, 2267--2272. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{ltt.plot}}, \code{\link{skyline}} } \keyword{univar} ape/man/seg.sites.Rd0000644000176200001440000000304114164530562013771 0ustar liggesusers\name{seg.sites} \alias{seg.sites} \title{ Find Segregating Sites in DNA Sequences } \usage{ seg.sites(x, strict = FALSE, trailingGapsAsN = TRUE) } \arguments{ \item{x}{a matrix or a list which contains the DNA sequences.} \item{strict}{a logical value; if \code{TRUE}, ambiguities and gaps in the sequences are not interpreted in the usual way.} \item{trailingGapsAsN}{a logical value; if \code{TRUE} (the default), the leading and trailing alignment gaps are considered as unknown bases (i.e., N).} } \description{ This function gives the indices of segregating (polymorphic) sites in a sample of DNA sequences. } \details{ If the sequences are in a list, they must all be of the same length. If \code{strict = FALSE} (the default), the following rule is used to determine if a site is polymorphic or not in the presence of ambiguous bases: `A' and `R' are not interpreted as different, `A' and `Y' are interpreted as different, and `N' and any other base (ambiguous or not) are interpreted as not different. If \code{strict = TRUE}, all letters are considered different. Alignment gaps are considered different from all letters except for the leading and trailing gaps if \code{trailingGapsAsN = TRUE} (which is the default). } \value{ A numeric (integer) vector giving the indices of the segregating sites. } \author{Emmanuel Paradis} \seealso{ \code{\link{base.freq}}, \code{theta.s}, \code{nuc.div} (last two in \pkg{pegas}) } \examples{ data(woodmouse) y <- seg.sites(woodmouse) y length(y) } \keyword{univar} ape/man/pcoa.Rd0000644000176200001440000001612014164530562013011 0ustar liggesusers\name{pcoa} \alias{pcoa} \alias{biplot.pcoa} \title{ Principal Coordinate Analysis } \description{ Function \code{\link{pcoa}} computes principal coordinate decomposition (also called classical scaling) of a distance matrix D (Gower 1966). It implements two correction methods for negative eigenvalues. } \usage{ pcoa(D, correction="none", rn=NULL) \method{biplot}{pcoa}(x, Y=NULL, plot.axes = c(1,2), dir.axis1=1, dir.axis2=1, rn=NULL, main=NULL, ...) } \arguments{ \item{D}{ A distance matrix of class \code{dist} or \code{matrix}. } \item{correction}{ Correction methods for negative eigenvalues (details below): \code{"lingoes"} and \code{"cailliez"}. Default value: \code{"none"}. } \item{rn}{ An optional vector of row names, of length n, for the n objects. } \item{x}{ Output object from \code{\link{pcoa}}. } \item{Y}{ Any rectangular data table containing explanatory variables to be projected onto the ordination plot. That table may contain, for example, the community composition data used to compute D, or any transformation of these data; see examples. } \item{plot.axes}{ The two PCoA axes to plot. } \item{dir.axis1}{ = -1 to revert axis 1 for the projection of points and variables. Default value: +1. } \item{dir.axis2}{ = -1 to revert axis 2 for the projection of points and variables. Default value: +1. } \item{main}{An optional title.} \item{...}{ Other graphical arguments passed to function. } } \details{ This function implements two methods for correcting for negative values in principal coordinate analysis (PCoA). Negative eigenvalues can be produced in PCoA when decomposing distance matrices produced by coefficients that are not Euclidean (Gower and Legendre 1986, Legendre and Legendre 1998). In \code{pcoa}, when negative eigenvalues are present in the decomposition results, the distance matrix D can be modified using either the Lingoes or the Cailliez procedure to produce results without negative eigenvalues. In the Lingoes (1971) procedure, a constant c1, equal to twice absolute value of the largest negative value of the original principal coordinate analysis, is added to each original squared distance in the distance matrix, except the diagonal values. A newe principal coordinate analysis, performed on the modified distances, has at most (n-2) positive eigenvalues, at least 2 null eigenvalues, and no negative eigenvalue. In the Cailliez (1983) procedure, a constant c2 is added to the original distances in the distance matrix, except the diagonal values. The calculation of c2 is described in Legendre and Legendre (1998). A new principal coordinate analysis, performed on the modified distances, has at most (n-2) positive eigenvalues, at least 2 null eigenvalues, and no negative eigenvalue. In all cases, only the eigenvectors corresponding to positive eigenvalues are shown in the output list. The eigenvectors are scaled to the square root of the corresponding eigenvalues. Gower (1966) has shown that eigenvectors scaled in that way preserve the original distance (in the D matrix) among the objects. These eigenvectors can be used to plot ordination graphs of the objects. We recommend not to use PCoA to produce ordinations from the chord, chi-square, abundance profile, or Hellinger distances. It is easier to first transform the community composition data using the following transformations, available in the \code{decostand} function of the \code{vegan} package, and then carry out a principal component analysis (PCA) on the transformed data: \describe{ \item{ }{Chord transformation: decostand(spiders,"normalize") } \item{ }{Transformation to relative abundance profiles: decostand(spiders,"total") } \item{ }{Hellinger transformation: decostand(spiders,"hellinger") } \item{ }{Chi-square transformation: decostand(spiders,"chi.square") } } The ordination results will be identical and the calculations shorter. This two-step ordination method, called transformation-based PCA (tb-PCA), was described by Legendre and Gallagher (2001). The \code{biplot.pcoa} function produces plots for any pair of principal coordinates. The original variables can be projected onto the ordination plot. } \value{ \item{correction }{The values of parameter \code{correction} and variable 'correct' in the function. } \item{note }{A note describing the type of correction done, if any. } \item{values }{The eigenvalues and related information: } \item{Eigenvalues}{All eigenvalues (positive, null, negative). } \item{Relative_eig}{Relative eigenvalues. } \item{Corr_eig}{Corrected eigenvalues (Lingoes correction); Legendre and Legendre (1998, p. 438, eq. 9.27). } \item{Rel_corr_eig}{Relative eigenvalues after Lingoes or Cailliez correction. } \item{Broken_stick}{Expected fractions of variance under the broken stick model. } \item{Cumul_eig}{Cumulative relative eigenvalues. } \item{Cum_corr_eig}{Cumulative corrected relative eigenvalues. } \item{Cumul_br_stick}{Cumulative broken stick fractions. } \item{vectors}{The principal coordinates with positive eigenvalues. } \item{trace}{The trace of the distance matrix. This is also the sum of all eigenvalues, positive and negative. } \item{vectors.cor }{The principal coordinates with positive eigenvalues from the distance matrix corrected using the method specified by parameter \code{correction}. } \item{trace.cor }{The trace of the corrected distance matrix. This is also the sum of its eigenvalues. } } \references{ Cailliez, F. (1983) The analytical solution of the additive constant problem. \emph{Psychometrika}, \bold{48}, 305--308. Gower, J. C. (1966) Some distance properties of latent root and vector methods used in multivariate analysis. \emph{Biometrika}, \bold{53}, 325--338. Gower, J. C. and Legendre, P. (1986) Metric and Euclidean properties of dissimilarity coefficients. \emph{Journal of Classification}, \bold{3}, 5--48. Legendre, P. and Gallagher, E. D. (2001) Ecologically meaningful transformations for ordination of species data. \emph{Oecologia}, \bold{129}, 271--280. Legendre, P. and Legendre, L. (1998) \emph{Numerical Ecology, 2nd English edition.} Amsterdam: Elsevier Science BV. Lingoes, J. C. (1971) Some boundary conditions for a monotone analysis of symmetric matrices. \emph{Psychometrika}, \bold{36}, 195--203. } \author{ Pierre Legendre, Universite de Montreal } \examples{ # Oribatid mite data from Borcard and Legendre (1994) \dontrun{ if (require(vegan)) { data(mite) # Community composition data, 70 peat cores, 35 species # Select rows 1:30. Species 35 is absent from these rows. Transform to log mite.log <- log(mite[1:30,-35]+1) # Equivalent: log1p(mite[1:30,-35]) # Principal coordinate analysis and simple ordination plot mite.D <- vegdist(mite.log, "bray") res <- pcoa(mite.D) res$values biplot(res) # Project unstandardized and standardized species on the PCoA ordination plot mite.log.st = apply(mite.log, 2, scale, center=TRUE, scale=TRUE) par(mfrow=c(1,2)) biplot(res, mite.log) biplot(res, mite.log.st) # Reverse the ordination axes in the plot par(mfrow=c(1,2)) biplot(res, mite.log, dir.axis1=-1, dir.axis2=-1) biplot(res, mite.log.st, dir.axis1=-1, dir.axis2=-1) } } } \keyword{ multivariate } ape/man/ape-internal.Rd0000644000176200001440000000116014164530562014444 0ustar liggesusers\name{ape-internal} \alias{perm.rowscols} \alias{phylogram.plot} \alias{cladogram.plot} \alias{circular.plot} \alias{unrooted.xy} \alias{BOTHlabels} \alias{floating.pie.asp} \alias{plotPhyloCoor} \alias{postprocess.prop.part} \alias{ONEwise} \alias{SHORTwise} \alias{reorderRcpp} \alias{polar2rect} \alias{rect2polar} \alias{node_depth} \alias{node_depth_edgelength} \alias{node_height} \alias{node_height_clado} \alias{seq_root2tip} \title{Internal Ape Functions} \description{ Internal \pkg{ape} functions which are undocumented but still exported because called by other packages. Use with care! } \keyword{internal} ape/man/compar.gee.Rd0000644000176200001440000001237514164530562014117 0ustar liggesusers\name{compar.gee} \alias{compar.gee} \alias{print.compar.gee} \alias{drop1.compar.gee} \alias{predict.compar.gee} \title{Comparative Analysis with GEEs} \description{ \code{compar.gee} performs the comparative analysis using generalized estimating equations as described by Paradis and Claude (2002). \code{drop1} tests single effects of a fitted model output from \code{compar.gee}. \code{predict} returns the predicted (fitted) values of the model. } \usage{ compar.gee(formula, data = NULL, family = "gaussian", phy, corStruct, scale.fix = FALSE, scale.value = 1) \method{drop1}{compar.gee}(object, scope, quiet = FALSE, ...) \method{predict}{compar.gee}(object, newdata = NULL, type = c("link", "response"), ...) } \arguments{ \item{formula}{a formula giving the model to be fitted.} \item{data}{the name of the data frame where the variables in \code{formula} are to be found; by default, the variables are looked for in the global environment.} \item{family}{a function specifying the distribution assumed for the response; by default a Gaussian distribution (with link identity) is assumed (see \code{?family} for details on specifying the distribution, and on changing the link function).} \item{phy}{an object of class \code{"phylo"} (ignored if \code{corStruct} is used).} \item{corStruct}{a (phylogenetic) correlation structure.} \item{scale.fix}{logical, indicates whether the scale parameter should be fixed (TRUE) or estimated (FALSE, the default).} \item{scale.value}{if \code{scale.fix = TRUE}, gives the value for the scale (default: \code{scale.value = 1}).} \item{object}{an object of class \code{"compar.gee"} resulting from fitting \code{compar.gee}.} \item{scope}{.} \item{quiet}{a logical specifying whether to display a warning message about eventual ``marginality principle violation''.} \item{newdata}{a data frame with column names matching the variables in the formula of the fitted object (see \code{\link[stats]{predict}} for details).} \item{type}{a character string specifying the type of predicted values. By default, the linear (link) prediction is returned.} \item{\dots}{further arguments to be passed to \code{drop1}.} } \details{ If a data frame is specified for the argument \code{data}, then its rownames are matched to the tip labels of \code{phy}. The user must be careful here since the function requires that both series of names perfectly match, so this operation may fail if there is a typing or syntax error. If both series of names do not match, the values in the data frame are taken to be in the same order than the tip labels of \code{phy}, and a warning message is issued. If \code{data = NULL}, then it is assumed that the variables are in the same order than the tip labels of \code{phy}. } \note{ The calculation of the phylogenetic degrees of freedom is likely to be approximative for non-Brownian correlation structures (this will be refined soon). The calculation of the quasilikelihood information criterion (QIC) needs to be tested. } \value{ \code{compar.gee} returns an object of class \code{"compar.gee"} with the following components: \item{call}{the function call, including the formula.} \item{effect.assign}{a vector of integers assigning the coefficients to the effects (used by \code{drop1}).} \item{nobs}{the number of observations.} \item{QIC}{the quasilikelihood information criterion as defined by Pan (2001).} \item{coefficients}{the estimated coefficients (or regression parameters).} \item{residuals}{the regression residuals.} \item{family}{a character string, the distribution assumed for the response.} \item{link}{a character string, the link function used for the mean function.} \item{scale}{the scale (or dispersion parameter).} \item{W}{the variance-covariance matrix of the estimated coefficients.} \item{dfP}{the phylogenetic degrees of freedom (see Paradis and Claude for details on this).} \code{drop1} returns an object of class \code{"\link[stats]{anova}"}. \code{predict} returns a vector or a data frame if \code{newdata} is used. } \references{ Pan, W. (2001) Akaike's information criterion in generalized estimating equations. \emph{Biometrics}, \bold{57}, 120--125. Paradis, E. and Claude J. (2002) Analysis of comparative data using generalized estimating equations. \emph{Journal of theoretical Biology}, \bold{218}, 175--185. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{pic}}, \code{\link{compar.lynch}}, \code{\link[stats]{drop1}} } \examples{ ### The example in Phylip 3.5c (originally from Lynch 1991) ### (the same analysis than in help(pic)...) tr <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);" tree.primates <- read.tree(text = tr) X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259) ### Both regressions... the results are quite close to those obtained ### with pic(). compar.gee(X ~ Y, phy = tree.primates) compar.gee(Y ~ X, phy = tree.primates) ### Now do the GEE regressions through the origin: the results are quite ### different! compar.gee(X ~ Y - 1, phy = tree.primates) compar.gee(Y ~ X - 1, phy = tree.primates) } \keyword{regression} ape/man/read.tree.Rd0000644000176200001440000001312314164530562013740 0ustar liggesusers\name{read.tree} \alias{read.tree} \alias{phylo} \title{Read Tree File in Parenthetic Format} \usage{ read.tree(file = "", text = NULL, tree.names = NULL, skip = 0, comment.char = "", keep.multi = FALSE, ...) } \arguments{ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string; if \code{file = ""} (the default) then the tree is input on the keyboard, the entry being terminated with a blank line.} \item{text}{alternatively, the name of a variable of mode character which contains the tree(s) in parenthetic format. By default, this is ignored (set to \code{NULL}, meaning that the tree is read in a file); if \code{text} is not \code{NULL}, then the argument \code{file} is ignored.} \item{tree.names}{if there are several trees to be read, a vector of mode character that gives names to the individual trees; if \code{NULL} (the default), the trees are named \code{"tree1"}, \code{"tree2"}, ...} \item{skip}{the number of lines of the input file to skip before beginning to read data (this is passed directly to\code{ scan()}).} \item{comment.char}{a single character, the remaining of the line after this character is ignored (this is passed directly to \code{scan()}).} \item{keep.multi}{if \code{TRUE} and \code{tree.names = NULL} then single trees are returned in \code{"multiPhylo"} format, with any name that is present (see details). Default is \code{FALSE}.} \item{\dots}{further arguments to be passed to \code{scan()}.} } \description{ This function reads a file which contains one or several trees in parenthetic format known as the Newick or New Hampshire format. } \details{ The default option for \code{file} allows to type directly the tree on the keyboard (or possibly to copy from an editor and paste in R's console) with, e.g., \code{mytree <- read.tree()}. `read.tree' tries to represent correctly trees with a badly represented root edge (i.e. with an extra pair of parentheses). For instance, the tree "((A:1,B:1):10);" will be read like "(A:1,B:1):10;" but a warning message will be issued in the former case as this is apparently not a valid Newick format. If there are two root edges (e.g., "(((A:1,B:1):10):10);"), then the tree is not read and an error message is issued. If there are any characters preceding the first "(" in a line then this is assigned to the name. This is returned when a "multiPhylo" object is returned and \code{tree.names = NULL}. Until \pkg{ape} 4.1, the default of \code{comment.char} was \code{"#"} (as in \code{scan}). This has been changed so that extended Newick files can be read. } \value{ an object of class \code{"phylo"} with the following components: \item{edge}{a two-column matrix of mode numeric where each row represents an edge of the tree; the nodes and the tips are symbolized with numbers; the tips are numbered 1, 2, \dots, and the nodes are numbered after the tips. For each row, the first column gives the ancestor.} \item{edge.length}{(optional) a numeric vector giving the lengths of the branches given by \code{edge}.} \item{tip.label}{a vector of mode character giving the names of the tips; the order of the names in this vector corresponds to the (positive) number in \code{edge}.} \item{Nnode}{the number of (internal) nodes.} \item{node.label}{(optional) a vector of mode character giving the names of the nodes.} \item{root.edge}{(optional) a numeric value giving the length of the branch at the root if it exists.} If several trees are read in the file, the returned object is of class \code{"multiPhylo"}, and is a list of objects of class \code{"phylo"}. The name of each tree can be specified by \code{tree.names}, or can be read from the file (see details). } \references{ Felsenstein, J. The Newick tree format. \url{http://evolution.genetics.washington.edu/phylip/newicktree.html} Olsen, G. Interpretation of the "Newick's 8:45" tree format standard. \url{http://evolution.genetics.washington.edu/phylip/newick_doc.html} Paradis, E. (2008) Definition of Formats for Coding Phylogenetic Trees in R. \url{http://ape-package.ird.fr/misc/FormatTreeR_24Oct2012.pdf} Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. } \author{Emmanuel Paradis and Daniel Lawson \email{dan.lawson@bristol.ac.uk}} \seealso{ \code{\link{write.tree}}, \code{\link{read.nexus}}, \code{\link{write.nexus}}, \code{\link[base]{scan}} for the basic R function to read data in a file } \examples{ ### An extract from Sibley and Ahlquist (1990) s <- "owls(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);" cat(s, file = "ex.tre", sep = "\n") tree.owls <- read.tree("ex.tre") str(tree.owls) tree.owls tree.owls <- read.tree("ex.tre", keep.multi = TRUE) tree.owls names(tree.owls) unlink("ex.tre") # delete the file "ex.tre" ### Only the first three species using the option `text' TREE <- "((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3);" TREE tree.owls.bis <- read.tree(text = TREE) str(tree.owls.bis) tree.owls.bis ## tree with singleton nodes: ts <- read.tree(text="((((a))),d);") plot(ts, node.depth = 2) # the default will overlap the singleton node with the tip nodelabels() ## skeleton tree with a singleton node: tx <- read.tree(text = "(((,)),);") plot(tx, node.depth = 2) nodelabels() ## a tree with single quoted labels (the 2nd label is not quoted): z <- "(('a: France, Spain (Europe)',b),'c: Australia [Outgroup]');" tz <- read.tree(text = z) plot(tz, font = 1) } \keyword{manip} \keyword{IO} ape/man/mcmc.popsize.Rd0000644000176200001440000001402114164530562014474 0ustar liggesusers\name{mcmc.popsize} \alias{mcmc.popsize} \alias{extract.popsize} \alias{plot.popsize} \alias{lines.popsize} \title{Reversible Jump MCMC to Infer Demographic History} \usage{ mcmc.popsize(tree,nstep, thinning=1, burn.in=0,progress.bar=TRUE, method.prior.changepoints=c("hierarchical", "fixed.lambda"), max.nodes=30, lambda=0.5, gamma.shape=0.5, gamma.scale=2, method.prior.heights=c("skyline", "constant", "custom"), prior.height.mean, prior.height.var) extract.popsize(mcmc.out, credible.interval=0.95, time.points=200, thinning=1, burn.in=0) \method{plot}{popsize}(x, show.median=TRUE, show.years=FALSE, subst.rate, present.year, xlab = NULL, ylab = "Effective population size", log = "y", ...) \method{lines}{popsize}(x, show.median=TRUE,show.years=FALSE, subst.rate, present.year, ...) } \arguments{ \item{tree}{Either an ultrametric tree (i.e. an object of class \code{"phylo"}), or coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}). } \item{nstep}{Number of MCMC steps, i.e. length of the Markov chain (suggested value: 10,000-50,000).} \item{thinning}{Thinning factor (suggest value: 10-100).} \item{burn.in}{Number of steps dropped from the chain to allow for a burn-in phase (suggest value: 1000).} \item{progress.bar}{Show progress bar during the MCMC run.} \item{method.prior.changepoints}{If \code{hierarchical}is chosen (the default) then the smoothing parameter lambda is drawn from a gamma distribution with some specified shape and scale parameters. Alternatively, for \code{fixed.lambda} the value of lambda is a given constant. } \item{max.nodes}{Upper limit for the number of internal nodes of the approximating spline (default: 30).} \item{lambda}{Smoothing parameter. For \code{method="fixed.lambda"} the specifed value of lambda determines the mean of the prior distribution for the number of internal nodes of the approximating spline for the demographic function (suggested value: 0.1-1.0).} \item{gamma.shape}{Shape parameter of the gamma function from which \code{lambda} is drawn for \code{method="hierarchical"}.} \item{gamma.scale}{Scale parameter of the gamma function from which \code{lambda} is drawn for \code{method="hierarchical"}.} \item{method.prior.heights}{Determines the prior for the heights of the change points. If \code{custom} is chosen then two functions describing the mean and variance of the heigths in depence of time have to be specified (via \code{prior.height.mean} and \code{prior.height.var} options). Alternatively, two built-in priors are available: \code{constant} assumes constant population size and variance determined by Felsenstein (1992), and \code{skyline} assumes a skyline plot (see Opgen-Rhein et al. 2004 for more details).} \item{prior.height.mean}{Function describing the mean of the prior distribution for the heights (only used if \code{method.prior.heights = custom}).} \item{prior.height.var}{Function describing the variance of the prior distribution for the heights (only used if \code{method.prior.heights = custom}).} \item{mcmc.out}{Output from \code{mcmc.popsize} - this is needed as input for \code{extract.popsize}.} \item{credible.interval}{Probability mass of the confidence band (default: 0.95).} \item{time.points}{Number of discrete time points in the table output by \code{extract.popsize}.} \item{x}{Table with population size versus time, as computed by \code{extract.popsize}. } \item{show.median}{Plot median rather than mean as point estimate for demographic function (default: TRUE).} \item{show.years}{Option that determines whether the time is plotted in units of of substitutions (default) or in years (requires specification of substution rate and year of present).} \item{subst.rate}{Substitution rate (see option show.years).} \item{present.year}{Present year (see option show.years).} \item{xlab}{label on the x-axis (depends on the value of \code{show.years}).} \item{ylab}{label on the y-axis.} \item{log}{log-transformation of axes; by default, the y-axis is log-transformed.} \item{\dots}{Further arguments to be passed on to \code{plot} or \code{lines}.} } \description{ These functions implement a reversible jump MCMC framework to infer the demographic history, as well as corresponding confidence bands, from a genealogical tree. The computed demographic history is a continous and smooth function in time. \code{mcmc.popsize} runs the actual MCMC chain and outputs information about the sampling steps, \code{extract.popsize} generates from this MCMC output a table of population size in time, and \code{plot.popsize} and \code{lines.popsize} provide utility functions to plot the corresponding demographic functions. } \details{ Please refer to Opgen-Rhein et al. (2005) for methodological details, and the help page of \code{\link{skyline}} for information on a related approach. } \author{ Rainer Opgen-Rhein and Korbinian Strimmer. Parts of the rjMCMC sampling procedure are adapted from \R code by Karl Broman. } \seealso{ \code{\link{skyline}} and \code{\link{skylineplot}}. } \references{ Opgen-Rhein, R., Fahrmeir, L. and Strimmer, K. 2005. Inference of demographic history from genealogical trees using reversible jump Markov chain Monte Carlo. \emph{BMC Evolutionary Biology}, \bold{5}, 6. } \examples{ # get tree data("hivtree.newick") # example tree in NH format tree.hiv <- read.tree(text = hivtree.newick) # load tree # run mcmc chain mcmc.out <- mcmc.popsize(tree.hiv, nstep=100, thinning=1, burn.in=0,progress.bar=FALSE) # toy run #mcmc.out <- mcmc.popsize(tree.hiv, nstep=10000, thinning=5, burn.in=500) # remove comments!! # make list of population size versus time popsize <- extract.popsize(mcmc.out) # plot and compare with skyline plot sk <- skyline(tree.hiv) plot(sk, lwd=1, lty=3, show.years=TRUE, subst.rate=0.0023, present.year = 1997) lines(popsize, show.years=TRUE, subst.rate=0.0023, present.year = 1997) } \keyword{manip} ape/man/print.phylo.Rd0000644000176200001440000000204214164530562014353 0ustar liggesusers\name{print.phylo} \alias{print.phylo} \alias{print.multiPhylo} \alias{str.multiPhylo} \title{Compact Display of a Phylogeny} \usage{ \method{print}{phylo}(x, printlen = 6 ,...) \method{print}{multiPhylo}(x, details = FALSE ,...) \method{str}{multiPhylo}(object, ...) } \arguments{ \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{object}{an object of class \code{"multiPhylo"}.} \item{printlen}{the number of labels to print (6 by default).} \item{details}{a logical indicating whether to print information on all trees.} \item{\dots}{further arguments passed to or from other methods.} } \description{ These functions prints a compact summary of a phylogeny, or a list of phylogenies, on the console. } \value{ NULL. } \author{Ben Bolker and Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{summary.phylo}}, \code{\link[base]{print}} for the generic \R function } \examples{ x <- rtree(10) print(x) print(x, printlen = 10) x <- rmtree(2, 10) print(x) print(x, TRUE) str(x) } \keyword{manip} ape/man/speciesTree.Rd0000644000176200001440000000335714164530562014352 0ustar liggesusers\name{speciesTree} \alias{speciesTree} \title{Species Tree Estimation} \description{ This function calculates the species tree from a set of gene trees. } \usage{ speciesTree(x, FUN = min) } \arguments{ \item{x}{a list of trees, e.g., an object of class \code{"multiPhylo"}.} \item{FUN}{a function used to compute the divergence times of each pair of tips.} } \details{ For all trees in \code{x}, the divergence time of each pair of tips is calculated: these are then `summarized' with \code{FUN} to build a new distance matrix used to calculate the species tree with a single-linkage hierarchical clustering. The default for \code{FUN} computes the maximum tree (maxtree) of Liu et al. (2010). Using \code{FUN = mean} gives the shallowest divergence tree of Maddison and Knowles (2006). } \value{ an object of class \code{"phylo"}. } \references{ Liu, L., Yu, L. and Pearl, D. K. (2010) Maximum tree: a consistent estimator of the species tree. \emph{Journal of Mathematical Biology}, \bold{60}, 95--106. Maddison, W. P. and Knowles, L. L. (2006) Inferring phylogeny despite incomplete lineage sorting. \emph{Systematic Biology}, \bold{55}, 21--30. } \author{Emmanuel Paradis} \examples{ ### example in Liu et al. (2010): tr1 <- read.tree(text = "(((B:0.05,C:0.05):0.01,D:0.06):0.04,A:0.1);") tr2 <- read.tree(text = "(((A:0.07,C:0.07):0.02,D:0.09):0.03,B:0.12);") TR <- c(tr1, tr2) TSmax <- speciesTree(TR) # MAXTREE TSsha <- speciesTree(TR, mean) # shallowest divergence kronoviz(c(tr1, tr2, TSmax, TSsha), horiz = FALSE, type = "c", cex = 1.5, font = 1) mtext(c("Gene tree 1", "Gene tree 2", "Species tree - MAXTREE"), at = -c(7.5, 4, 1)) mtext("Species tree - Shallowest Divergence") layout(1) } \keyword{models} ape/man/image.DNAbin.Rd0000644000176200001440000000631214164530562014245 0ustar liggesusers\name{image.DNAbin} \alias{image.DNAbin} \title{Plot of DNA Sequence Alignement} \description{ This function plots an image of an alignment of nucleotide sequences. } \usage{ \method{image}{DNAbin}(x, what, col, bg = "white", xlab = "", ylab = "", show.labels = TRUE, cex.lab = 1, legend = TRUE, grid = FALSE, show.bases = FALSE, base.cex = 1, base.font = 1, base.col = "black", ...) } \arguments{ \item{x}{a matrix of DNA sequences (class \code{"DNAbin"}).} \item{what}{a vector of characters specifying the bases to visualize. If missing, this is set to ``a'', ``g'', ``c'', ``t'', ``n'', and ``-'' (in this order).} \item{col}{a vector of colours. If missing, this is set to ``red'', ``yellow'', ``green'', ``blue'', ``grey'', and ``black''. If it is shorter (or longer) than \code{what}, it is recycled (or shortened).} \item{bg}{the colour used for nucleotides whose base is not among \code{what}.} \item{xlab}{the label for the \emph{x}-axis; none by default.} \item{ylab}{Idem for the \emph{y}-axis. Note that by default, the labels of the sequences are printed on the \emph{y}-axis (see next option).} \item{show.labels}{a logical controlling whether the sequence labels are printed (\code{TRUE} by default).} \item{cex.lab}{a single numeric controlling the size of the sequence labels. Use \code{cex.axis} to control the size of the annotations on the \emph{x}-axis.} \item{legend}{a logical controlling whether the legend is plotted (\code{TRUE} by default).} \item{grid}{a logical controlling whether to draw a grid (\code{FALSE} by default).} \item{show.bases}{a logical controlling whether to show the base symbols (\code{FALSE} by default).} \item{base.cex, base.font, base.col}{control the aspect of the base symbols (ignored if the previous is \code{FALSE}).} \item{\dots}{further arguments passed to \code{\link[graphics]{image.default}} (e.g., \code{xlab}, \code{cex.axis}).} } \details{ The idea of this function is to allow flexible plotting and colouring of a nucleotide alignment. By default, the most common bases (a, g, c, t, and n) and alignment gap are plotted using a standard colour scheme. It is possible to plot only one base specified as \code{what} with a chosen colour: this might be useful to check, for instance, the distribution of alignment gaps (\code{image(x, "-")}) or missing data (see examples). } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{del.gaps}}, \code{\link{alex}}, \code{\link{alview}}, \code{\link{all.equal.DNAbin}}, \code{\link{clustal}}, \code{\link[graphics]{grid}}, \code{\link{image.AAbin}} } \examples{ data(woodmouse) image(woodmouse) rug(seg.sites(woodmouse), -0.02, 3, 1) image(woodmouse, "n", "blue") # show missing data image(woodmouse, c("g", "c"), "green") # G+C par(mfcol = c(2, 2)) ### barcoding style: for (x in c("a", "g", "c", "t")) image(woodmouse, x, "black", cex.lab = 0.5, cex.axis = 0.7) par(mfcol = c(1, 1)) ### zoom on a portion of the data: image(woodmouse[11:15, 1:50], c("a", "n"), c("blue", "grey")) grid(50, 5, col = "black") ### see the guanines on a black background: image(woodmouse, "g", "yellow", "black") } \keyword{hplot} ape/man/multi2di.Rd0000644000176200001440000000363014164530562013622 0ustar liggesusers\name{multi2di} \alias{multi2di} \alias{multi2di.phylo} \alias{multi2di.multiPhylo} \alias{di2multi} \alias{di2multi.phylo} \alias{di2multi.multiPhylo} \title{Collapse and Resolve Multichotomies} \description{ These two functions collapse or resolve multichotomies in phylogenetic trees. } \usage{ multi2di(phy, ...) \method{multi2di}{phylo}(phy, random = TRUE, equiprob = TRUE, ...) \method{multi2di}{multiPhylo}(phy, random = TRUE, equiprob = TRUE, ...) di2multi(phy, ...) \method{di2multi}{phylo}(phy, tol = 1e-08, ...) \method{di2multi}{multiPhylo}(phy, tol = 1e-08, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{random}{a logical value specifying whether to resolve the multichotomies randomly (the default) or in the order they appear in the tree (if \code{random = FALSE}).} \item{equiprob}{a logical value: should topologies generated in equal probabilities; see details in \code{\link{rtree}} (ignored if \code{random = FALSE}).} \item{tol}{a numeric value giving the tolerance to consider a branch length significantly greater than zero.} \item{\dots}{arguments passed among methods.} } \details{ \code{multi2di} transforms all multichotomies into a series of dichotomies with one (or several) branch(es) of length zero. \code{di2multi} deletes all branches smaller than \code{tol} and collapses the corresponding dichotomies into a multichotomy. } \seealso{\code{\link{is.binary}}} \author{Emmanuel Paradis} \value{ an object of the same class than the input. } \examples{ data(bird.families) is.binary(bird.families) is.binary(multi2di(bird.families)) all.equal(di2multi(multi2di(bird.families)), bird.families) ### To see the results of randomly resolving a trichotomy: tr <- read.tree(text = "(a:1,b:1,c:1);") layout(matrix(1:4, 2, 2)) for (i in 1:4) plot(multi2di(tr), use.edge.length = FALSE, cex = 1.5) layout(1) } \keyword{manip} ape/man/axisPhylo.Rd0000644000176200001440000000246614164530562014057 0ustar liggesusers\name{axisPhylo} \alias{axisPhylo} \title{Axis on Side of Phylogeny} \usage{ axisPhylo(side = 1, root.time = NULL, backward = TRUE, ...) } \arguments{ \item{side}{a numeric value specifying the side where the axis is plotted: 1: below, 2: left, 3: above, 4: right.} \item{root.time}{the time assigned to the root node of the tree. By default, this is taken from the \code{root.time} element of the tree. If it is absent, this is determined from the next option.} \item{backward}{a logical value; if TRUE, the most distant tip from the root is considered as the origin of the time scale; if FALSE, this is the root node.} \item{\dots}{further arguments to be passed to \code{axis}.} } \description{ This function adds a scaled axis on the side of a phylogeny plot. } \details{ The further arguments (\code{...}) are used to format the axis. They may be \code{font}, \code{cex}, \code{col}, \code{las}, and so on (see the help pages on \code{\link[graphics]{axis}} and \code{\link[graphics]{par}}). } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{add.scale.bar}}, \code{\link[graphics]{axis}}, \code{\link[graphics]{par}} } \examples{ tr <- rtree(30) ch <- rcoal(30) plot(ch) axisPhylo() plot(tr, "c", FALSE, direction = "u") axisPhylo(2, las = 1) } \keyword{aplot} ape/man/rlineage.Rd0000644000176200001440000001050414164530562013655 0ustar liggesusers\name{rlineage} \alias{rlineage} \alias{rbdtree} \alias{rphylo} \alias{drop.fossil} \title{Tree Simulation Under the Time-Dependent Birth--Death Models} \description{ These three functions simulate phylogenies under any time-dependent birth--death model: \code{rlineage} generates a complete tree including the species going extinct before present; \code{rbdtree} generates a tree with only the species living at present (thus the tree is ultrametric); \code{rphylo} generates a tree with a fixed number of species at present time. \code{drop.fossil} is a utility function to remove the extinct species. } \usage{ rlineage(birth, death, Tmax = 50, BIRTH = NULL, DEATH = NULL, eps = 1e-6) rbdtree(birth, death, Tmax = 50, BIRTH = NULL, DEATH = NULL, eps = 1e-6) rphylo(n, birth, death, BIRTH = NULL, DEATH = NULL, T0 = 50, fossils = FALSE, eps = 1e-06) drop.fossil(phy, tol = 1e-8) } \arguments{ \item{birth, death}{a numeric value or a (vectorized) function specifying how speciation and extinction rates vary through time.} \item{Tmax}{a numeric value giving the length of the simulation.} \item{BIRTH, DEATH}{a (vectorized) function which is the primitive of \code{birth} or \code{death}. This can be used to speed-up the computation. By default, a numerical integration is done.} \item{eps}{a numeric value giving the time resolution of the simulation; this may be increased (e.g., 0.001) to shorten computation times.} \item{n}{the number of species living at present time.} \item{T0}{the time at present (for the backward-in-time algorithm).} \item{fossils}{a logical value specifying whether to output the lineages going extinct.} \item{phy}{an object of class \code{"phylo"}.} \item{tol}{a numeric value giving the tolerance to consider a species as extinct.} } \details{ These three functions use continuous-time algorithms: \code{rlineage} and \code{rbdtree} use the forward-in-time algorithms described in Paradis (2011), whereas \code{rphylo} uses a backward-in-time algorithm from Stadler (2011). The models are time-dependent birth--death models as described in Kendall (1948). Speciation (birth) and extinction (death) rates may be constant or vary through time according to an \R function specified by the user. In the latter case, \code{BIRTH} and/or \code{DEATH} may be used if the primitives of \code{birth} and \code{death} are known. In these functions time is the formal argument and must be named \code{t}. Note that \code{rphylo} simulates trees in a way similar to what the package \pkg{TreeSim} does, the difference is in the parameterization of the time-dependent models which is here the same than used in the two other functions. In this parameterization scheme, time is measured from past to present (see details in Paradis 2015 which includes a comparison of these algorithms). The difference between \code{rphylo} and \code{rphylo(... fossils = TRUE)} is the same than between \code{rbdtree} and \code{rlineage}. } \value{ An object of class \code{"phylo"}. } \references{ Kendall, D. G. (1948) On the generalized ``birth-and-death'' process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15. Paradis, E. (2011) Time-dependent speciation and extinction from phylogenies: a least squares approach. \emph{Evolution}, \bold{65}, 661--672. Paradis, E. (2015) Random phylogenies and the distribution of branching times. \emph{Journal of Theoretical Biology}, \bold{387}, 39--45. Stadler, T. (2011) Simulating trees with a fixed number of extant species. \emph{Systematic Biology}, \bold{60}, 676--684. } \author{Emmanuel Paradis} \seealso{ \code{\link{yule}}, \code{\link{yule.time}}, \code{\link{birthdeath}}, \code{\link{rtree}}, \code{\link{stree}} } \examples{ set.seed(10) plot(rlineage(0.1, 0)) # Yule process with lambda = 0.1 plot(rlineage(0.1, 0.05)) # simple birth-death process b <- function(t) 1/(1 + exp(0.2*t - 1)) # logistic layout(matrix(0:3, 2, byrow = TRUE)) curve(b, 0, 50, xlab = "Time", ylab = "") mu <- 0.07 segments(0, mu, 50, mu, lty = 2) legend("topright", c(expression(lambda), expression(mu)), lty = 1:2, bty = "n") plot(rlineage(b, mu), show.tip.label = FALSE) title("Simulated with 'rlineage'") plot(rbdtree(b, mu), show.tip.label = FALSE) title("Simulated with 'rbdtree'") } \keyword{datagen} ape/man/howmanytrees.Rd0000644000176200001440000000600214164530562014612 0ustar liggesusers\name{howmanytrees} \alias{howmanytrees} \alias{LargeNumber} \alias{print.LargeNumber} \title{Calculate Numbers of Phylogenetic Trees} \description{ \code{howmanytrees} calculates the number of possible phylogenetic trees for a given number of tips. \code{LargeNumber} is a utility function to compute (approximately) large numbers from the power \eqn{a^b}. } \usage{ howmanytrees(n, rooted = TRUE, binary = TRUE, labeled = TRUE, detail = FALSE) LargeNumber(a, b) \method{print}{LargeNumber}(x, ...) } \arguments{ \item{n}{a positive numeric integer giving the number of tips.} \item{rooted}{a logical indicating whether the trees are rooted (default is \code{TRUE}).} \item{binary}{a logical indicating whether the trees are bifurcating (default is \code{TRUE}).} \item{labeled}{a logical indicating whether the trees have tips labeled (default is \code{TRUE}).} \item{detail}{a logical indicating whether the eventual intermediate calculations should be returned (default is \code{FALSE}). This applies only for the multifurcating trees, and the bifurcating, rooted, unlabeled trees (aka tree shapes).} \item{a, b}{two numbers.} \item{x}{an object of class \code{"LargeNumber"}.} \item{\dots}{(unused).} } \details{ In the cases of labeled binary trees, the calculation is done directly and a single numeric value is returned (or an object of class \code{"LargeNumber"}). For multifurcating trees, and bifurcating, rooted, unlabeled trees, the calculation is done iteratively for 1 to \code{n} tips. Thus the user can print all the intermediate values if \code{detail = TRUE}, or only a single value if \code{detail = FALSE} (the default). For multifurcating trees, if \code{detail = TRUE}, a matrix is returned with the number of tips as rows (named from \code{1} to \code{n}), and the number of nodes as columns (named from \code{1} to \code{n - 1}). For bifurcating, rooted, unlabeled trees, a vector is returned with names equal to the number of tips (from \code{1} to \code{n}). The number of unlabeled trees (aka tree shapes) can be computed only for the rooted binary cases. Note that if an infinite value (\code{Inf}) is returned this does not mean that there is an infinite number of trees (this cannot be if the number of tips is finite), but that the calculation is beyond the limits of the computer. Only for the cases of rooted, binary, labeled topologies an approximate number is returned in the form a \code{"LargeNumber"} object. } \value{ a single numeric value, an object of class \code{"LargeNumber"}, or in the case where \code{detail = TRUE} is used, a named vector or matrix. } \references{ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sunderland: Sinauer Associates. } \author{Emmanuel Paradis} \examples{ ### Table 3.1 in Felsenstein 2004: for (i in c(1:20, 30, 40, 50)) cat(paste(i, howmanytrees(i), sep = "\t"), sep ="\n") ### Table 3.6: howmanytrees(8, binary = FALSE, detail = TRUE) } \keyword{arith} \keyword{math} ape/man/trans.Rd0000644000176200001440000000355514164530562013226 0ustar liggesusers\name{trans} \alias{trans} \alias{complement} \title{Translation from DNA to Amino Acid Sequences} \description{ \code{trans} translates DNA sequences into amino acids. \code{complement} returns the (reverse) complement sequences. } \usage{ trans(x, code = 1, codonstart = 1) complement(x) } \arguments{ \item{x}{an object of class \code{"DNAbin"} (vector, matrix or list).} \item{code}{an integer value giving the genetic code to be used. Currently only the genetic codes 1 to 6 are supported.} \item{codonstart}{an integer giving where to start the translation. This should be 1, 2, or 3, but larger values are accepted and have for effect to start the translation further towards the 3'-end of the sequence.} } \details{ With \code{trans}, if the sequence length is not a multiple of three, a warning message is printed. Alignment gaps are simply ignored (i.e., \code{AG-} returns \code{X} with no special warning or message). Base ambiguities are taken into account where relevant: for instance, \code{GGN}, \code{GGA}, \code{GGR}, etc, all return \code{G}. See the link given in the References for details about the taxonomic coverage and alternative codons of each code. } \value{ an object of class \code{"AAbin"} or \code{"DNAbin"}, respectively. } \note{ These functions are equivalent to \code{translate} and \code{comp} in the package \pkg{seqinr} with the difference that there is no need to convert the sequences into character strings. } \references{ \url{https://www.ncbi.nlm.nih.gov/Taxonomy/taxonomyhome.html/index.cgi?chapter=cgencodes} } \author{Emmanuel Paradis} \seealso{ \code{\link{AAbin}}, \code{\link{checkAlignment}}, \code{\link{alview}} } \examples{ data(woodmouse) X <- trans(woodmouse) # not correct X2 <- trans(woodmouse, 2) # using the correct code identical(X, X2) alview(X[1:2, 1:60]) # some 'Stop' codons (*) alview(X2[, 1:60]) X2 }ape/man/mst.Rd0000644000176200001440000000566314164530562012704 0ustar liggesusers\name{mst} \alias{mst} \alias{plot.mst} \title{Minimum Spanning Tree} \usage{ mst(X) \method{plot}{mst}(x, graph = "circle", x1 = NULL, x2 = NULL, \dots) } \arguments{ \item{X}{either a matrix that can be interpreted as a distance matrix, or an object of class \code{"dist"}.} \item{x}{an object of class \code{"mst"} (e.g. returned by \code{mst()}).} \item{graph}{a character string indicating the type of graph to plot the minimum spanning tree; two choices are possible: \code{"circle"} where the observations are plotted regularly spaced on a circle, and \code{"nsca"} where the two first axes of a non-symmetric correspondence analysis are used to plot the observations (see Details below). If both arguments \code{x1} and \code{x2} are given, the argument \code{graph} is ignored.} \item{x1}{a numeric vector giving the coordinates of the observations on the \emph{x}-axis. Both \code{x1} and \code{x2} must be specified to be used.} \item{x2}{a numeric vector giving the coordinates of the observations on the \emph{y}-axis. Both \code{x1} and \code{x2} must be specified to be used.} \item{\dots}{further arguments to be passed to \code{plot()}.} } \description{ The function \code{mst} finds the minimum spanning tree between a set of observations using a matrix of pairwise distances. The \code{plot} method plots the minimum spanning tree showing the links where the observations are identified by their numbers. } \details{ These functions provide two ways to plot the minimum spanning tree which try to space as much as possible the observations in order to show as clearly as possible the links. The option \code{graph = "circle"} simply plots regularly the observations on a circle, whereas \code{graph = "nsca"} uses a non-symmetric correspondence analysis where each observation is represented at the centroid of its neighbours. Alternatively, the user may use any system of coordinates for the obsevations, for instance a principal components analysis (PCA) if the distances were computed from an original matrix of continous variables. } \value{ an object of class \code{"mst"} which is a square numeric matrix of size equal to the number of observations with either \code{1} if a link between the corresponding observations was found, or \code{0} otherwise. The names of the rows and columns of the distance matrix, if available, are given as rownames and colnames to the returned object. } \author{ Yvonnick Noel \email{noel@univ-lille3.fr}, Julien Claude \email{julien.claude@umontpellier.fr} and Emmanuel Paradis } \seealso{ \code{\link{dist.dna}}, \code{\link{dist.gene}}, \code{\link[stats]{dist}}, \code{\link[graphics]{plot}} } \examples{ require(stats) X <- matrix(runif(200), 20, 10) d <- dist(X) PC <- prcomp(X) M <- mst(d) opar <- par(mfcol = c(2, 2)) plot(M) plot(M, graph = "nsca") plot(M, x1 = PC$x[, 1], x2 = PC$x[, 2]) par(opar) } \keyword{multivariate} ape/man/write.tree.Rd0000644000176200001440000000500614164530562014160 0ustar liggesusers\name{write.tree} \alias{write.tree} \title{Write Tree File in Parenthetic Format} \usage{ write.tree(phy, file = "", append = FALSE, digits = 10, tree.names = FALSE) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{file}{a file name specified by either a variable of mode character, or a double-quoted string; if \code{file = ""} (the default) then the tree is written on the standard output connection (i.e. the console).} \item{append}{a logical, if \code{TRUE} the tree is appended to the file without erasing the data possibly existing in the file, otherwise the file (if it exists) is overwritten (\code{FALSE} the default).} \item{digits}{a numeric giving the number of digits used for printing branch lengths.} \item{tree.names}{either a logical or a vector of mode character. If \code{TRUE} then any tree names will be written prior to the tree on each line. If character, specifies the name of \code{"phylo"} objects which can be written to the file.} } \description{ This function writes in a file a tree in parenthetic format using the Newick (also known as New Hampshire) format. } \value{ a vector of mode character if \code{file = ""}, none (invisible \code{NULL}) otherwise. } \details{ The node labels and the root edge length, if available, are written in the file. If \code{tree.names == TRUE} then a variant of the Newick format is written for which the name of a tree precedes the Newick format tree (parentheses are eventually deleted beforehand). The tree names are taken from the \code{names} attribute if present (they are ignored if \code{tree.names} is a character vector). The tip labels (and the node labels if present) are checked before being printed: the leading and trailing spaces, and the leading left and trailing right parentheses are deleted; the other spaces are replaced by underscores; the commas, colons, semicolons, and the other parentheses are replaced with dashes. } \references{ Felsenstein, J. The Newick tree format. \url{http://evolution.genetics.washington.edu/phylip/newicktree.html} Olsen, G. Interpretation of the "Newick's 8:45" tree format standard. \url{http://evolution.genetics.washington.edu/phylip/newick_doc.html} } \author{Emmanuel Paradis, Daniel Lawson \email{dan.lawson@bristol.ac.uk}, and Klaus Schliep \email{kschliep@snv.jussieu.fr}} \seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}}, \code{\link{write.nexus}} } \keyword{manip} \keyword{IO}ape/man/mcconwaysims.test.Rd0000644000176200001440000000402614164530562015563 0ustar liggesusers\name{mcconwaysims.test} \alias{mcconwaysims.test} \title{McConway-Sims Test of Homogeneous Diversification} \description{ This function performs the McConway--Sims test that a trait or variable does not affect diversification rate. } \usage{ mcconwaysims.test(x) } \arguments{ \item{x}{a matrix or a data frame with at least two columns: the first one gives the number of species in clades with a trait supposed to increase or decrease diversification rate, and the second one the number of species in the sister-clades without the trait. Each row represents a pair of sister-clades.} } \details{ The McConway--Sims test compares a series of sister-clades where one of the two is characterized by a trait supposed to affect diversification rate. The null hypothesis is that the trait does not affect diversification. The alternative hypothesis is that diversification rate is increased or decreased by the trait (by contrast to the Slowinski--Guyer test). The test is a likelihood-ratio of a null Yule model and an alternative model with two parameters. } \value{ a data frame with the \eqn{\chi^2}{chi2}, the number of degrees of freedom, and the \emph{P}-value. } \references{ McConway, K. J. and Sims, H. J. (2004) A likelihood-based method for testing for nonstochastic variation of diversification rates in phylogenies. \emph{Evolution}, \bold{58}, 12--23. Paradis, E. (2012) Shift in diversification in sister-clade comparisons: a more powerful test. \emph{Evolution}, \bold{66}, 288--295. } \author{Emmanuel Paradis} \seealso{ \code{\link{balance}}, \code{\link{slowinskiguyer.test}}, \code{rc} in \pkg{geiger}, \code{shift.test} in \pkg{apTreeshape} } \examples{ ### simulate 10 clades with lambda = 0.1 and mu = 0.09: n0 <- replicate(10, balance(rbdtree(.1, .09, Tmax = 35))[1]) ### simulate 10 clades with lambda = 0.15 and mu = 0.1: n1 <- replicate(10, balance(rbdtree(.15, .1, Tmax = 35))[1]) x <- cbind(n1, n0) mcconwaysims.test(x) slowinskiguyer.test(x) richness.yule.test(x, 35) } \keyword{htest} ape/man/diversi.time.Rd0000644000176200001440000000520214164530562014470 0ustar liggesusers\name{diversi.time} \alias{diversi.time} \title{Analysis of Diversification with Survival Models} \usage{ diversi.time(x, census = NULL, censoring.codes = c(1, 0), Tc = NULL) } \arguments{ \item{x}{a numeric vector with the branching times.} \item{census}{a vector of the same length than `x' used as an indicator variable; thus, it must have only two values, one coding for accurately known branching times, and the other for censored branching times. This argument can be of any mode (numeric, character, logical), or can even be a factor.} \item{censoring.codes}{a vector of length two giving the codes used for \code{census}: by default 1 (accurately known times) and 0 (censored times). The mode must be the same than the one of \code{census}.} \item{Tc}{a single numeric value specifying the break-point time to fit Model C. If none is provided, then it is set arbitrarily to the mean of the analysed branching times.} } \description{ This functions fits survival models to a set of branching times, some of them may be known approximately (censored). Three models are fitted, Model A assuming constant diversification, Model B assuming that diversification follows a Weibull law, and Model C assuming that diversification changes with a breakpoint at time `Tc'. The models are fitted by maximum likelihood. } \details{ The principle of the method is to consider each branching time as an event: if the branching time is accurately known, then it is a failure event; if it is approximately knwon then it is a censoring event. An analogy is thus made between the failure (or hazard) rate estimated by the survival models and the diversification rate of the lineage. Time is here considered from present to past. Model B assumes a monotonically changing diversification rate. The parameter that controls the change of this rate is called beta. If beta is greater than one, then the diversification rate decreases through time; if it is lesser than one, the the rate increases through time. If beta is equal to one, then Model B reduces to Model A. } \value{ A NULL value is returned, the results are simply printed. } \references{ Paradis, E. (1997) Assessing temporal variations in diversification rates from phylogenies: estimation and hypothesis testing. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{264}, 1141--1147. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.gof}} \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule}}, \code{\link{yule.cov}} } \keyword{models} ape/man/pic.ortho.Rd0000644000176200001440000000416614164530562014003 0ustar liggesusers\name{pic.ortho} \alias{pic.ortho} \title{Phylogenetically Independent Orthonormal Contrasts} \description{ This function computes the orthonormal contrasts using the method described by Felsenstein (2008). Only a single trait can be analyzed; there can be several observations per species. } \usage{ pic.ortho(x, phy, var.contrasts = FALSE, intra = FALSE) } \arguments{ \item{x}{a numeric vector or a list of numeric vectors.} \item{phy}{an object of class \code{"phylo"}.} \item{var.contrasts}{logical, indicates whether the expected variances of the contrasts should be returned (default to \code{FALSE}).} \item{intra}{logical, whether to return the intraspecific contrasts.} } \details{ The data \code{x} can be in two forms: a vector if there is a single observation for each species, or a list whose elements are vectors containing the individual observations for each species. These vectors may be of different lengths. If \code{x} has names, its values are matched to the tip labels of \code{phy}, otherwise its values are taken to be in the same order than the tip labels of \code{phy}. } \value{ either a vector of contrasts, or a two-column matrix with the contrasts in the first column and their expected variances in the second column (if \code{var.contrasts = TRUE}). If the tree has node labels, these are used as labels of the returned object. If \code{intra = TRUE}, the attribute \code{"intra"}, a list of vectors with the intraspecific contrasts or \code{NULL} for the species with a one observation, is attached to the returned object. } \references{ Felsenstein, J. (2008) Comparative methods with sampling error and within-species variation: Contrasts revisited and revised. \emph{American Naturalist}, \bold{171}, 713--725. } \author{Emmanuel Paradis} \seealso{ \code{\link{pic}}, \code{\link{varCompPhylip}} } \examples{ tr <- rcoal(30) ### a single observation per species: x <- rTraitCont(tr) pic.ortho(x, tr) pic.ortho(x, tr, TRUE) ### different number of observations per species: x <- lapply(sample(1:5, 30, TRUE), rnorm) pic.ortho(x, tr, intra = TRUE) } \keyword{regression} ape/man/read.dna.Rd0000644000176200001440000002056114164530562013547 0ustar liggesusers\name{read.dna} \alias{read.dna} \alias{read.FASTA} \alias{read.fastq} \title{Read DNA Sequences in a File} \description{ These functions read DNA sequences in a file, and returns a matrix or a list of DNA sequences with the names of the taxa read in the file as rownames or names, respectively. By default, the sequences are returned in binary format, otherwise (if \code{as.character = TRUE}) in lowercase. } \usage{ read.dna(file, format = "interleaved", skip = 0, nlines = 0, comment.char = "#", as.character = FALSE, as.matrix = NULL) read.FASTA(file, type = "DNA") read.fastq(file, offset = -33) } \arguments{ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string. Can also be a \link{connection} (which will be opened for reading if necessary, and if so \code{\link{close}}d (and hence destroyed) at the end of the function call). Files compressed with GZIP can be read (providing the name ends with .gz), as well as remote files.} \item{format}{a character string specifying the format of the DNA sequences. Four choices are possible: \code{"interleaved"}, \code{"sequential"}, \code{"clustal"}, or \code{"fasta"}, or any unambiguous abbreviation of these.} \item{skip}{the number of lines of the input file to skip before beginning to read data (ignored for FASTA files; see below).} \item{nlines}{the number of lines to be read (by default the file is read untill its end; ignored for FASTA files)).} \item{comment.char}{a single character, the remaining of the line after this character is ignored (ignored for FASTA files).} \item{as.character}{a logical controlling whether to return the sequences as an object of class \code{"DNAbin"} (the default).} \item{as.matrix}{(used if \code{format = "fasta"}) one of the three followings: (i) \code{NULL}: returns the sequences in a matrix if they are of the same length, otherwise in a list; (ii) \code{TRUE}: returns the sequences in a matrix, or stops with an error if they are of different lengths; (iii) \code{FALSE}: always returns the sequences in a list.} \item{type}{a character string giving the type of the sequences: one of \code{"DNA"} or \code{"AA"} (case-independent, can be abbreviated).} \item{offset}{the value to be added to the quality scores (the default applies to the Sanger format and should work for most recent FASTQ files).} } \details{ \code{read.dna} follows the interleaved and sequential formats defined in PHYLIP (Felsenstein, 1993) but with the original feature than there is no restriction on the lengths of the taxa names. For these two formats, the first line of the file must contain the dimensions of the data (the numbers of taxa and the numbers of nucleotides); the sequences are considered as aligned and thus must be of the same lengths for all taxa. For the FASTA and FASTQ formats, the conventions defined in the references are followed; the sequences are taken as non-aligned. For all formats, the nucleotides can be arranged in any way with blanks and line-breaks inside (with the restriction that the first ten nucleotides must be contiguous for the interleaved and sequential formats, see below). The names of the sequences are read in the file. Particularities for each format are detailed below. \itemize{ \item{Interleaved:}{the function starts to read the sequences after it finds one or more spaces (or tabulations). All characters before the sequences are taken as the taxa names after removing the leading and trailing spaces (so spaces in taxa names are not allowed). It is assumed that the taxa names are not repeated in the subsequent blocks of nucleotides.} \item{Sequential:}{the same criterion than for the interleaved format is used to start reading the sequences and the taxa names; the sequences are then read until the number of nucleotides specified in the first line of the file is reached. This is repeated for each taxa.} \item{Clustal:}{this is the format output by the Clustal programs (.aln). It is close to the interleaved format: the differences are that the dimensions of the data are not indicated in the file, and the names of the sequences are repeated in each block.} \item{FASTA:}{This looks like the sequential format but the taxa names (or a description of the sequence) are on separate lines beginning with a `greater than' character `>' (there may be leading spaces before this character). These lines are taken as taxa names after removing the `>' and the possible leading and trailing spaces. All the data in the file before the first sequence are ignored.} } The FASTQ format is explained in the references. Compressed files must be read through connections (see examples). \code{read.fastq} can read compressed files directly (see examples). } \value{ a matrix or a list (if \code{format = "fasta"}) of DNA sequences stored in binary format, or of mode character (if \code{as.character = "TRUE"}). \code{read.FASTA} always returns a list of class \code{"DNAbin"} or \code{"AAbin"}. \code{read.fastq} returns a list of class \code{"DNAbin"} with an atrribute \code{"QUAL"} (see examples). } \references{ Anonymous. FASTA format. \url{https://en.wikipedia.org/wiki/FASTA_format} Anonymous. FASTQ format. \url{https://en.wikipedia.org/wiki/FASTQ_format} Felsenstein, J. (1993) Phylip (Phylogeny Inference Package) version 3.5c. Department of Genetics, University of Washington. \url{http://evolution.genetics.washington.edu/phylip/phylip.html} } \seealso{ \code{\link{read.GenBank}}, \code{\link{write.dna}}, \code{\link{DNAbin}}, \code{\link{dist.dna}}, \code{\link{woodmouse}} } \author{Emmanuel Paradis and RJ Ewing} \examples{ ## a small extract from data(woodmouse) in sequential format: cat("3 40", "No305 NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT", "No304 ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT", "No306 ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT", file = "exdna.txt", sep = "\n") ex.dna <- read.dna("exdna.txt", format = "sequential") str(ex.dna) ex.dna ## the same data in interleaved format... cat("3 40", "No305 NTTCGAAAAA CACACCCACT", "No304 ATTCGAAAAA CACACCCACT", "No306 ATTCGAAAAA CACACCCACT", " ACTAAAANTT ATCAGTCACT", " ACTAAAAATT ATCAACCACT", " ACTAAAAATT ATCAATCACT", file = "exdna.txt", sep = "\n") ex.dna2 <- read.dna("exdna.txt") ## ... in clustal format... cat("CLUSTAL (ape) multiple sequence alignment", "", "No305 NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT", "No304 ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT", "No306 ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT", " ************************** ****** ****", file = "exdna.txt", sep = "\n") ex.dna3 <- read.dna("exdna.txt", format = "clustal") ## ... and in FASTA format cat(">No305", "NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT", ">No304", "ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT", ">No306", "ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT", file = "exdna.fas", sep = "\n") ex.dna4 <- read.dna("exdna.fas", format = "fasta") ## They are the same: identical(ex.dna, ex.dna2) identical(ex.dna, ex.dna3) identical(ex.dna, ex.dna4) ## How to read compressed files: ## create the ZIP file: zip("exdna.fas.zip", "exdna.fas") ## create the GZ file with a connection: con <- gzfile("exdna.fas.gz", "wt") cat(">No305", "NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT", ">No304", "ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT", ">No306", "ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT", file = con, sep = "\n") close(con) ex.dna5 <- read.dna(unz("exdna.fas.zip", "exdna.fas"), "fasta") ex.dna6 <- read.dna(gzfile("exdna.fas.gz"), "fasta") identical(ex.dna5, ex.dna4) identical(ex.dna6, ex.dna4) unlink("exdna.txt") unlink("exdna.fas") unlink("exdna.fas.zip") unlink("exdna.fas.gz") ## read a FASTQ file from 1000 Genomes: \dontrun{ a <- "https://ftp.1000genomes.ebi.ac.uk/vol1/ftp/phase3/data/HG00096/sequence_read/" b <- "SRR062641.filt.fastq.gz" URL <- paste0(a, b) download.file(URL, b) ## If the above command doesn't work, you may copy/paste URL in ## a Web browser instead. X <- read.fastq(b) X # 109,811 sequences ## get the qualities of the first sequence: (qual1 <- attr(X, "QUAL")[[1]]) ## the corresponding probabilities: 10^(-qual1/10) ## get the mean quality for each sequence: mean.qual <- sapply(attr(X, "Q"), mean) ## can do the same for var, sd, ... }} \keyword{IO} ape/man/collapse.singles.Rd0000644000176200001440000000270414164530562015337 0ustar liggesusers\name{collapse.singles} \alias{collapse.singles} \alias{has.singles} \title{Collapse Single Nodes} \description{ \code{collapse.singles} deletes the single nodes (i.e., with a single descendant) in a tree. \code{has.singles} tests for the presence of single node(s) in a tree. } \usage{ collapse.singles(tree, root.edge = FALSE) has.singles(tree) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{root.edge}{whether to get the singleton edges from the root until the first bifurcating node and put them as \code{root.edge} of the returned tree. By default, this is ignored or if the tree has no edge lengths (see examples).} } \value{ an object of class \code{"phylo"}. } \author{Emmanuel Paradis, Klaus Schliep} \seealso{ \code{\link{plot.phylo}}, \code{\link{read.tree}} } \examples{ ## a tree with 3 tips and 3 nodes: e <- c(4L, 6L, 6L, 5L, 5L, 6L, 1L, 5L, 3L, 2L) dim(e) <- c(5, 2) tr <- structure(list(edge = e, tip.label = LETTERS[1:3], Nnode = 3L), class = "phylo") tr has.singles(tr) ## the following shows that node #4 (ie, the root) is a singleton ## and node #6 is the first bifurcating node tr$edge ## A bifurcating tree has less nodes than it has tips: ## the following used to fail with ape 4.1 or lower: plot(tr) collapse.singles(tr) # only 2 nodes ## give branch lengths to use the 'root.edge' option: tr$edge.length <- runif(5) str(collapse.singles(tr, TRUE)) # has a 'root.edge' } \keyword{manip} ape/man/identify.phylo.Rd0000644000176200001440000000410614164530562015035 0ustar liggesusers\name{identify.phylo} \alias{identify.phylo} \title{Graphical Identification of Nodes and Tips} \usage{ \method{identify}{phylo}(x, nodes = TRUE, tips = FALSE, labels = FALSE, quiet = FALSE, ...) } \arguments{ \item{x}{an object of class \code{"phylo"}.} \item{nodes}{a logical specifying whether to identify the node.} \item{tips}{a logical specifying whether to return the tip information.} \item{labels}{a logical specifying whether to return the labels; by default only the numbers are returned.} \item{quiet}{a logical controlling whether to print a message inviting the user to click on the tree.} \item{\dots}{further arguments to be passed to or from other methods.} } \description{ This function allows to identify a clade on a plotted tree by clicking on the plot with the mouse. The tree, specified in the argument \code{x}, must be plotted beforehand. } \details{ By default, the clade is identified by its number as found in the `edge' matrix of the tree. If \code{tips = TRUE}, the tips descending from the identified node are returned, possibly together with the node. If \code{labels = TRUE}, the labels are returned (if the tree has no node labels, then the node numbered is returned). The node is identified by the shortest distance where the click occurs. If the click occurs close to a tip, the function returns its information. } \note{ This function does not add anything on the plot, but it can be wrapped with, e.g., \code{\link{nodelabels}} (see example), or its results can be sent to, e.g., \code{\link{drop.tip}}. } \value{ A list with one or two vectors named \code{"tips"} and/or \code{"nodes"} with the identification of the tips and/or of the nodes. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{nodelabels}}, \code{\link[graphics]{identify}} for the generic function } \examples{ \dontrun{ tr <- rtree(20) f <- function(col) { o <- identify(tr) nodelabels(node=o$nodes, pch = 19, col = col) } plot(tr) f("red") # click close to a node f("green") } } \keyword{aplot} ape/man/birthdeath.Rd0000644000176200001440000000526414164530562014214 0ustar liggesusers\name{birthdeath} \alias{birthdeath} \alias{print.birthdeath} \title{Estimation of Speciation and Extinction Rates With Birth-Death Models} \usage{ birthdeath(phy) \method{print}{birthdeath}(x, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{x}{an object of class \code{"birthdeath"}.} \item{\dots}{further arguments passed to the \code{print} function.} } \description{ This function fits by maximum likelihood a birth-death model to the branching times computed from a phylogenetic tree using the method of Nee et al. (1994). } \details{ Nee et al. (1994) used a re-parametrization of the birth-death model studied by Kendall (1948) so that the likelihood has to be maximized over \emph{d/b} and \emph{b - d}, where \emph{b} is the birth rate, and \emph{d} the death rate. This is the approach used by the present function. This function computes the standard-errors of the estimated parameters using a normal approximations of the maximum likelihood estimates: this is likely to be inaccurate because of asymmetries of the likelihood function (Nee et al. 1995). In addition, 95 % confidence intervals of both parameters are computed using profile likelihood: they are particularly useful if the estimate of \emph{d/b} is at the boundary of the parameter space (i.e. 0, which is often the case). Note that the function does not check that the tree is effectively ultrametric, so if it is not, the returned result may not be meaningful. } \value{ An object of class \code{"birthdeath"} which is a list with the following components: \item{tree}{the name of the tree analysed.} \item{N}{the number of species.} \item{dev}{the deviance (= -2 log lik) at its minimum.} \item{para}{the estimated parameters.} \item{se}{the corresponding standard-errors.} \item{CI}{the 95\% profile-likelihood confidence intervals.} } \references{ Kendall, D. G. (1948) On the generalized ``birth-and-death'' process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15. Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London. Series B. Biological Sciences}, \bold{344}, 305--311. Nee, S., Holmes, E. C., May, R. M. and Harvey, P. H. (1995) Estimating extinctions from molecular phylogenies. in \emph{Extinction Rates}, eds. Lawton, J. H. and May, R. M., pp. 164--182, Oxford University Press. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.gof}}, \code{\link{diversi.time}}, \code{\link{ltt.plot}}, \code{\link{yule}}, \code{\link{bd.ext}}, \code{\link{yule.cov}}, \code{\link{bd.time}} } \keyword{models} ape/man/bd.time.Rd0000644000176200001440000000616714164530562013423 0ustar liggesusers\name{bd.time} \alias{bd.time} \title{Time-Dependent Birth-Death Models} \description{ This function fits a used-defined time-dependent birth-death model. } \usage{ bd.time(phy, birth, death, BIRTH = NULL, DEATH = NULL, ip, lower, upper, fast = FALSE, boot = 0, trace = 0) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{birth}{either a numeric (if speciation rate is assumed constant), or a (vectorized) function specifying how the birth (speciation) probability changes through time (see details).} \item{death}{id. for extinction probability.} \item{BIRTH}{(optional) a vectorized function giving the primitive of \code{birth}.} \item{DEATH}{id. for \code{death}.} \item{ip}{a numeric vector used as initial values for the estimation procedure. If missing, these values are guessed.} \item{lower, upper}{the lower and upper bounds of the parameters. If missing, these values are guessed too.} \item{fast}{a logical value specifying whether to use faster integration (see details).} \item{boot}{the number of bootstrap replicates to assess the confidence intervals of the parameters. Not run by default.} \item{trace}{an integer value. If non-zero, the fitting procedure is printed every \code{trace} steps. This can be helpful if convergence is particularly slow.} } \details{ Details on how to specify the birth and death functions and their primitives can be found in the help page of \code{\link{yule.time}}. The model is fitted by minimizing the least squares deviation between the observed and the predicted distributions of branching times. These computations rely heavily on numerical integrations. If \code{fast = FALSE}, integrations are done with R's \code{\link[stats]{integrate}} function. If \code{fast = TRUE}, a faster but less accurate function provided in \pkg{ape} is used. If fitting a complex model to a large phylogeny, a strategy might be to first use the latter option, and then to use the estimates as starting values with \code{fast = FALSE}. } \value{ A list with the following components: \itemize{ \item{par}{a vector of estimates with names taken from the parameters in the specified functions.} \item{SS}{the minimized sum of squares.} \item{convergence}{output convergence criterion from \code{\link[stats]{nlminb}}.} \item{message}{id.} \item{iterations}{id.} \item{evaluations}{id.} }} \references{ Paradis, E. (2011) Time-dependent speciation and extinction from phylogenies: a least squares approach. \emph{Evolution}, \bold{65}, 661--672. } \author{Emmanuel Paradis} \seealso{ \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{yule.time}}, \code{\link{LTT}} } \examples{ set.seed(3) tr <- rbdtree(0.1, 0.02) bd.time(tr, 0, 0) # fits a simple BD model bd.time(tr, 0, 0, ip = c(.1, .01)) # 'ip' is useful here ## the classic logistic: birth.logis <- function(a, b) 1/(1 + exp(-a*t - b)) \dontrun{ bd.time(tr, birth.logis, 0, ip = c(0, -2, 0.01)) ## slow to get: ## $par ## a b death ## -0.003486961 -1.995983179 0.016496454 ## ## $SS ## [1] 20.73023 } } \keyword{models} ape/man/read.caic.Rd0000644000176200001440000000325414164530562013704 0ustar liggesusers\name{read.caic} \alias{read.caic} \title{Read Tree File in CAIC Format} \description{ This function reads one tree from a CAIC file. A second file containing branch lengths values may also be passed (experimental). } \usage{ read.caic(file, brlen = NULL, skip = 0, comment.char = "#", ...) } \arguments{ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} \item{brlen}{a file name for the branch lengths file.} \item{skip}{the number of lines of the input file to skip before beginning to read data (this is passed directly to scan()).} \item{comment.char}{a single character, the remaining of the line after this character is ignored (this is passed directly to scan()).} \item{\dots}{Further arguments to be passed to scan().} } \details{ Read a tree from a file in the format used by the CAIC and MacroCAIc program. } \value{ an object of class \code{"phylo"}. } \references{ Purvis, A. and Rambaut, A. (1995) Comparative analysis by independent contrasts (CAIC): an Apple Macintosh application for analysing comparative data. \emph{CABIOS}, \bold{11} :241--251. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}} \section{Warning}{The branch length support is still experimental and was not fully tested.} \seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}} } \examples{ ### The same example than in read.tree, without branch lengths. ### An extract from Sibley and Ahlquist (1990) cat("AAA","Strix_aluco","AAB","Asio_otus", "AB","Athene_noctua","B","Tyto_alba", file = "ex.tre", sep = "\n") tree.owls <- read.caic("ex.tre") plot(tree.owls) tree.owls unlink("ex.tre") # delete the file "ex.tre" } \keyword{hplot} ape/man/comparePhylo.Rd0000644000176200001440000000457714164530562014546 0ustar liggesusers\name{comparePhylo} \alias{comparePhylo} \alias{print.comparePhylo} \title{Compare Two "phylo" Objects} \description{ This function compares two phylogenetic trees, rooted or unrooted, and returns a detailed report of this comparison. } \usage{ comparePhylo(x, y, plot = FALSE, force.rooted = FALSE, use.edge.length = FALSE, commons = TRUE, location = "bottomleft", ...) \method{print}{comparePhylo}(x, ...) } \arguments{ \item{x, y}{two objects of class \code{"phylo"}.} \item{plot}{a logical value. If \code{TRUE}, the two trees are plotted on the same device and their similarities are shown.} \item{force.rooted}{a logical value. If \code{TRUE}, the trees are considered rooted even if \code{is.rooted} returns \code{FALSE}.} \item{use.edge.length}{a logical value passed to \code{\link{plot.phylo}} (see below).} \item{commons}{whether to show the splits (the default), or the splits specific to each tree (applies only for unrooted trees).} \item{location}{location of where to position the \code{\link{legend}}.} \item{\dots}{further parameters used by \code{\link{plot.phylo}}, in function \code{print.comparePhylo} unused.} } \details{ In all cases, the numbers of tips and of nodes and the tip labels are compared. If both trees are rooted, or if \code{force.rooted = TRUE}, the clade compositions of each tree are compared. If both trees are also ultrametric, their branching times are compared. If both trees are unrooted and have the same number of nodes, the bipartitions (aka splits) are compared. If \code{plot = TRUE}, the edge lengths are not used by default because in some situations with unrooted trees, some splits might not be visible if the corresponding internal edge length is very short. To use edge lengths, set \code{use.edge.length = TRUE}. } \value{ an object of class \code{"comparePhylo"} which is a list with messages from the comparison and, optionally, tables comparing branching times. } \author{Emmanuel Paradis, Klaus Schliep} \seealso{\code{\link{all.equal.phylo}}} \examples{ ## two unrooted trees but force comparison as rooted: a <- read.tree(text = "(a,b,(c,d));") b <- read.tree(text = "(a,c,(b,d));") comparePhylo(a, b, plot = TRUE, force.rooted = TRUE) ## two random unrooted trees: c <- rtree(5, rooted = FALSE) d <- rtree(5, rooted = FALSE) comparePhylo(c, d, plot = TRUE) } \keyword{manip} ape/man/dist.topo.Rd0000644000176200001440000000571714164530562014024 0ustar liggesusers\name{dist.topo} \alias{dist.topo} \title{Topological Distances Between Two Trees} \description{ This function computes the topological distance between two phylogenetic trees or among trees in a list (if \code{y = NULL} using different methods. } \usage{ dist.topo(x, y = NULL, method = "PH85") } \arguments{ \item{x}{an object of class \code{"phylo"} or of class \code{"multiPhylo"}.} \item{y}{an (optional) object of class \code{"phylo"}.} \item{method}{a character string giving the method to be used: either \code{"PH85"}, or \code{"score"}.} } \value{ a single numeric value if both \code{x} and \code{y} are used, an object of class \code{"dist"} otherwise. } \details{ Two methods are available: the one by Penny and Hendy (1985, originally from Robinson and Foulds 1981), and the branch length score by Kuhner and Felsenstein (1994). The trees are always considered as unrooted. The topological distance is defined as twice the number of internal branches defining different bipartitions of the tips (Robinson and Foulds 1981; Penny and Hendy 1985). Rzhetsky and Nei (1992) proposed a modification of the original formula to take multifurcations into account. The branch length score may be seen as similar to the previous distance but taking branch lengths into account. Kuhner and Felsenstein (1994) proposed to calculate the square root of the sum of the squared differences of the (internal) branch lengths defining similar bipartitions (or splits) in both trees. } \note{ The geodesic distance of Billera et al. (2001) has been disabled: see the package \pkg{distory} on CRAN. } \references{ Billera, L. J., Holmes, S. P. and Vogtmann, K. (2001) Geometry of the space of phylogenetic trees. \emph{Advances in Applied Mathematics}, \bold{27}, 733--767. Kuhner, M. K. and Felsenstein, J. (1994) Simulation comparison of phylogeny algorithms under equal and unequal evolutionary rates. \emph{Molecular Biology and Evolution}, \bold{11}, 459--468. Nei, M. and Kumar, S. (2000) \emph{Molecular Evolution and Phylogenetics}. Oxford: Oxford University Press. Penny, D. and Hendy, M. D. (1985) The use of tree comparison metrics. \emph{Systemetic Zoology}, \bold{34}, 75--82. Robinson, D. F. and Foulds, L. R. (1981) Comparison of phylogenetic trees. \emph{Mathematical Biosciences}, \bold{53}, 131--147. Rzhetsky, A. and Nei, M. (1992) A simple method for estimating and testing minimum-evolution trees. \emph{Molecular Biology and Evolution}, \bold{9}, 945--967. } \author{Emmanuel Paradis} \seealso{ \code{\link{cophenetic.phylo}}, \code{\link{prop.part}} } \examples{ ta <- rtree(30, rooted = FALSE) tb <- rtree(30, rooted = FALSE) dist.topo(ta, ta) # 0 dist.topo(ta, tb) # unlikely to be 0 ## rmtopology() simulated unrooted trees by default: TR <- rmtopology(100, 10) ## these trees have 7 internal branches, so the maximum distance ## between two of them is 14: DTR <- dist.topo(TR) table(DTR) } \keyword{manip} ape/man/additive.Rd0000644000176200001440000000120014164530562013651 0ustar liggesusers\name{additive} \alias{additive} \alias{ultrametric} \title{Incomplete Distance Matrix Filling} \description{ Fills missing entries from incomplete distance matrix using the additive or the ultrametric procedure (see reference for details). } \usage{ additive(X) ultrametric(X) } \arguments{ \item{X}{a distance matrix or an object of class \code{"dist"}.} } \value{ a distance matrix. } \references{ Makarenkov, V. and Lapointe, F.-J. (2004) A weighted least-squares approach for inferring phylogenies from incomplete distance matrices. \emph{Bioinformatics}, \bold{20}, 2113--2121. } \author{Andrei Popescu} \keyword{manip} ape/man/delta.plot.Rd0000644000176200001440000000313614164530562014140 0ustar liggesusers\name{delta.plot} \alias{delta.plot} \title{Delta Plots} \usage{ delta.plot(X, k = 20, plot = TRUE, which = 1:2) } \arguments{ \item{X}{a distance matrix, may be an object of class ``dist''.} \item{k}{an integer giving the number of intervals in the plot.} \item{plot}{a logical specifying whether to draw the \eqn{\delta}{delta} plot (the default).} \item{which}{a numeric vector indicating which plots are done; 1: the histogram of the \eqn{\delta_q}{delta_q} values, 2: the plot of the individual \eqn{\bar{\delta}}{delta.bar} values. By default, both plots are done.} } \description{ This function makes a \eqn{\delta}{delta} plot following Holland et al. (2002). } \details{ See Holland et al. (2002) for details and interpretation. The computing time of this function is proportional to the fourth power of the number of observations (\eqn{O(n^4)}), so calculations may be very long with only a slight increase in sample size. } \value{ This function returns invisibly a named list with two components: \itemize{ \item{counts}{the counts for the histogram of \eqn{\delta_q}{delta_q} values} \item{delta.bar}{the mean \eqn{\delta}{delta} value for each observation} } } \references{ Holland, B. R., Huber, K. T., Dress, A. and Moulton, V. (2002) Delta plots: a tool for analyzing phylogenetic distance data. \emph{Molecular Biology and Evolution}, \bold{12}, 2051--2059. } \author{Emmanuel Paradis} \seealso{ \code{\link{dist.dna}} } \examples{ data(woodmouse) d <- dist.dna(woodmouse) delta.plot(d) layout(1) delta.plot(d, 40, which = 1) } \keyword{hplot} ape/man/MoranI.Rd0000644000176200001440000000547214164530562013264 0ustar liggesusers\name{Moran.I} \alias{Moran.I} \title{Moran's I Autocorrelation Index} \usage{ Moran.I(x, weight, scaled = FALSE, na.rm = FALSE, alternative = "two.sided") } \arguments{ \item{x}{a numeric vector.} \item{weight}{a matrix of weights.} \item{scaled}{a logical indicating whether the coefficient should be scaled so that it varies between -1 and +1 (default to \code{FALSE}).} \item{na.rm}{a logical indicating whether missing values should be removed.} \item{alternative}{a character string specifying the alternative hypothesis that is tested against the null hypothesis of no phylogenetic correlation; must be of one "two.sided", "less", or "greater", or any unambiguous abbrevation of these.} } \description{ This function computes Moran's I autocorrelation coefficient of \code{x} giving a matrix of weights using the method described by Gittleman and Kot (1990). } \details{ The matrix \code{weight} is used as ``neighbourhood'' weights, and Moran's I coefficient is computed using the formula: \deqn{I = \frac{n}{S_0} \frac{\sum_{i=1}^n\sum_{j=1}^n w_{i,j}(y_i - \overline{y})(y_j - \overline{y})}{\sum_{i=1}^n {(y_i - \overline{y})}^2}}{\code{I = n/S0 * (sum\{i=1..n\} sum\{j=1..n\} wij(yi - ym))(yj - ym) / (sum\{i=1..n\} (yi - ym)^2)}} with \itemize{ \item \eqn{y_i}{yi} = observations \item \eqn{w_{i,j}}{wij} = distance weight \item \eqn{n} = number of observations \item \eqn{S_0}{S0} = \eqn{\sum_{i=1}^n\sum_{j=1}^n wij}{\code{sum_{i=1..n} sum{j=1..n} wij}} } The null hypothesis of no phylogenetic correlation is tested assuming normality of I under this null hypothesis. If the observed value of I is significantly greater than the expected value, then the values of \code{x} are positively autocorrelated, whereas if Iobserved < Iexpected, this will indicate negative autocorrelation. } \value{ A list containing the elements: \item{observed}{the computed Moran's I.} \item{expected}{the expected value of I under the null hypothesis.} \item{sd}{the standard deviation of I under the null hypothesis.} \item{p.value}{the P-value of the test of the null hypothesis against the alternative hypothesis specified in \code{alternative}.} } \references{ Gittleman, J. L. and Kot, M. (1990) Adaptation: statistics and a null model for estimating phylogenetic effects. \emph{Systematic Zoology}, \bold{39}, 227--241. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de} and Emmanuel Paradis} \seealso{\code{\link{weight.taxo}}} \examples{ tr <- rtree(30) x <- rnorm(30) ## weights w[i,j] = 1/d[i,j]: w <- 1/cophenetic(tr) ## set the diagonal w[i,i] = 0 (instead of Inf...): diag(w) <- 0 Moran.I(x, w) Moran.I(x, w, alt = "l") Moran.I(x, w, alt = "g") Moran.I(x, w, scaled = TRUE) # usualy the same } \keyword{models} \keyword{regression} ape/man/clustal.Rd0000644000176200001440000001137114164530562013541 0ustar liggesusers\name{clustal} \alias{clustal} \alias{clustalomega} \alias{muscle} \alias{tcoffee} \title{Multiple Sequence Alignment with External Applications} \description{ These functions call their respective program from \R to align a set of nucleotide sequences of class \code{"DNAbin"} or \code{"AAbin"}. The application(s) must be installed seperately and it is highly recommended to do this so that the executables are in a directory located on the PATH of the system. } \usage{ clustal(x, y, guide.tree, pw.gapopen = 10, pw.gapext = 0.1, gapopen = 10, gapext = 0.2, exec = NULL, MoreArgs = "", quiet = TRUE, original.ordering = TRUE, file) clustalomega(x, y, guide.tree, exec = NULL,MoreArgs = "", quiet = TRUE, original.ordering = TRUE, file) muscle(x, y, guide.tree, exec, MoreArgs = "", quiet = TRUE, original.ordering = TRUE, file) tcoffee(x, exec = "t_coffee", MoreArgs = "", quiet = TRUE, original.ordering = TRUE) } \arguments{ \item{x}{an object of class \code{"DNAbin"} or \code{"AAbin"} (can be missing).} \item{y}{an object of class \code{"DNAbin"} or \code{"AAbin"} used for profile alignment (can be missing).} \item{guide.tree}{guide tree, an object of class \code{"phylo"} (can be missing).} \item{pw.gapopen, pw.gapext}{gap opening and gap extension penalties used by Clustal during pairwise alignments.} \item{gapopen, gapext}{idem for global alignment.} \item{exec}{a character string giving the name of the program, with its path if necessary. \code{clustal} tries to guess this argument depending on the operating system (see details).} \item{MoreArgs}{a character string giving additional options.} \item{quiet}{a logical: the default is to not print on \R's console the messages from the external program.} \item{original.ordering}{a logical specifying whether to return the aligned sequences in the same order than in \code{x} (\code{TRUE} by default).} \item{file}{a file with its path if results should be stored (can be missing).} } \details{ It is highly recommended to install the executables properly so that they are in a directory located on the PATH (i.e., accessible from any other directory). Alternatively, the full path to the executable may be given (e.g., \code{exec = "~/muscle/muscle"}), or a (symbolic) link may be copied in the working directory. For Debian and its derivatives (e.g., Ubuntu), it is recommended to use the binaries distributed by Debian. \code{clustal} tries to guess the name of the executable program depending on the operating system. Specifically, the followings are used: ``clustalw'' under Linux, ``clustalw2'' under MacOS, and ``clustalw2.exe'' under Windows. For \code{clustalomega}, ``clustalo[.exe]'' is the default on all systems (with no specific path). When called without arguments (i.e., \code{clustal()}, \dots), the function prints the options of the program which may be passed to \code{MoreArgs}. Since \pkg{ape} 5.1, \code{clustal}, \code{clustalomega}, and \code{muscle} can align AA sequences as well as DNA sequences. } \value{ an object of class \code{"DNAbin"} or \code{"AAbin"} with the aligned sequences. } \references{ Chenna, R., Sugawara, H., Koike, T., Lopez, R., Gibson, T. J., Higgins, D. G. and Thompson, J. D. (2003) Multiple sequence alignment with the Clustal series of programs. \emph{Nucleic Acids Research} \bold{31}, 3497--3500. \url{http://www.clustal.org/} Edgar, R. C. (2004) MUSCLE: Multiple sequence alignment with high accuracy and high throughput. \emph{Nucleic Acids Research}, \bold{32}, 1792--1797. \url{http://www.drive5.com/muscle/muscle_userguide3.8.html} Notredame, C., Higgins, D. and Heringa, J. (2000) T-Coffee: A novel method for multiple sequence alignments. \emph{Journal of Molecular Biology}, \bold{302}, 205--217. \url{https://www.tcoffee.org/} Sievers, F., Wilm, A., Dineen, D., Gibson, T. J., Karplus, K., Li, W., Lopez, R., McWilliam, H., Remmert, M., S\"oding, J., Thompson, J. D. and Higgins, D. G. (2011) Fast, scalable generation of high-quality protein multiple sequence alignments using Clustal Omega. \emph{Molecular Systems Biology}, \bold{7}, 539. \url{http://www.clustal.org/} } \author{Emmanuel Paradis, Franz Krah} \seealso{ \code{\link{image.DNAbin}}, \code{\link{del.gaps}}, \code{\link{all.equal.DNAbin}}, \code{\link{alex}}, \code{\link{alview}}, \code{\link{checkAlignment}} } \examples{ \dontrun{ ### display the options: clustal() clustalomega() muscle() tcoffee() data(woodmouse) ### open gaps more easily: clustal(woodmouse, pw.gapopen = 1, pw.gapext = 1) ### T-Coffee requires negative values (quite slow; muscle() is much faster): tcoffee(woodmouse, MoreArgs = "-gapopen=-10 -gapext=-2") }} \keyword{manip} ape/man/plot.correlogram.Rd0000644000176200001440000000434714164530562015370 0ustar liggesusers\name{plot.correlogram} \alias{plot.correlogram} \alias{plot.correlogramList} \title{Plot a Correlogram} \usage{ \method{plot}{correlogram}(x, legend = TRUE, test.level = 0.05, col = c("grey", "red"), type = "b", xlab = "", ylab = "Moran's I", pch = 21, cex = 2, ...) \method{plot}{correlogramList}(x, lattice = TRUE, legend = TRUE, test.level = 0.05, col = c("grey", "red"), xlab = "", ylab = "Moran's I", type = "b", pch = 21, cex = 2, ...) } \arguments{ \item{x}{an object of class \code{"correlogram"} or of class \code{"correlogramList"} (both produced by \code{\link{correlogram.formula}}).} \item{legend}{should a legend be added on the plot?} \item{test.level}{the level used to discriminate the plotting symbols with colours considering the P-values.} \item{col}{two colours for the plotting symbols: the first one is used if the P-value is greater than or equal to \code{test.level}, the second one otherwise.} \item{type}{the type of plot to produce (see \code{\link[graphics]{plot}} for possible choices).} \item{xlab}{an optional character string for the label on the x-axis (none by default).} \item{ylab}{the default label on the y-axis.} \item{pch}{the type of plotting symbol.} \item{cex}{the default size for the plotting symbols.} \item{lattice}{when plotting several correlograms, should they be plotted in trellis-style with lattice (the default), or together on the same plot?} \item{\dots}{other parameters passed to the \code{plot} or \code{lines} function.} } \description{ These functions plot correlagrams previously computed with \code{\link{correlogram.formula}}. } \details{ When plotting several correlograms with lattice, some options have no effect: \code{legend}, \code{type}, and \code{pch} (\code{pch=19} is always used in this situation). When using \code{pch} between 1 and 20 (i.e., non-filled symbols, the colours specified in \code{col} are also used for the lines joining the points. To keep black lines, it is better to leave \code{pch} between 21 and 25. } \author{Emmanuel Paradis} \seealso{ \code{\link{correlogram.formula}}, \code{\link{Moran.I}} } \keyword{hplot} ape/man/bird.orders.Rd0000644000176200001440000000225314164530562014306 0ustar liggesusers\name{bird.orders} \alias{bird.orders} \title{Phylogeny of the Orders of Birds From Sibley and Ahlquist} \description{ This data set describes the phylogenetic relationships of the orders of birds as reported by Sibley and Ahlquist (1990). Sibley and Ahlquist inferred this phylogeny from an extensive number of DNA/DNA hybridization experiments. The ``tapestry'' reported by these two authors (more than 1000 species out of the ca. 9000 extant bird species) generated a lot of debates. The present tree is based on the relationships among orders. The branch lengths were calculated from the values of \eqn{\Delta T_{50}H}{Delta T50H} as found in Sibley and Ahlquist (1990, fig. 353). } \usage{ data(bird.orders) } \format{ The data are stored as an object of class \code{"phylo"} which structure is described in the help page of the function \code{\link{read.tree}}. } \source{ Sibley, C. G. and Ahlquist, J. E. (1990) Phylogeny and classification of birds: a study in molecular evolution. New Haven: Yale University Press. } \seealso{ \code{\link{read.tree}}, \code{\link{bird.families}} } \examples{ data(bird.orders) plot(bird.orders) } \keyword{datasets} ape/man/binaryPGLMM.Rd0000644000176200001440000003161414164530562014155 0ustar liggesusers\name{binaryPGLMM} \alias{binaryPGLMM} \alias{binaryPGLMM.sim} \alias{print.binaryPGLMM} \title{Phylogenetic Generalized Linear Mixed Model for Binary Data} \description{ binaryPGLMM performs linear regression for binary phylogenetic data, estimating regression coefficients with approximate standard errors. It simultaneously estimates the strength of phylogenetic signal in the residuals and gives an approximate conditional likelihood ratio test for the hypothesis that there is no signal. Therefore, when applied without predictor (independent) variables, it gives a test for phylogenetic signal for binary data. The method uses a GLMM approach, alternating between penalized quasi-likelihood (PQL) to estimate the "mean components" and restricted maximum likelihood (REML) to estimate the "variance components" of the model. binaryPGLMM.sim is a companion function that simulates binary phylogenetic data of the same structure analyzed by binaryPGLMM. } \usage{ binaryPGLMM(formula, data = list(), phy, s2.init = 0.1, B.init = NULL, tol.pql = 10^-6, maxit.pql = 200, maxit.reml = 100) binaryPGLMM.sim(formula, data = list(), phy, s2 = NULL, B = NULL, nrep = 1) \method{print}{binaryPGLMM}(x, digits = max(3, getOption("digits") - 3), ...) } \arguments{ \item{formula}{a two-sided linear formula object describing the fixed-effects of the model; for example, Y ~ X.} \item{data}{a data frame containing the variables named in formula.} \item{phy}{a phylogenetic tree as an object of class "phylo".} \item{s2.init}{an initial estimate of s2, the scaling component of the variance in the PGLMM. A value of s2 = 0 implies no phylogenetic signal. Note that the variance-covariance matrix given by the phylogeny phy is scaled to have determinant = 1.} \item{B.init}{initial estimates of B, the matrix containing regression coefficients in the model. This matrix must have dim(B.init)=c(p+1,1), where p is the number of predictor (independent) variables; the first element of B corresponds to the intercept, and the remaining elements correspond in order to the predictor (independent) variables in the model.} \item{tol.pql}{a control parameter dictating the tolerance for convergence for the PQL optimization.} \item{maxit.pql}{a control parameter dictating the maximum number of iterations for the PQL optimization.} \item{maxit.reml}{a control parameter dictating the maximum number of iterations for the REML optimization.} \item{x}{an object of class "binaryPGLMM".} \item{s2}{in binaryPGLMM.sim, value of s2. See s2.init.} \item{B}{in binaryPGLMM.sim, value of B, the matrix containing regression coefficients in the model. See B.init.} \item{nrep}{in binaryPGLMM.sim, number of compete data sets produced.} \item{digits}{the number of digits to print.} \item{\dots}{further arguments passed to \code{print}.} } \details{ The function estimates parameters for the model \deqn{Pr(Y = 1) = q } \deqn{q = inverse.logit(b0 + b1 * x1 + b2 * x2 + \dots + \epsilon)} \deqn{\epsilon ~ Gaussian(0, s2 * V) } where \eqn{V} is a variance-covariance matrix derived from a phylogeny (typically under the assumption of Brownian motion evolution). Although mathematically there is no requirement for \eqn{V} to be ultrametric, forcing \eqn{V} into ultrametric form can aide in the interpretation of the model, because in regression for binary dependent variables, only the off-diagonal elements (i.e., covariances) of matrix \eqn{V} are biologically meaningful (see Ives & Garland 2014). The function converts a phylo tree object into a variance-covariance matrix, and further standardizes this matrix to have determinant = 1. This in effect standardizes the interpretation of the scalar s2. Although mathematically not required, it is a very good idea to standardize the predictor (independent) variables to have mean 0 and variance 1. This will make the function more robust and improve the interpretation of the regression coefficients. For categorical (factor) predictor variables, you will need to construct 0-1 dummy variables, and these should not be standardized (for obvious reasons). The estimation method alternates between PQL to obtain estimates of the mean components of the model (this is the standard approach to estimating GLMs) and REML to obtain estimates of the variance components. This method gives relatively fast and robust estimation. Nonetheless, the estimates of the coefficients B will generally be upwards bias, as is typical of estimation for binary data. The standard errors of B are computed from the PQL results conditional on the estimate of s2 and therefore should tend to be too small. The function returns an approximate P-value for the hypothesis of no phylogenetic signal in the residuals (i.e., H0:s2 = 0) using an approximate likelihood ratio test based on the conditional REML likelihood (rather than the marginal likelihood). Simulations have shown that these P-values tend to be high (giving type II errors: failing to identify variances that in fact are statistically significantly different from zero). It is a good idea to confirm statistical inferences using parametric bootstrapping, and the companion function binaryPGLMM.sim gives a simply tool for this. See Examples below. } \value{ An object of class "binaryPGLMM". \item{formula}{formula specifying the regression model.} \item{B}{estimates of the regression coefficients.} \item{B.se}{approximate PQL standard errors of the regression coefficients.} \item{B.cov}{approximate PQL covariance matrix for the regression coefficients.} \item{B.zscore}{approximate PQL Z scores for the regression coefficients.} \item{B.pvalue}{approximate PQL tests for the regression coefficients being different from zero.} \item{s2}{phylogenetic signal measured as the scalar magnitude of the phylogenetic variance-covariance matrix s2 * V.} \item{P.H0.s2}{approximate likelihood ratio test of the hypothesis H0 that s2 = 0. This test is based on the conditional REML (keeping the regression coefficients fixed) and is prone to inflated type 1 errors.} \item{mu}{for each data point y, the estimate of p that y = 1.} \item{b}{for each data point y, the estimate of inverse.logit(p).} \item{X}{the predictor (independent) variables returned in matrix form (including 1s in the first column).} \item{H}{residuals of the form b + (Y - mu)/(mu * (1 - mu)).} \item{B.init}{the user-provided initial estimates of B. If B.init is not provided, these are estimated using glm() assuming no phylogenetic signal. The glm() estimates can generate convergence problems, so using small values (e.g., 0.01) is more robust but slower.} \item{VCV}{the standardized phylogenetic variance-covariance matrix.} \item{V}{estimate of the covariance matrix of H.} \item{convergeflag}{flag for cases when convergence failed.} \item{iteration}{number of total iterations performed.} \item{converge.test.B}{final tolerance for B.} \item{converge.test.s2}{final tolerance for s2.} \item{rcondflag}{number of times B is reset to 0.01. This is done when rcond(V) < 10^(-10), which implies that V cannot be inverted.} \item{Y}{in binaryPGLMM.sim, the simulated values of Y.} } \author{Anthony R. Ives} \references{ Ives, A. R. and Helmus, M. R. (2011) Generalized linear mixed models for phylogenetic analyses of community structure. \emph{Ecological Monographs}, \bold{81}, 511--525. Ives, A. R. and Garland, T., Jr. (2014) Phylogenetic regression for binary dependent variables. Pages 231--261 \emph{in} L. Z. Garamszegi, editor. \emph{Modern Phylogenetic Comparative Methods and Their Application in Evolutionary Biology}. Springer-Verlag, Berlin Heidelberg. } \seealso{ package \pkg{pez} and its function \code{communityPGLMM}; package \pkg{phylolm} and its function \code{phyloglm}; package \pkg{MCMCglmm} } \examples{ ## Illustration of binaryPGLMM() with simulated data # Generate random phylogeny n <- 100 phy <- compute.brlen(rtree(n=n), method = "Grafen", power = 1) # Generate random data and standardize to have mean 0 and variance 1 X1 <- rTraitCont(phy, model = "BM", sigma = 1) X1 <- (X1 - mean(X1))/var(X1) # Simulate binary Y sim.dat <- data.frame(Y=array(0, dim=n), X1=X1, row.names=phy$tip.label) sim.dat$Y <- binaryPGLMM.sim(Y ~ X1, phy=phy, data=sim.dat, s2=.5, B=matrix(c(0,.25),nrow=2,ncol=1), nrep=1)$Y # Fit model binaryPGLMM(Y ~ X1, phy=phy, data=sim.dat) \dontrun{ # Compare with phyloglm() library(phylolm) summary(phyloglm(Y ~ X1, phy=phy, data=sim.dat)) # Compare with glm() that does not account for phylogeny summary(glm(Y ~ X1, data=sim.dat, family="binomial")) # Compare with logistf() that does not account # for phylogeny but is less biased than glm() library(logistf) logistf(Y ~ X1, data=sim.dat) # Compare with MCMCglmm library(MCMCglmm) V <- vcv(phy) V <- V/max(V) detV <- exp(determinant(V)$modulus[1]) V <- V/detV^(1/n) invV <- Matrix(solve(V),sparse=T) sim.dat$species <- phy$tip.label rownames(invV) <- sim.dat$species nitt <- 43000 thin <- 10 burnin <- 3000 prior <- list(R=list(V=1, fix=1), G=list(G1=list(V=1, nu=1000, alpha.mu=0, alpha.V=1))) summary(MCMCglmm(Y ~ X1, random=~species, ginvers=list(species=invV), data=sim.dat, slice=TRUE, nitt=nitt, thin=thin, burnin=burnin, family="categorical", prior=prior, verbose=FALSE)) ## Examine bias in estimates of B1 and s2 from binaryPGLMM with # simulated data. Note that this will take a while. Reps = 1000 s2 <- 0.4 B1 <- 1 meanEsts <- data.frame(n = Inf, B1 = B1, s2 = s2, Pr.s2 = 1, propconverged = 1) for (n in c(160, 80, 40, 20)) { meanEsts.n <- data.frame(B1 = 0, s2 = 0, Pr.s2 = 0, convergefailure = 0) for (rep in 1:Reps) { phy <- compute.brlen(rtree(n = n), method = "Grafen", power = 1) X <- rTraitCont(phy, model = "BM", sigma = 1) X <- (X - mean(X))/var(X) sim.dat <- data.frame(Y = array(0, dim = n), X = X, row.names = phy$tip.label) sim <- binaryPGLMM.sim(Y ~ 1 + X, phy = phy, data = sim.dat, s2 = s2, B = matrix(c(0,B1), nrow = 2, ncol = 1), nrep = 1) sim.dat$Y <- sim$Y z <- binaryPGLMM(Y ~ 1 + X, phy = phy, data = sim.dat) meanEsts.n[rep, ] <- c(z$B[2], z$s2, z$P.H0.s2, z$convergeflag == "converged") } converged <- meanEsts.n[,4] meanEsts <- rbind(meanEsts, c(n, mean(meanEsts.n[converged==1,1]), mean(meanEsts.n[converged==1,2]), mean(meanEsts.n[converged==1, 3] < 0.05), mean(converged))) } meanEsts # Results output for B1 = 0.5, s2 = 0.4; n-Inf gives the values used to # simulate the data # n B1 s2 Pr.s2 propconverged # 1 Inf 1.000000 0.4000000 1.00000000 1.000 # 2 160 1.012719 0.4479946 0.36153072 0.993 # 3 80 1.030876 0.5992027 0.24623116 0.995 # 4 40 1.110201 0.7425203 0.13373860 0.987 # 5 20 1.249886 0.8774708 0.05727377 0.873 ## Examine type I errors for estimates of B0 and s2 from binaryPGLMM() # with simulated data. Note that this will take a while. Reps = 1000 s2 <- 0 B0 <- 0 B1 <- 0 H0.tests <- data.frame(n = Inf, B0 = B0, s2 = s2, Pr.B0 = .05, Pr.s2 = .05, propconverged = 1) for (n in c(160, 80, 40, 20)) { ests.n <- data.frame(B1 = 0, s2 = 0, Pr.B0 = 0, Pr.s2 = 0, convergefailure = 0) for (rep in 1:Reps) { phy <- compute.brlen(rtree(n = n), method = "Grafen", power = 1) X <- rTraitCont(phy, model = "BM", sigma = 1) X <- (X - mean(X))/var(X) sim.dat <- data.frame(Y = array(0, dim = n), X = X, row.names = phy$tip.label) sim <- binaryPGLMM.sim(Y ~ 1, phy = phy, data = sim.dat, s2 = s2, B = matrix(B0, nrow = 1, ncol = 1), nrep = 1) sim.dat$Y <- sim$Y z <- binaryPGLMM(Y ~ 1, phy = phy, data = sim.dat) ests.n[rep, ] <- c(z$B[1], z$s2, z$B.pvalue, z$P.H0.s2, z$convergeflag == "converged") } converged <- ests.n[,5] H0.tests <- rbind(H0.tests, c(n, mean(ests.n[converged==1,1]), mean(ests.n[converged==1,2]), mean(ests.n[converged==1, 3] < 0.05), mean(ests.n[converged==1, 4] < 0.05), mean(converged))) } H0.tests # Results for type I errors for B0 = 0 and s2 = 0; n-Inf gives the values # used to simulate the data. These results show that binaryPGLMM() tends to # have lower-than-nominal p-values; fewer than 0.05 of the simulated # data sets have H0:B0=0 and H0:s2=0 rejected at the alpha=0.05 level. # n B0 s2 Pr.B0 Pr.s2 propconverged # 1 Inf 0.0000000000 0.00000000 0.05000000 0.05000000 1.000 # 2 160 -0.0009350357 0.07273163 0.02802803 0.04804805 0.999 # 3 80 -0.0085831477 0.12205876 0.04004004 0.03403403 0.999 # 4 40 0.0019303847 0.25486307 0.02206620 0.03711133 0.997 # 5 20 0.0181394905 0.45949266 0.02811245 0.03313253 0.996 }} \keyword{regression} ape/man/treePop.Rd0000644000176200001440000000060614164530562013507 0ustar liggesusers\name{treePop} \alias{treePop} \title{Tree Popping} \description{ Method for reconstructing phylogenetic trees from an object of class splits using tree popping. } \usage{ treePop(obj) } \arguments{ \item{obj}{an object of class \code{"bitsplit"}.} } \value{ an object of class "phylo" which displays all the splits in the input object. } \author{Andrei Popescu} \keyword{models} ape/man/collapsed.intervals.Rd0000644000176200001440000000460014164530562016043 0ustar liggesusers\name{collapsed.intervals} \alias{collapsed.intervals} \title{Collapsed Coalescent Intervals} \usage{ collapsed.intervals(ci, epsilon=0) } \arguments{ \item{ci}{coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}).} \item{epsilon}{collapsing parameter that controls the amount of smoothing (allowed range: from \code{0} to \code{ci$total.depth})} } \description{ This function takes a \code{"coalescentIntervals"} objects and collapses neighbouring coalescent intervals into a single combined interval so that every collapsed interval is larger than \code{epsilon}. Collapsed coalescent intervals are used, e.g., to obtain the generalized skyline plot (\code{\link{skyline}}). For \code{epsilon = 0} no interval is collapsed. } \details{ Proceeding from the tips to the root of the tree each small interval is pooled with the neighboring interval closer to the root. If the neighboring interval is also small, then pooling continues until the composite interval is larger than \code{epsilon}. Note that this approach prevents the occurrence of zero-length intervals at the present. For more details see Strimmer and Pybus (2001). } \value{ An object of class \code{"collapsedIntervals"} with the following entries: \item{lineages}{ A vector with the number of lineages at the start of each coalescent interval.} \item{interval.length}{ A vector with the length of each coalescent interval.} \item{collapsed.interval}{A vector indicating for each coalescent interval to which collapsed interval it belongs.} \item{interval.count}{ The total number of coalescent intervals.} \item{collapsed.interval.count}{The number of collapsed intervals.} \item{total.depth}{ The sum of the lengths of all coalescent intervals.} \item{epsilon}{The value of the underlying smoothing parameter.} } \author{Korbinian Strimmer} \seealso{ \code{\link{coalescent.intervals}},\code{\link{skyline}}. } \references{ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history of DNA sequences using the generalized skyline plot. \emph{Molecular Biology and Evolution}, \bold{18}, 2298--2305. } \examples{ data("hivtree.table") # example tree # colescent intervals from vector of interval lengths ci <- coalescent.intervals(hivtree.table$size) ci # collapsed intervals cl1 <- collapsed.intervals(ci,0) cl2 <- collapsed.intervals(ci,0.0119) cl1 cl2 } \keyword{manip} ape/man/skyline.Rd0000644000176200001440000001231414164530562013546 0ustar liggesusers\name{skyline} \alias{skyline} \alias{skyline.phylo} \alias{skyline.coalescentIntervals} \alias{skyline.collapsedIntervals} \alias{find.skyline.epsilon} \title{Skyline Plot Estimate of Effective Population Size} \usage{ skyline(x, \dots) \method{skyline}{phylo}(x, \dots) \method{skyline}{coalescentIntervals}(x, epsilon=0, \dots) \method{skyline}{collapsedIntervals}(x, old.style=FALSE, \dots) find.skyline.epsilon(ci, GRID=1000, MINEPS=1e-6, \dots) } \arguments{ \item{x}{Either an ultrametric tree (i.e. an object of class \code{"phylo"}), or coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}), or collapsed coalescent intervals (i.e. an object of class \code{"collapsedIntervals"}).} \item{epsilon}{collapsing parameter that controls the amount of smoothing (allowed range: from \code{0} to \code{ci$total.depth}, default value: 0). This is the same parameter as in \link{collapsed.intervals}.} \item{old.style}{Parameter to choose between two slightly different variants of the generalized skyline plot (Strimmer and Pybus, pers. comm.). The default value \code{FALSE} is recommended.} \item{ci}{coalescent intervals (i.e. an object of class \code{"coalescentIntervals"})} \item{GRID}{Parameter for the grid search for \code{epsilon} in \code{find.skyline.epsilon}.} \item{MINEPS}{Parameter for the grid search for \code{epsilon} in \code{find.skyline.epsilon}.} \item{\dots}{Any of the above parameters.} } \description{ \code{skyline} computes the \emph{generalized skyline plot} estimate of effective population size from an estimated phylogeny. The demographic history is approximated by a step-function. The number of parameters of the skyline plot (i.e. its smoothness) is controlled by a parameter \code{epsilon}. \code{find.skyline.epsilon} searches for an optimal value of the \code{epsilon} parameter, i.e. the value that maximizes the AICc-corrected log-likelihood (\code{logL.AICc}). } \details{ \code{skyline} implements the \emph{generalized skyline plot} introduced in Strimmer and Pybus (2001). For \code{epsilon = 0} the generalized skyline plot degenerates to the \emph{classic skyline plot} described in Pybus et al. (2000). The latter is in turn directly related to lineage-through-time plots (Nee et al., 1995). } \value{ \code{skyline} returns an object of class \code{"skyline"} with the following entries: \item{time}{ A vector with the time at the end of each coalescent interval (i.e. the accumulated interval lengths from the beginning of the first interval to the end of an interval)} \item{interval.length}{ A vector with the length of each interval.} \item{population.size}{A vector with the effective population size of each interval.} \item{parameter.count}{ Number of free parameters in the skyline plot.} \item{epsilon}{The value of the underlying smoothing parameter.} \item{logL}{Log-likelihood of skyline plot (see Strimmer and Pybus, 2001).} \item{logL.AICc}{AICc corrected log-likelihood (see Strimmer and Pybus, 2001).} \code{find.skyline.epsilon} returns the value of the \code{epsilon} parameter that maximizes \code{logL.AICc}. } \author{Korbinian Strimmer} \seealso{ \code{\link{coalescent.intervals}}, \code{\link{collapsed.intervals}}, \code{\link{skylineplot}}, \code{\link{ltt.plot}}. } \references{ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history of DNA sequences using the generalized skyline plot. \emph{Molecular Biology and Evolution}, \bold{18}, 2298--2305. Pybus, O. G, Rambaut, A. and Harvey, P. H. (2000) An integrated framework for the inference of viral population history from reconstructed genealogies. \emph{Genetics}, \bold{155}, 1429--1437. Nee, S., Holmes, E. C., Rambaut, A. and Harvey, P. H. (1995) Inferring population history from molecular phylogenies. \emph{Philosophical Transactions of the Royal Society of London. Series B. Biological Sciences}, \bold{349}, 25--31. } \examples{ # get tree data("hivtree.newick") # example tree in NH format tree.hiv <- read.tree(text = hivtree.newick) # load tree # corresponding coalescent intervals ci <- coalescent.intervals(tree.hiv) # from tree # collapsed intervals cl1 <- collapsed.intervals(ci,0) cl2 <- collapsed.intervals(ci,0.0119) #### classic skyline plot #### sk1 <- skyline(cl1) # from collapsed intervals sk1 <- skyline(ci) # from coalescent intervals sk1 <- skyline(tree.hiv) # from tree sk1 plot(skyline(tree.hiv)) skylineplot(tree.hiv) # shortcut plot(sk1, show.years=TRUE, subst.rate=0.0023, present.year = 1997) #### generalized skyline plot #### sk2 <- skyline(cl2) # from collapsed intervals sk2 <- skyline(ci, 0.0119) # from coalescent intervals sk2 <- skyline(tree.hiv, 0.0119) # from tree sk2 plot(sk2) # classic and generalized skyline plot together in one plot plot(sk1, show.years=TRUE, subst.rate=0.0023, present.year = 1997, col=c(grey(.8),1)) lines(sk2, show.years=TRUE, subst.rate=0.0023, present.year = 1997) legend(.15,500, c("classic", "generalized"), col=c(grey(.8),1),lty=1) # find optimal epsilon parameter using AICc criterion find.skyline.epsilon(ci) sk3 <- skyline(ci, -1) # negative epsilon also triggers estimation of epsilon sk3$epsilon } \keyword{manip} ape/man/solveAmbiguousBases.Rd0000644000176200001440000000337114164530562016055 0ustar liggesusers\name{solveAmbiguousBases} \alias{solveAmbiguousBases} \title{Solve Ambiguous Bases in DNA Sequences} \description{ Replaces ambiguous bases in DNA sequences (R, Y, W, \dots) by A, G, C, or T. } \usage{ solveAmbiguousBases(x, method = "columnwise", random = TRUE) } \arguments{ \item{x}{a matrix of class \code{"DNAbin"}; a list is accepted and is converted into a matrix.} \item{method}{the method used (no other choice than the default for the moment; see details).} \item{random}{a logical value (see details).} } \details{ The replacements of ambiguous bases are done columwise. First, the base frequencies are counted: if no ambiguous base is found in the column, nothing is done. By default (i.e., if \code{random = TRUE}), the replacements are done by random sampling using the frequencies of the observed compatible, non-ambiguous bases. For instance, if the ambiguous base is Y, it is replaced by either C or T using their observed frequencies as probabilities. If \code{random = FALSE}, the greatest of these frequencies is used. If there are no compatible bases in the column, equal probabilities are used. For instance, if the ambiguous base is R, and only C and T are observed, then it is replaced by either A or G with equal probabilities. Alignment gaps are not changed; see the function \code{\link{latag2n}} to change the leading and trailing gaps. } \value{ a matrix of class \code{"DNAbin"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{base.freq}}, \code{\link{latag2n}}, \code{\link{dnds}} } \examples{ X <- as.DNAbin(matrix(c("A", "G", "G", "R"), ncol = 1)) alview(solveAmbiguousBases(X)) # R replaced by either A or G alview(solveAmbiguousBases(X, random = FALSE)) # R always replaced by G } \keyword{manip} ape/man/dbd.Rd0000644000176200001440000001017514164530562012624 0ustar liggesusers\name{dbd} \alias{dyule} \alias{dbd} \alias{dbdTime} \title{Probability Density Under Birth--Death Models} \description{ These functions compute the probability density under some birth--death models, that is the probability of obtaining \emph{x} species after a time \emph{t} giving how speciation and extinction probabilities vary through time (these may be constant, or even equal to zero for extinction). } \usage{ dyule(x, lambda = 0.1, t = 1, log = FALSE) dbd(x, lambda, mu, t, conditional = FALSE, log = FALSE) dbdTime(x, birth, death, t, conditional = FALSE, BIRTH = NULL, DEATH = NULL, fast = FALSE) } \arguments{ \item{x}{a numeric vector of species numbers (see Details).} \item{lambda}{a numerical value giving the probability of speciation; can be a vector with several values for \code{dyule}.} \item{mu}{id. for extinction.} \item{t}{id. for the time(s).} \item{log}{a logical value specifying whether the probabilities should be returned log-transformed; the default is \code{FALSE}.} \item{conditional}{a logical specifying whether the probabilities should be computed conditional under the assumption of no extinction after time \code{t}.} \item{birth, death}{a (vectorized) function specifying how the speciation or extinction probability changes through time (see \code{\link{yule.time}} and below).} \item{BIRTH, DEATH}{a (vectorized) function giving the primitive of \code{birth} or \code{death}.} \item{fast}{a logical value specifying whether to use faster integration (see \code{\link{bd.time}}).} } \details{ These three functions compute the probabilities to observe \code{x} species starting from a single one after time \code{t} (assumed to be continuous). The first function is a short-cut for the second one with \code{mu = 0} and with default values for the two other arguments. \code{dbdTime} is for time-varying \code{lambda} and \code{mu} specified as \R functions. \code{dyule} is vectorized simultaneously on its three arguments \code{x}, \code{lambda}, and \code{t}, according to \R's rules of recycling arguments. \code{dbd} is vectorized simultaneously \code{x} and \code{t} (to make likelihood calculations easy), and \code{dbdTime} is vectorized only on \code{x}; the other arguments are eventually shortened with a warning if necessary. The returned value is, logically, zero for values of \code{x} out of range, i.e., negative or zero for \code{dyule} or if \code{conditional = TRUE}. However, it is not checked if the values of \code{x} are positive non-integers and the probabilities are computed and returned. The details on the form of the arguments \code{birth}, \code{death}, \code{BIRTH}, \code{DEATH}, and \code{fast} can be found in the links below. } \note{ If you use these functions to calculate a likelihood function, it is strongly recommended to compute the log-likelihood with, for instance in the case of a Yule process, \code{sum(dyule( , log = TRUE))} (see examples). } \value{ a numeric vector. } \references{ Kendall, D. G. (1948) On the generalized ``birth-and-death'' process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15. } \author{Emmanuel Paradis} \seealso{ \code{\link{bd.time}}, \code{\link{yule.time}} } \examples{ x <- 0:10 plot(x, dyule(x), type = "h", main = "Density of the Yule process") text(7, 0.85, expression(list(lambda == 0.1, t == 1))) y <- dbd(x, 0.1, 0.05, 10) z <- dbd(x, 0.1, 0.05, 10, conditional = TRUE) d <- rbind(y, z) colnames(d) <- x barplot(d, beside = TRUE, ylab = "Density", xlab = "Number of species", legend = c("unconditional", "conditional on\nno extinction"), args.legend = list(bty = "n")) title("Density of the birth-death process") text(17, 0.4, expression(list(lambda == 0.1, mu == 0.05, t == 10))) \dontrun{ ### generate 1000 values from a Yule process with lambda = 0.05 x <- replicate(1e3, Ntip(rlineage(0.05, 0))) ### the correct way to calculate the log-likelihood...: sum(dyule(x, 0.05, 50, log = TRUE)) ### ... and the wrong way: log(prod(dyule(x, 0.05, 50))) ### a third, less preferred, way: sum(log(dyule(x, 0.05, 50))) }} \keyword{utilities} ape/man/varcomp.Rd0000644000176200001440000000171214164530562013537 0ustar liggesusers\name{varcomp} \alias{varcomp} \title{Compute Variance Component Estimates} \description{ Get variance component estimates from a fitted \code{lme} object. } \usage{ varcomp(x, scale = FALSE, cum = FALSE) } \arguments{ \item{x}{A fitted \code{lme} object} \item{scale}{Scale all variance so that they sum to 1} \item{cum}{Send cumulative variance components.} } \details{ Variance computations is done as in Venables and Ripley (2002). } \value{ A named vector of class \code{varcomp} with estimated variance components. } \references{ Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics with S (Fourth Edition)}. New York: Springer-Verlag. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}} \seealso{\code{\link[nlme]{lme}}} \examples{ data(carnivora) library(nlme) m <- lme(log10(SW) ~ 1, random = ~ 1|Order/SuperFamily/Family/Genus, data=carnivora) v <- varcomp(m, TRUE, TRUE) plot(v) } \keyword{regression} \keyword{dplot} ape/man/branching.times.Rd0000644000176200001440000000155314164530562015146 0ustar liggesusers\name{branching.times} \alias{branching.times} \title{Branching Times of a Phylogenetic Tree} \usage{ branching.times(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \description{ This function computes the branching times of a phylogenetic tree, that is the distance from each node to the tips, under the assumption that the tree is ultrametric. Note that the function does not check that the tree is effectively ultrametric, so if it is not, the returned result may not be meaningful. } \value{ a numeric vector with the branching times. If the phylogeny \code{phy} has an element \code{node.label}, this is used as names for the returned vector; otherwise the numbers (of mode character) of the matrix \code{edge} of \code{phy} are used as names. } \author{Emmanuel Paradis} \seealso{ \code{\link{is.ultrametric}} } \keyword{manip} ape/man/boot.phylo.Rd0000644000176200001440000001752014164530562014171 0ustar liggesusers\name{boot.phylo} \alias{boot.phylo} \alias{prop.part} \alias{prop.clades} \alias{print.prop.part} \alias{summary.prop.part} \alias{plot.prop.part} \title{Tree Bipartition and Bootstrapping Phylogenies} \description{ These functions analyse bipartitions found in a series of trees. \code{prop.part} counts the number of bipartitions found in a series of trees given as \code{\dots}. If a single tree is passed, the returned object is a list of vectors with the tips descending from each node (i.e., clade compositions indexed by node number). \code{prop.clades} counts the number of times the bipartitions present in \code{phy} are present in a series of trees given as \code{\dots} or in the list previously computed and given with \code{part}. \code{boot.phylo} performs a bootstrap analysis. } \usage{ boot.phylo(phy, x, FUN, B = 100, block = 1, trees = FALSE, quiet = FALSE, rooted = is.rooted(phy), jumble = TRUE, mc.cores = 1) prop.part(..., check.labels = TRUE) prop.clades(phy, ..., part = NULL, rooted = FALSE) \method{print}{prop.part}(x, ...) \method{summary}{prop.part}(object, ...) \method{plot}{prop.part}(x, barcol = "blue", leftmar = 4, col = "red", ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{x}{in the case of \code{boot.phylo}: a taxa (rows) by characters (columns) matrix; in the case of \code{print} and \code{plot}: an object of class \code{"prop.part"}.} \item{FUN}{the function used to estimate \code{phy} (see details).} \item{B}{the number of bootstrap replicates.} \item{block}{the number of columns in \code{x} that will be resampled together (see details).} \item{trees}{a logical specifying whether to return the bootstraped trees (\code{FALSE} by default).} \item{quiet}{a logical: a progress bar is displayed by default.} \item{rooted}{a logical specifying whether the trees should be treated as rooted or not.} \item{jumble}{a logical value. By default, the rows of \code{x} are randomized to avoid artificially too large bootstrap values associated with very short branches.} \item{mc.cores}{the number of cores (CPUs) to be used (passed to \pkg{parallel}).} \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a series of such objects separated by commas, or (iii) a list containing such objects. In the case of \code{plot} further arguments for the plot (see details).} \item{check.labels}{a logical specifying whether to check the labels of each tree. If \code{FALSE}, it is assumed that all trees have the same tip labels, and that they are in the same order (see details).} \item{part}{a list of partitions as returned by \code{prop.part}; if this is used then \code{\dots} is ignored.} \item{object}{an object of class \code{"prop.part"}.} \item{barcol}{the colour used for the bars displaying the number of partitions in the upper panel.} \item{leftmar}{the size of the margin on the left to display the tip labels.} \item{col}{the colour used to visualise the bipartitions.} } \details{ The argument \code{FUN} in \code{boot.phylo} must be the function used to estimate the tree from the original data matrix. Thus, if the tree was estimated with neighbor-joining (see \code{nj}), one maybe wants something like \code{FUN = function(xx) nj(dist.dna(xx))}. \code{block} in \code{boot.phylo} specifies the number of columns to be resampled altogether. For instance, if one wants to resample at the codon-level, then \code{block = 3} must be used. Using \code{check.labels = FALSE} in \code{prop.part} decreases computing times. This requires that (i) all trees have the same tip labels, \emph{and} (ii) these labels are ordered similarly in all trees (in other words, the element \code{tip.label} are identical in all trees). The plot function represents a contingency table of the different partitions (on the \emph{x}-axis) in the lower panel, and their observed numbers in the upper panel. Any further arguments (\dots) are used to change the aspects of the points in the lower panel: these may be \code{pch}, \code{col}, \code{bg}, \code{cex}, etc. This function works only if there is an attribute \code{labels} in the object. The print method displays the partitions and their numbers. The summary method extracts the numbers only. } \note{ \code{prop.clades} calls internally \code{prop.part} with the option \code{check.labels = TRUE}, which may be very slow. If the trees passed as \code{\dots} fulfills conditions (i) and (ii) above, then it might be faster to first call, e.g., \code{pp <- prop.part(...)}, then use the option \code{part}: \code{prop.clades(phy, part = pp)}. Since \pkg{ape} 3.5, \code{prop.clades} should return sensible results for all values of \code{rooted}: if \code{FALSE}, the numbers of bipartitions (or splits); if \code{TRUE}, the number of clades (of hopefully rooted trees). } \value{ \code{prop.part} returns an object of class \code{"prop.part"} which is a list with an attribute \code{"number"}. The elements of this list are the observed clades, and the attribute their respective numbers. If the default \code{check.labels = FALSE} is used, an attribute \code{"labels"} is added, and the vectors of the returned object contains the indices of these labels instead of the labels themselves. \code{prop.clades} and \code{boot.phylo} return a numeric vector which \emph{i}th element is the number associated to the \emph{i}th node of \code{phy}. If \code{trees = TRUE}, \code{boot.phylo} returns a list whose first element (named \code{"BP"}) is like before, and the second element (\code{"trees"}) is a list with the bootstraped trees. \code{summary} returns a numeric vector. } \references{ Efron, B., Halloran, E. and Holmes, S. (1996) Bootstrap confidence levels for phylogenetic trees. \emph{Proceedings of the National Academy of Sciences USA}, \bold{93}, 13429--13434. Felsenstein, J. (1985) Confidence limits on phylogenies: an approach using the bootstrap. \emph{Evolution}, \bold{39}, 783--791. } \author{Emmanuel Paradis} \seealso{ \code{\link{as.bitsplits}}, \code{\link{dist.topo}}, \code{\link{consensus}}, \code{\link{nodelabels}} } \examples{ data(woodmouse) f <- function(x) nj(dist.dna(x)) tr <- f(woodmouse) ### Are bootstrap values stable? for (i in 1:5) print(boot.phylo(tr, woodmouse, f, quiet = TRUE)) ### How many partitions in 100 random trees of 10 labels?... TR <- rmtree(100, 10) pp10 <- prop.part(TR) length(pp10) ### ... and in 100 random trees of 20 labels? TR <- rmtree(100, 20) pp20 <- prop.part(TR) length(pp20) plot(pp10, pch = "x", col = 2) plot(pp20, pch = "x", col = 2) set.seed(2) tr <- rtree(10) # rooted ## the following used to return a wrong result with ape <= 3.4: prop.clades(tr, tr) prop.clades(tr, tr, rooted = TRUE) tr <- rtree(10, rooted = FALSE) prop.clades(tr, tr) # correct ### an illustration of the use of prop.clades with bootstrap trees: fun <- function(x) as.phylo(hclust(dist.dna(x), "average")) # upgma() in phangorn tree <- fun(woodmouse) ## get 100 bootstrap trees: bstrees <- boot.phylo(tree, woodmouse, fun, trees = TRUE)$trees ## get proportions of each clade: clad <- prop.clades(tree, bstrees, rooted = TRUE) ## get proportions of each bipartition: boot <- prop.clades(tree, bstrees) layout(1) par(mar = rep(2, 4)) plot(tree, main = "Bipartition vs. Clade Support Values") drawSupportOnEdges(boot) nodelabels(clad) legend("bottomleft", legend = c("Bipartitions", "Clades"), pch = 22, pt.bg = c("green", "lightblue"), pt.cex = 2.5) \dontrun{ ## an example of double bootstrap: nrep1 <- 100 nrep2 <- 100 p <- ncol(woodmouse) DB <- 0 for (b in 1:nrep1) { X <- woodmouse[, sample(p, p, TRUE)] DB <- DB + boot.phylo(tr, X, f, nrep2, quiet = TRUE) } DB ## to compare with: boot.phylo(tr, woodmouse, f, 1e4) } } \keyword{manip} \keyword{htest} ape/man/DNAbin.Rd0000644000176200001440000001113414164530562013162 0ustar liggesusers\name{DNAbin} \alias{DNAbin} \alias{print.DNAbin} \alias{[.DNAbin} \alias{rbind.DNAbin} \alias{cbind.DNAbin} \alias{as.matrix.DNAbin} \alias{c.DNAbin} \alias{as.list.DNAbin} \alias{labels.DNAbin} \title{Manipulate DNA Sequences in Bit-Level Format} \description{ These functions help to manipulate DNA sequences coded in the bit-level coding scheme. } \usage{ \method{print}{DNAbin}(x, printlen = 6, digits = 3, \dots) \method{rbind}{DNAbin}(\dots) \method{cbind}{DNAbin}(\dots, check.names = TRUE, fill.with.gaps = FALSE, quiet = FALSE) \method{[}{DNAbin}(x, i, j, drop = FALSE) \method{as.matrix}{DNAbin}(x, \dots) \method{c}{DNAbin}(\dots, recursive = FALSE) \method{as.list}{DNAbin}(x, \dots) \method{labels}{DNAbin}(object, \dots) } \arguments{ \item{x, object}{an object of class \code{"DNAbin"}.} \item{\dots}{either further arguments to be passed to or from other methods in the case of \code{print}, \code{as.matrix}, and \code{labels}, or a series of objects of class \code{"DNAbin"} in the case of \code{rbind}, \code{cbind}, and \code{c}.} \item{printlen}{the number of labels to print (6 by default).} \item{digits}{the number of digits to print (3 by default).} \item{check.names}{a logical specifying whether to check the rownames before binding the columns (see details).} \item{fill.with.gaps}{a logical indicating whether to keep all possible individuals as indicating by the rownames, and eventually filling the missing data with insertion gaps (ignored if \code{check.names = FALSE}).} \item{quiet}{a logical to switch off warning messages when some rows are dropped.} \item{i, j}{indices of the rows and/or columns to select or to drop. They may be numeric, logical, or character (in the same way than for standard \R objects).} \item{drop}{logical; if \code{TRUE}, the returned object is of the lowest possible dimension.} \item{recursive}{for compatibility with the generic (unused).} } \details{ These are all `methods' of generic functions which are here applied to DNA sequences stored as objects of class \code{"DNAbin"}. They are used in the same way than the standard \R functions to manipulate vectors, matrices, and lists. Additionally, the operators \code{[[} and \code{$} may be used to extract a vector from a list. Note that the default of \code{drop} is not the same than the generic operator: this is to avoid dropping rownames when selecting a single sequence. These functions are provided to manipulate easily DNA sequences coded with the bit-level coding scheme. The latter allows much faster comparisons of sequences, as well as storing them in less memory compared to the format used before \pkg{ape} 1.10. For \code{cbind}, the default behaviour is to keep only individuals (as indicated by the rownames) for which there are no missing data. If \code{fill.with.gaps = TRUE}, a `complete' matrix is returned, enventually with insertion gaps as missing data. If \code{check.names = TRUE} (the default), the rownames of each matrix are checked, and the rows are reordered if necessary (if some rownames are duplicated, an error is returned). If \code{check.names = FALSE}, the matrices must all have the same number of rows, and are simply binded; the rownames of the first matrix are used. See the examples. \code{as.matrix} may be used to convert DNA sequences (of the same length) stored in a list into a matrix while keeping the names and the class. \code{as.list} does the reverse operation. } \value{ an object of class \code{"DNAbin"} in the case of \code{rbind}, \code{cbind}, and \code{[}. } \references{ Paradis, E. (2007) A Bit-Level Coding Scheme for Nucleotides. \url{http://ape-package.ird.fr/misc/BitLevelCodingScheme_20April2007.pdf} Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{as.DNAbin}}, \code{\link{read.dna}}, \code{\link{read.GenBank}}, \code{\link{write.dna}}, \code{\link{image.DNAbin}},\code{\link{AAbin}} The corresponding generic functions are documented in the package \pkg{base}. } \examples{ data(woodmouse) woodmouse print(woodmouse, 15, 6) print(woodmouse[1:5, 1:300], 15, 6) ### Just to show how distances could be influenced by sampling: dist.dna(woodmouse[1:2, ]) dist.dna(woodmouse[1:3, ]) ### cbind and its options: x <- woodmouse[1:2, 1:5] y <- woodmouse[2:4, 6:10] as.character(cbind(x, y)) # gives warning as.character(cbind(x, y, fill.with.gaps = TRUE)) \dontrun{ as.character(cbind(x, y, check.names = FALSE)) # gives an error } } \keyword{manip} ape/man/cophyloplot.Rd0000644000176200001440000000731714164530562014453 0ustar liggesusers\name{cophyloplot} \alias{cophyloplot} \title{Plots two phylogenetic trees face to face with links between the tips.} \description{ This function plots two trees face to face with the links if specified. It is possible to rotate the branches of each tree around the nodes by clicking. } \usage{ cophyloplot(x, y, assoc = NULL, use.edge.length = FALSE, space = 0, length.line = 1, gap = 2, type = "phylogram", rotate = FALSE, col = par("fg"), lwd = par("lwd"), lty = par("lty"), show.tip.label = TRUE, font = 3, \dots) } \arguments{ \item{x, y}{two objects of class \code{"phylo"}.} \item{assoc}{a matrix with 2 columns specifying the associations between the tips. If NULL, no links will be drawn.} \item{use.edge.length}{a logical indicating whether the branch lengths should be used to plot the trees; default is FALSE.} \item{space}{a positive value that specifies the distance between the two trees.} \item{length.line}{a positive value that specifies the length of the horizontal line associated to each taxa. Default is 1.} \item{gap}{a value specifying the distance between the tips of the phylogeny and the lines.} \item{type}{a character string specifying the type of phylogeny to be drawn; it must be one of "phylogram" (the default) or "cladogram".} \item{rotate}{a logical indicating whether the nodes of the phylogeny can be rotated by clicking. Default is FALSE.} \item{col}{a character vector indicating the color to be used for the links; recycled as necessary.} \item{lwd}{id. for the width.} \item{lty}{id. for the line type.} \item{show.tip.label}{a logical indicating whether to show the tip labels on the phylogeny (defaults to 'TRUE', i.e. the labels are shown).} \item{font}{an integer specifying the type of font for the labels: 1 (plain text), 2 (bold), 3 (italic, the default), or 4 (bold italic).} \item{\dots}{(unused)} } \details{ The aim of this function is to plot simultaneously two phylogenetic trees with associated taxa. The two trees do not necessarily have the same number of tips and more than one tip in one phylogeny can be associated with a tip in the other. The association matrix used to draw the links has to be a matrix with two columns containing the names of the tips. One line in the matrix represents one link on the plot. The first column of the matrix has to contain tip labels of the first tree (\code{phy1}) and the second column of the matrix, tip labels of the second tree (\code{phy2}). There is no limit (low or high) for the number of lines in the matrix. A matrix with two colums and one line will give a plot with one link. Arguments \code{gap}, \code{length.line} and \code{space} have to be changed to get a nice plot of the two phylogenies. Note that the function takes into account the length of the character strings corresponding to the names at the tips, so that the lines do not overwrite those names. The \code{rotate} argument can be used to transform both phylogenies in order to get the more readable plot (typically by decreasing the number of crossing lines). This can be done by clicking on the nodes. The escape button or right click take back to the console. } \author{Damien de Vienne \email{damien.de-vienne@u-psud.fr}} \seealso{ \code{\link{plot.phylo}}, \code{\link{rotate}}, \code{\link{rotateConstr}} } \examples{ #two random trees tree1 <- rtree(40) tree2 <- rtree(20) #creation of the association matrix: association <- cbind(tree2$tip.label, tree2$tip.label) cophyloplot(tree1, tree2, assoc = association, length.line = 4, space = 28, gap = 3) #plot with rotations \dontrun{ cophyloplot(tree1, tree2, assoc=association, length.line=4, space=28, gap=3, rotate=TRUE) } } \keyword{hplot} ape/man/mrca.Rd0000644000176200001440000000222014164530562013005 0ustar liggesusers\name{mrca} \alias{mrca} \alias{getMRCA} \title{Find Most Recent Common Ancestors Between Pairs} \description{ \code{mrca} returns for each pair of tips (and nodes) its most recent common ancestor (MRCA). \code{getMRCA} returns the MRCA of two or more tips. } \usage{ mrca(phy, full = FALSE) getMRCA(phy, tip) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{full}{a logical indicating whether to return the MRCAs among all tips and nodes (if \code{TRUE}); the default is to return only the MRCAs among tips.} \item{tip}{a vector of mode numeric or character specifying the tips; can also be node numbers.} } \details{ For \code{mrca}, the diagonal is set to the number of the tips (and nodes if \code{full = TRUE}). If \code{full = FALSE}, the colnames and rownames are set with the tip labels of the tree; otherwise the numbers are given as names. For \code{getMRCA}, if \code{tip} is of length one or zero then \code{NULL} is returned. } \value{ a matrix of mode numeric (\code{mrca}) or a single numeric value (\code{getMRCA}). } \author{Emmanuel Paradis, Klaus Schliep, Joseph W. Brown} \keyword{manip} ape/man/fastme.Rd0000644000176200001440000000333314164530562013350 0ustar liggesusers\name{FastME} \alias{FastME} \alias{fastme} \alias{fastme.bal} \alias{fastme.ols} \title{ Tree Estimation Based on the Minimum Evolution Algorithm } \description{ The two FastME functions (balanced and OLS) perform the minimum evolution algorithm of Desper and Gascuel (2002). } \usage{ fastme.bal(X, nni = TRUE, spr = TRUE, tbr = FALSE) fastme.ols(X, nni = TRUE) } \arguments{ \item{X}{a distance matrix; may be an object of class \code{"dist"}.} \item{nni}{a logical value; TRUE to perform NNIs (default).} \item{spr}{ditto for SPRs.} \item{tbr}{ignored (see details).} } \details{ The code to perform topology searches based on TBR (tree bisection and reconnection) did not run correctly and has been removed after the release of \pkg{ape} 5.3. A warning is issued if \code{tbr = TRUE}. } \value{ an object of class \code{"phylo"}. } \references{ Desper, R. and Gascuel, O. (2002) Fast and accurate phylogeny reconstruction algorithms based on the minimum-evolution principle. \emph{Journal of Computational Biology}, \bold{9}, 687--705. } \author{ original C code by Richard Desper; adapted and ported to R by Vincent Lefort \email{vincent.lefort@lirmm.fr} } \seealso{ \code{\link{nj}}, \code{\link{bionj}}, \code{\link{write.tree}}, \code{\link{read.tree}}, \code{\link{dist.dna}} } \examples{ ### From Saitou and Nei (1987, Table 1): x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13, 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12, 5, 6, 10, 9, 13, 8) M <- matrix(0, 8, 8) M[lower.tri(M)] <- x M <- t(M) M[lower.tri(M)] <- x dimnames(M) <- list(1:8, 1:8) tr <- fastme.bal(M) plot(tr, "u") ### a less theoretical example data(woodmouse) trw <- fastme.bal(dist.dna(woodmouse)) plot(trw) } \keyword{models} ape/man/SDM.Rd0000644000176200001440000000264414164530562012520 0ustar liggesusers\name{SDM} \alias{SDM} \title{Construction of Consensus Distance Matrix With SDM} \description{ This function implements the SDM method of Criscuolo et al. (2006) for a set of n distance matrices. } \usage{ SDM(...) } \arguments{ \item{\dots}{2n elements (with n > 1), the first n elements are the distance matrices: these can be (symmetric) matrices, objects of class \code{"dist"}, or a mix of both. The next n elements are the sequence length from which the matrices have been estimated (can be seen as a degree of confidence in matrices).} } \details{ Reconstructs a consensus distance matrix from a set of input distance matrices on overlapping sets of taxa. Potentially missing values in the supermatrix are represented by \code{NA}. An error is returned if the input distance matrices can not resolve to a consensus matrix. } \value{ a 2-element list containing a distance matrix labelled by the union of the set of taxa of the input distance matrices, and a variance matrix associated to the returned distance matrix. } \references{ Criscuolo, A., Berry, V., Douzery, E. J. P. , and Gascuel, O. (2006) SDM: A fast distance-based approach for (super)tree building in phylogenomics. \emph{Systematic Biology}, \bold{55}, 740--755. } \author{Andrei Popescu} \seealso{ \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}}, \code{\link{mvrs}}, \code{\link{triangMtd}} } \keyword{models} ape/man/def.Rd0000644000176200001440000000420114164530562012622 0ustar liggesusers\name{def} \alias{def} \title{Definition of Vectors for Plotting or Annotating} \description{ This function can be used to define vectors to annotate a set of taxon names, labels, etc. It should facilitate the (re)definition of colours or similar attributes for plotting trees or other graphics. } \usage{ def(x, ..., default = NULL, regexp = FALSE) } \arguments{ \item{x}{a vector of mode character.} \item{\dots}{a series of statements defining the attributes.} \item{default}{the default to be used (see details).} \item{regexp}{a logical value specifying whether the statements defined in \code{\dots} should be taken as regular expressions.} } \details{ The idea of this function is to make the definition of colours, etc., simpler than what is done usually. A typical use is: \code{def(tr$tip.label, Homo_sapiens = "blue")} which will return a vector of character strings all "black" except one matching the tip label "Homo_sapiens" which will be "blue". Another use could be: \code{def(tr$tip.label, Homo_sapiens = 2)} which will return a vector a numerical values all 1 except for "Homo_sapiens" which will be 2. Several definitions can be done, e.g.: \code{def(tr$tip.label, Homo_sapiens = "blue", Pan_paniscus = "red")} The default value is determined with respect to the mode of the values given with the \code{\dots} (either "black" or 1). If \code{regexp = TRUE} is used, then the names of the statements must be quoted, e.g.: \code{def(tr$tip.label, "^Pan_" = "red", regexp = TRUE)} will return "red" for all labels starting with "Pan_". } \value{ a vector of the same length than \code{x}. } \author{Emmanuel Paradis} \examples{ data(bird.orders) a <- def(bird.orders$tip.label, Galliformes = 2) str(a) # numeric plot(bird.orders, font = a) co <- def(bird.orders$tip.label, Passeriformes = "red", Trogoniformes = "blue") str(co) # character plot(bird.orders, tip.color = co) ### use of a regexp (so we need to quote it) to colour all orders ### with names starting with "C" (and change the default): co2 <- def(bird.orders$tip.label, "^C" = "gold", default = "grey", regexp = TRUE) plot(bird.orders, tip.color = co2) } \keyword{manip} ape/man/plot.phyloExtra.Rd0000644000176200001440000000326714164530562015213 0ustar liggesusers\name{plot.phylo.extra} \alias{plot.phylo.extra} \alias{plotBreakLongEdges} \alias{drawSupportOnEdges} \title{Extra Fuctions to Plot and Annotate Phylogenies} \description{ These are extra functions to plot and annotate phylogenies, mostly calling basic graphical functions in \pkg{ape}. } \usage{ plotBreakLongEdges(phy, n = 1, ...) drawSupportOnEdges(value, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{n}{the numner of long branches to be broken.} \item{value}{the values to be printed on the internal branches of the tree.} \item{\dots}{further arguments to be passed to \code{plot.phylo} or to \code{edgelabels}.} } \details{ \code{drawSupportOnEdges} assumes the tree is unrooted, so the vector \code{value} should have as many values than the number of internal branches (= number of nodes - 1). If there is one additional value, it is assumed that it relates to the root node and is dropped (see examples). } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{edgelabels}}, \code{\link{boot.phylo}}, \code{\link{plotTreeTime}} } \examples{ tr <- rtree(10) tr$edge.length[c(1, 18)] <- 100 op <- par(mfcol = 1:2) plot(tr); axisPhylo() plotBreakLongEdges(tr, 2); axisPhylo() ## from ?boot.phylo: f <- function(x) nj(dist.dna(x)) data(woodmouse) tw <- f(woodmouse) # NJ tree with K80 distance set.seed(1) ## bootstrap with 100 replications: (bp <- boot.phylo(tw, woodmouse, f, quiet = TRUE)) ## the first value relates to the root node and is always 100 ## it is ignored below: plot(tw, "u") drawSupportOnEdges(bp) ## more readable but the tree is really unrooted: plot(tw) drawSupportOnEdges(bp) par(op) } \keyword{hplot} ape/man/summary.phylo.Rd0000644000176200001440000000405514164530562014722 0ustar liggesusers\name{summary.phylo} \alias{summary.phylo} \alias{Ntip} \alias{Ntip.phylo} \alias{Ntip.multiPhylo} \alias{Nnode} \alias{Nnode.phylo} \alias{Nnode.multiPhylo} \alias{Nedge} \alias{Nedge.phylo} \alias{Nedge.multiPhylo} \title{Print Summary of a Phylogeny} \usage{ \method{summary}{phylo}(object, \dots) Ntip(phy) \method{Ntip}{phylo}(phy) \method{Ntip}{multiPhylo}(phy) Nnode(phy, ...) \method{Nnode}{phylo}(phy, internal.only = TRUE, ...) \method{Nnode}{multiPhylo}(phy, internal.only = TRUE, ...) Nedge(phy) \method{Nedge}{phylo}(phy) \method{Nedge}{multiPhylo}(phy) } \arguments{ \item{object, phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{\dots}{further arguments passed to or from other methods.} \item{internal.only}{a logical indicating whether to return the number of internal nodes only (the default), or of internal and terminal (tips) nodes (if \code{FALSE}).} } \description{ The first function prints a compact summary of a phylogenetic tree (an object of class \code{"phylo"}). The three other functions return the number of tips, nodes, or edges, respectively. } \details{ The summary includes the numbers of tips and of nodes, summary statistics of the branch lengths (if they are available) with mean, variance, minimum, first quartile, median, third quartile, and maximum, listing of the first ten tip labels, and (if available) of the first ten node labels. It is also printed whether some of these optional elements (branch lengths, node labels, and root edge) are not found in the tree. \code{summary} simply prints its results on the standard output and is not meant for programming. } \value{ A NULL value in the case of \code{summary}, a single numeric value for the three other functions. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link[base]{summary}} for the generic R function, \code{\link{multiphylo}}, \code{\link{c.phylo}} } \examples{ data(bird.families) summary(bird.families) Ntip(bird.families) Nnode(bird.families) Nedge(bird.families) } \keyword{manip} ape/man/which.edge.Rd0000644000176200001440000000155314164530562014100 0ustar liggesusers\name{which.edge} \alias{which.edge} \title{Identifies Edges of a Tree} \description{ This function identifies the edges that belong to a group (possibly non-monophyletic) specified as a set of tips. } \usage{ which.edge(phy, group) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{group}{a vector of mode numeric or character specifying the tips for which the edges are to be identified.} } \details{ The group of tips specified in `group' may be non-monophyletic (paraphyletic or polyphyletic), in which case all edges from the tips to their most recent common ancestor are identified. The identification is made with the indices of the rows of the matrix `edge' of the tree. } \value{ a numeric vector. } \author{Emmanuel Paradis} \seealso{ \code{\link{bind.tree}}, \code{\link{drop.tip}}, \code{\link{root}} } \keyword{manip} ape/man/vcv.phylo.Rd0000644000176200001440000000346014164530562014022 0ustar liggesusers\name{vcv} \alias{vcv} \alias{vcv.phylo} \alias{vcv.corPhyl} \title{Phylogenetic Variance-covariance or Correlation Matrix} \usage{ vcv(phy, ...) \method{vcv}{phylo}(phy, model = "Brownian", corr = FALSE, ...) \method{vcv}{corPhyl}(phy, corr = FALSE, ...) } \arguments{ \item{phy}{an object of the correct class (see above).} \item{model}{a character giving the model used to compute the variances and covariances; only \code{"Brownian"} is available (for other models, a correlation structure may be used).} \item{corr}{a logical indicating whether the correlation matrix should be returned (\code{TRUE}); by default the variance-covariance matrix is returned (\code{FALSE}).} \item{\dots}{further arguments to be passed to or from other methods.} } \description{ This function computes the expected variances and covariances of a continuous trait assuming it evolves under a given model. This is a generic function with methods for objects of class \code{"phylo"} and \code{"corPhyl"}. } \value{ a numeric matrix with the names of the tips as colnames and rownames. } \references{ Garland, T. Jr. and Ives, A. R. (2000) Using the past to predict the present: confidence intervals for regression equations in phylogenetic comparative methods. \emph{American Naturalist}, \bold{155}, 346--364. } \author{Emmanuel Paradis} \note{ Do not confuse this function with \code{\link[stats]{vcov}} which computes the variance-covariance matrix among parameters of a fitted model object. } \seealso{ \code{\link{corBrownian}}, \code{\link{corMartins}}, \code{\link{corGrafen}}, \code{\link{corPagel}}, \code{\link{corBlomberg}}, \code{\link{vcv2phylo}} } \examples{ tr <- rtree(5) ## all are the same: vcv(tr) vcv(corBrownian(1, tr)) vcv(corPagel(1, tr)) } \keyword{manip} \keyword{multivariate} ape/man/getAnnotationsGenBank.Rd0000644000176200001440000000402014164530562016306 0ustar liggesusers\name{getAnnotationsGenBank} \alias{getAnnotationsGenBank} \title{Read Annotations from GenBank} \description{ This function connects to the GenBank database and reads sequence annotations using accession number(s) given as argument. } \usage{ getAnnotationsGenBank(access.nb, quiet = TRUE) } \arguments{ \item{access.nb}{a vector of mode character giving the accession numbers.} \item{quiet}{a logical value indicating whether to show the progress of the downloads.} } \details{ The sequence annotations (a.k.a. feature list) are returned in a data frame with five or six columns: start, end, type, product, others, and gene (the last being optional). This is the same information that can be downloaded from NCBI's Web interface by clicking on `Send to:', `File', and then selecting `Feature Table' under `Format'. A warning is given if some features are incomplete (this information is then dropped from the returned object). A warning is given if some accession numbers are not found on GenBank. } \value{ On of the followings: (i) a data frame if \code{access.nb} contains a single accession number; (ii) a list of data frames if \code{access.nb} contains several accession numbers, the names are set with \code{access.nb} (if some accession numbers are not found on GenBank, the corresponding entries are set to \code{NULL}); (iii) \code{NULL} if all accession numbers are not found on GenBank. } \seealso{\code{\link{read.GenBank}}, \code{\link{read.gff}}, \code{\link{DNAbin}} } \author{Emmanuel Paradis} \references{https://www.ncbi.nlm.nih.gov/Sequin/table.html (Note: it seems this URL is broken; 2022-01-03)} \examples{ ## The 8 sequences of tanagers (Ramphocelus): ref <- c("U15717", "U15718", "U15719", "U15720", "U15721", "U15722", "U15723", "U15724") ## Copy/paste or type the following commands if you ## want to try them. \dontrun{ annot.rampho <- getAnnotationsGenBank(ref) annot.rampho ## check all annotations are the same: unique(do.call(rbind, annot.rampho)[, -5]) } } \keyword{IO} ape/man/mantel.test.Rd0000644000176200001440000000576114164530562014336 0ustar liggesusers\name{mantel.test} \alias{mantel.test} \title{Mantel Test for Similarity of Two Matrices} \description{ This function computes Mantel's permutation test for similarity of two matrices. It permutes the rows and columns of the second matrix randomly and calculates a \eqn{Z}-statistic. } \usage{ mantel.test(m1, m2, nperm = 999, graph = FALSE, alternative = "two.sided", ...) } \arguments{ \item{m1}{a numeric matrix giving a measure of pairwise distances, correlations, or similarities among observations.} \item{m2}{a second numeric matrix giving another measure of pairwise distances, correlations, or similarities among observations.} \item{nperm}{the number of times to permute the data.} \item{graph}{a logical indicating whether to produce a summary graph (by default the graph is not plotted).} \item{alternative}{a character string defining the alternative hypothesis: \code{"two.sided"} (default), \code{"less"}, \code{"greater"}, or any unambiguous abbreviation of these.} \item{\dots}{further arguments to be passed to \code{plot()} (to add a title, change the axis labels, and so on).} } \details{ The function calculates a \eqn{Z}-statistic for the Mantel test, equal to the sum of the pairwise product of the lower triangles of the permuted matrices, for each permutation of rows and columns. It compares the permuted distribution with the \eqn{Z}-statistic observed for the actual data. The present implementation can analyse symmetric as well as (since version 5.1 of \pkg{ape}) asymmetric matrices (see Mantel 1967, Sects. 4 and 5). The diagonals of both matrices are ignored. If \code{graph = TRUE}, the functions plots the density estimate of the permutation distribution along with the observed \eqn{Z}-statistic as a vertical line. The \code{\dots} argument allows the user to give further options to the \code{plot} function: the title main be changed with \code{main=}, the axis labels with \code{xlab =}, and \code{ylab =}, and so on. } \value{ \item{z.stat}{the \eqn{Z}-statistic (sum of rows*columns of lower triangle) of the data matrices.} \item{p}{\eqn{P}-value (quantile of the observed \eqn{Z}-statistic in the permutation distribution).} \item{alternative}{the alternative hypothesis.} } \references{ Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209--220. Manly, B. F. J. (1986) \emph{Multivariate statistical methods: a primer.} London: Chapman & Hall. } \author{ Original code in S by Ben Bolker, ported to \R by Julien Claude } \examples{ q1 <- matrix(runif(36), nrow = 6) q2 <- matrix(runif(36), nrow = 6) diag(q1) <- diag(q2) <- 0 mantel.test(q1, q2, graph = TRUE, main = "Mantel test: a random example with 6 X 6 matrices representing asymmetric relationships", xlab = "z-statistic", ylab = "Density", sub = "The vertical line shows the observed z-statistic") } \keyword{multivariate} ape/man/DNAbin2indel.Rd0000644000176200001440000000137714164530562014270 0ustar liggesusers\name{DNAbin2indel} \alias{DNAbin2indel} \title{Recode Blocks of Indels} \description{ This function scans a set of aligned DNA sequences and returns a matrix with information of the localisations and lengths on alignment gaps. } \usage{ DNAbin2indel(x) } \arguments{ \item{x}{an object of class \code{"DNAbin"}.} } \details{ The output matrix has the same dimensions than the input one with, either a numeric value where an alignment gap starts giving the length of the gap, or zero. The rownames are kept. } \value{ a numeric matrix. } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{as.DNAbin}}, \code{\link{del.gaps}}, \code{\link{seg.sites}}, \code{\link{image.DNAbin}}, \code{\link{checkAlignment}} } \keyword{manip} ape/man/reconstruct.Rd0000644000176200001440000001072214164530562014444 0ustar liggesusers\name{reconstruct} \alias{reconstruct} \title{Continuous Ancestral Character Estimation} \description{ This function estimates ancestral character states, and the associated uncertainty, for continuous characters. It mainly works as the ace function, from which it differs, first, in the fact that computations are not performed by numerical optimisation but through matrix calculus. Second, besides classical Brownian-based reconstruction methods, it reconstructs ancestral states under Arithmetic Brownian Motion (ABM, i.e. Brownian with linear trend) and Ornstein-Uhlenbeck process (OU, i.e. Brownian with an attractive optimum). } \usage{ reconstruct(x, phyInit, method = "ML", alpha = NULL, CI = TRUE) } \arguments{ \item{x}{a numerical vector.} \item{phyInit}{an object of class \code{"phylo"}.} \item{method}{a character specifying the method used for estimation. Six choices are possible: \code{"ML"}, \code{"REML"}, \code{"GLS"}, \code{"GLS_ABM"}, \code{"GLS_OU"} or \code{"GLS_OUS"}.} \item{alpha}{a numerical value which accounts for the attractive strength parameter of \code{"GLS_OU"} or \code{"GLS_OUS"} (used only in these cases). If alpha = NULL (the default), then it is estimated by maximum likelihood using \code{optim} which may lead to convergence issue.} \item{CI}{a logical specifying whether to return the 95\% confidence intervals of the ancestral state estimates.} } \details{ For \code{"ML"}, \code{"REML"} and \code{"GLS"}, the default model is Brownian motion. This model can be fitted by maximum likelihood (\code{method = "ML"}, Felsenstein 1973, Schluter et al. 1997) - the default, residual maximum likelihood (\code{method = "REML"}), or generalized least squares (\code{method = "GLS"}, Martins and Hansen 1997, Garland T and Ives AR 2000). \code{"GLS_ABM"} is based on Brownian motion with trend model. Both \code{"GLS_OU"} and \code{"GLS_OUS"} are based on Ornstein-Uhlenbeck model. \code{"GLS_OU"} and \code{"GLS_OUS"} differs in the fact that \code{"GLS_OUS"} assume that the process starts from the optimum, while the root state has to be estimated for \code{"GLS_OU"}, which may rise some issues (see Royer-Carenzi and Didier, 2016). Users may provide the attractive strength parameter \code{alpha}, for these two models. \code{"GLS_ABM"}, \code{"GLS_OU"} and \code{"GLS_OUS"} are all fitted by generalized least squares (Royer-Carenzi and Didier, 2016). } \value{ an object of class \code{"ace"} with the following elements: \item{ace}{the estimates of the ancestral character values.} \item{CI95}{the estimated 95\% confidence intervals.} \item{sigma2}{if \code{method = "ML"}, the maximum likelihood estimate of the Brownian parameter.} \item{loglik}{if \code{method = "ML"}, the maximum log-likelihood.} } \references{ Felsenstein, J. (1973) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, \bold{25}, 471--492. Garland T. and Ives A.R. (2000) Using the past to predict the present: confidence intervals for regression equations in phylogenetic comparative methods. \emph{American Naturalist}, \bold{155}, 346--364. Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative method: a general approach to incorporating phylogenetic information into the analysis of interspecific data. \emph{American Naturalist}, \bold{149}, 646--667. Royer-Carenzi, M. and Didier, G. (2016) A comparison of ancestral state reconstruction methods for quantitative characters. \emph{Journal of Theoretical Biology}, \bold{404}, 126--142. Schluter, D., Price, T., Mooers, A. O. and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution}, \bold{51}, 1699--1711. Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford: Oxford University Press. } \author{Manuela Royer-Carenzi, Gilles Didier} \seealso{ \code{\link{MPR}}, \code{\link{corBrownian}}, \code{\link{compar.ou}} Reconstruction of ancestral sequences can be done with the package \pkg{phangorn} (see function \code{?ancestral.pml}). } \note{ \code{GLS_ABM} should not be used on ultrametric tree. \code{GLS_OU} may lead to aberrant reconstructions. } \examples{ ### Some random data... data(bird.orders) x <- rnorm(23, m=100) ### Reconstruct ancestral quantitative characters: reconstruct(x, bird.orders) reconstruct(x, bird.orders, method = "GLS_OUS", alpha=NULL) } \keyword{models} ape/man/ewLasso.Rd0000644000176200001440000000366114164530562013512 0ustar liggesusers\name{ewLasso} \alias{ewLasso} \title{ Incomplete distances and edge weights of unrooted topology } \description{ This function implements a method for checking whether an incomplete set of distances satisfy certain conditions that might make it uniquely determine the edge weights of a given topology, T. It prints information about whether the graph with vertex set the set of leaves, denoted by X, and edge set the set of non-missing distance pairs, denoted by L, is connected or strongly non-bipartite. It then also checks whether L is a triplet cover for T. } \usage{ ewLasso(X, phy) } \arguments{ \item{X}{a distance matrix.} \item{phy}{an unrooted tree of class \code{"phylo"}.} } \details{ Missing values must be represented by either \code{NA} or a negative value. This implements a method for checking whether an incomplete set of distances satisfies certain conditions that might make it uniquely determine the edge weights of a given topology, T. It prints information about whether the graph, G, with vertex set the set of leaves, denoted by X, and edge set the set of non-missing distance pairs, denoted by L, is connected or strongly non-bipartite. It also checks whether L is a triplet cover for T. If G is not connected, then T does not need to be the only topology satisfying the input incomplete distances. If G is not strongly non-bipartite then the edge-weights of the edges of T are not the unique ones for which the input distance is satisfied. If L is a triplet cover, then the input distance matrix uniquely determines the edge weights of T. See Dress et al. (2012) for details. } \value{ NULL, the results are printed in the console. } \references{ Dress, A. W. M., Huber, K. T., and Steel, M. (2012) `Lassoing' a phylogentic tree I: basic properties, shellings and covers. \emph{Journal of Mathematical Biology}, \bold{65(1)}, 77--105. } \author{Andrei Popescu} \keyword{multivariate} ape/man/root.Rd0000644000176200001440000001064214164530562013055 0ustar liggesusers\name{root} \alias{root} \alias{root.phylo} \alias{root.multiPhylo} \alias{unroot} \alias{unroot.phylo} \alias{unroot.multiPhylo} \alias{is.rooted} \alias{is.rooted.phylo} \alias{is.rooted.multiPhylo} \title{Roots Phylogenetic Trees} \description{ \code{root} reroots a phylogenetic tree with respect to the specified outgroup or at the node specified in \code{node}. \code{unroot} unroots a phylogenetic tree, or returns it unchanged if it is already unrooted. \code{is.rooted} tests whether a tree is rooted. } \usage{ root(phy, ...) \method{root}{phylo}(phy, outgroup, node = NULL, resolve.root = FALSE, interactive = FALSE, edgelabel = FALSE, ...) \method{root}{multiPhylo}(phy, outgroup, ...) unroot(phy) \method{unroot}{phylo}(phy) \method{unroot}{multiPhylo}(phy) is.rooted(phy) \method{is.rooted}{phylo}(phy) \method{is.rooted}{multiPhylo}(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{outgroup}{a vector of mode numeric or character specifying the new outgroup.} \item{node}{alternatively, a node number where to root the tree.} \item{resolve.root}{a logical specifying whether to resolve the new root as a bifurcating node.} \item{interactive}{if \code{TRUE} the user is asked to select the node by clicking on the tree which must be plotted.} \item{edgelabel}{a logical value specifying whether to treat node labels as edge labels and thus eventually switching them so that they are associated with the correct edges when using \code{\link{drawSupportOnEdges}} (see Czech et al. 2016).} \item{\dots}{arguments passed among methods (e.g., when rooting lists of trees).} } \details{ The argument \code{outgroup} can be either character or numeric. In the first case, it gives the labels of the tips of the new outgroup; in the second case the numbers of these labels in the vector \code{phy$tip.label} are given. If \code{outgroup} is of length one (i.e., a single value), then the tree is rerooted using the node below this tip as the new root. If \code{outgroup} is of length two or more, the most recent common ancestor (MRCA) \emph{of the ingroup} is used as the new root. Note that the tree is unrooted before being rerooted, so that if \code{outgroup} is already the outgroup, then the returned tree is not the same than the original one (see examples). If \code{outgroup} is not monophyletic, the operation fails and an error message is issued. If \code{resolve.root = TRUE}, \code{root} adds a zero-length branch below the MRCA of the ingroup. A tree is considered rooted if either only two branches connect to the root, or if there is a \code{root.edge} element. In all other cases, \code{is.rooted} returns \code{FALSE}. } \note{ The use of \code{resolve.root = TRUE} together with \code{node = } gives an error if the specified node is the current root of the tree. This is because there is an ambiguity when resolving a node in an unrooted tree with no explicit outgroup. If the node is not the current root, the ambiguity is solved arbitrarily by considering the clade on the right of \code{node} (when the tree is plotted by default) as the ingroup. See a detailed explanation there: \url{https://www.mail-archive.com/r-sig-phylo@r-project.org/msg03805.html}. } \value{ an object of class \code{"phylo"} or \code{"multiPhylo"} for \code{root} and \code{unroot}; a logical vector for \code{is.rooted}. } \references{ Czech, L., Huerta-Cepas, J. and Stamatakis, A. (2017) A critical review on the use of support values in tree viewers and bioinformatics toolkits. \emph{Molecular Biology and Evolution}, \bold{34}, 1535--1542. \doi{10.1093/molbev/msx055} } \author{Emmanuel Paradis} \seealso{ \code{\link{bind.tree}}, \code{\link{drop.tip}}, \code{\link{nodelabels}}, \code{\link{identify.phylo}} } \examples{ data(bird.orders) plot(root(bird.orders, 1)) plot(root(bird.orders, 1:5)) tr <- root(bird.orders, 1) is.rooted(bird.orders) # yes is.rooted(tr) # no ### This is because the tree has been unrooted first before rerooting. ### You can delete the outgroup... is.rooted(drop.tip(tr, "Struthioniformes")) ### ... or resolve the basal trichotomy in two ways: is.rooted(multi2di(tr)) is.rooted(root(bird.orders, 1, r = TRUE)) ### To keep the basal trichotomy but forcing the tree as rooted: tr$root.edge <- 0 is.rooted(tr) x <- setNames(rmtree(10, 10), LETTERS[1:10]) is.rooted(x) } \keyword{manip} ape/man/chiroptera.Rd0000644000176200001440000000136614164530562014235 0ustar liggesusers\name{chiroptera} \alias{chiroptera} \title{Bat Phylogeny} \description{ This phylogeny of bats (Mammalia: Chiroptera) is a supertree (i.e. a composite phylogeny constructed from several sources; see source for details). } \usage{ data(chiroptera) } \format{ The data are stored in RData (binary) format. } \source{ Jones, K. E., Purvis, A., MacLarnon, A., Bininda-Emonds, O. R. P. and Simmons, N. B. (2002) A phylogenetic supertree of the bats (Mammalia: Chiroptera). \emph{Biological Reviews of the Cambridge Philosophical Society}, \bold{77}, 223--259. } \seealso{ \code{\link{read.nexus}}, \code{\link{zoom}} } \examples{ data(chiroptera) str(chiroptera) op <- par(cex = 0.3) plot(chiroptera, type = "c") par(op) } \keyword{datasets} ape/man/all.equal.DNAbin.Rd0000644000176200001440000000420214164530562015035 0ustar liggesusers\name{all.equal.DNAbin} \alias{all.equal.DNAbin} \title{Compare DNA Sets} \description{ Comparison of DNA sequence sets, particularly when aligned. } \usage{ \method{all.equal}{DNAbin}(target, current, plot = FALSE, ...) } \arguments{ \item{target, current}{the two sets of sequences to be compared.} \item{plot}{a logical value specifying whether to plot the sites that are different (only if the labels of both alignments are the same).} \item{\dots}{further arguments passed to \code{\link{image.DNAbin}}.} } \details{ If the two sets of DNA sequences are exactly identical, this function returns \code{TRUE}. Otherwise, a detailed comparison is made only if the labels (i.e., rownames) of \code{target} and \code{current} are the same (possibly in different orders). In all other cases, a brief description of the differences is returned (sometimes with recommendations to make further comparisons). This function can be used for testing in programs using \code{\link[base]{isTRUE}} (see examples below). } \value{ \code{TRUE} if the two sets are identical; a list with two elements (message and different.sites) if a detailed comparison is done; or a vector of mode character. } \author{Emmanuel Paradis} \seealso{ \code{\link{image.DNAbin}}, \code{\link{clustal}}, \code{\link{checkAlignment}}, the generic function: \code{\link[base]{all.equal}} } \examples{ data(woodmouse) woodm2 <- woodmouse woodm2[1, c(1:5, 10:12, 30:40)] <- as.DNAbin("g") res <- all.equal(woodmouse, woodm2, plot = TRUE) str(res) ## if used for testing in R programs: isTRUE(all.equal(woodmouse, woodmouse)) # TRUE isTRUE(all.equal(woodmouse, woodm2)) # FALSE all.equal(woodmouse, woodmouse[15:1, ]) all.equal(woodmouse, woodmouse[-1, ]) all.equal(woodmouse, woodmouse[, -1]) \dontrun{ ## To run the followings you need internet and Clustal and MUSCLE ## correctly installed. ## Data from Johnson et al. (2006, Science) refs <- paste("DQ082", 505:545, sep = "") DNA <- read.GenBank(refs) DNA.clustal <- clustal(DNA) DNA.muscle <- muscle(DNA) isTRUE(all.equal(DNA.clustal, DNA.muscle)) # FALSE all.equal(DNA.clustal, DNA.muscle, TRUE) } } \keyword{manip} ape/man/degree.Rd0000644000176200001440000000336014164530562013324 0ustar liggesusers\name{degree} \alias{degree} \alias{degree.phylo} \alias{degree.evonet} \title{Vertex Degrees in Trees and Networks} \description{ \code{degree} is a generic function to calculate the degree of all nodes in a tree or in a network. } \usage{ degree(x, ...) \method{degree}{phylo}(x, details = FALSE, ...) \method{degree}{evonet}(x, details = FALSE, ...) } \arguments{ \item{x}{an object (tree, network, \dots).} \item{details}{whether to return the degree of each node in the tree, or a summary table (the default).} \item{\dots}{arguments passed to methods.} } \details{ The degree of a node (or vertex) in a network is defined by the number of branches (or edges) that connect to this node. In a phylogenetic tree, the tips (or terminal nodes) are of degree one, and the (internal) nodes are of degree two or more. There are currently two methods for the classes \code{"phylo"} and \code{"evonet"}. The default of these functions is to return a summary table with the degrees observed in the tree or network in the first column, and the number of nodes in the second column. If \code{details = TRUE}, a vector giving the degree of each node (as numbered in the \code{edge} matrix) is returned. The validity of the object is not checked, so \code{degree} can be used to check problems with badly conformed trees. } \value{ a data frame if \code{details = FALSE}, or a vector of integers otherwise. } \author{Emmanuel Paradis} \seealso{\code{\link{checkValidPhylo}}} \examples{ data(bird.orders) degree(bird.orders) degree(bird.orders, details = TRUE) data(bird.families) degree(bird.families) degree(rtree(10)) # 10, 1, 8 degree(rtree(10, rooted = FALSE)) # 10, 0, 8 degree(stree(10)) # 10 + 1 node of degree 10 } \keyword{manip} ape/man/consensus.Rd0000644000176200001440000000303714164530562014112 0ustar liggesusers\name{consensus} \alias{consensus} \title{Concensus Trees} \usage{ consensus(..., p = 1, check.labels = TRUE, rooted = FALSE) } \arguments{ \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a series of such objects separated by commas, or (iii) a list containing such objects.} \item{p}{a numeric value between 0.5 and 1 giving the proportion for a clade to be represented in the consensus tree.} \item{check.labels}{a logical specifying whether to check the labels of each tree. If \code{FALSE} (the default), it is assumed that all trees have the same tip labels, and that they are in the same order (see details).} \item{rooted}{a logical specifying whether the trees should be treated as rooted or not.} } \description{ Given a series of trees, this function returns the consensus tree. By default, the strict-consensus tree is computed. To get the majority-rule consensus tree, use \code{p = 0.5}. Any value between 0.5 and 1 can be used. } \details{ Using \code{check.labels = FALSE} results in considerable decrease in computing times. This requires that all trees have the same tip labels, \emph{and} these labels are ordered similarly in all trees (in other words, the element \code{tip.label} are identical in all trees). } \value{ an object of class \code{"phylo"}. } \references{ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sunderland: Sinauer Associates. } \author{Emmanuel Paradis} \seealso{ \code{\link{prop.part}}, \code{\link{dist.topo}} } \keyword{manip} ape/man/bird.families.Rd0000644000176200001440000000253214164530562014601 0ustar liggesusers\name{bird.families} \alias{bird.families} \title{Phylogeny of the Families of Birds From Sibley and Ahlquist} \description{ This data set describes the phylogenetic relationships of the families of birds as reported by Sibley and Ahlquist (1990). Sibley and Ahlquist inferred this phylogeny from an extensive number of DNA/DNA hybridization experiments. The ``tapestry'' reported by these two authors (more than 1000 species out of the ca. 9000 extant bird species) generated a lot of debates. The present tree is based on the relationships among families. A few families were not included in the figures in Sibley and Ahlquist, and thus are not included here as well. The branch lengths were calculated from the values of \eqn{\Delta T_{50}H}{Delta T50H} as found in Sibley and Ahlquist (1990, figs. 354, 355, 356, and 369). } \usage{ data(bird.families) } \format{ The data are stored as an object of class \code{"phylo"} which structure is described in the help page of the function \code{\link{read.tree}}. } \source{ Sibley, C. G. and Ahlquist, J. E. (1990) Phylogeny and classification of birds: a study in molecular evolution. New Haven: Yale University Press. } \seealso{ \code{\link{read.tree}}, \code{\link{bird.orders}} } \examples{ data(bird.families) op <- par(cex = 0.3) plot(bird.families) par(op) } \keyword{datasets} ape/man/woodmouse.Rd0000644000176200001440000000153514164530562014114 0ustar liggesusers\name{woodmouse} \alias{woodmouse} \title{Cytochrome b Gene Sequences of Woodmice} \description{ This is a set of 15 sequences of the mitochondrial gene cytochrome \emph{b} of the woodmouse (\emph{Apodemus sylvaticus}) which is a subset of the data analysed by Michaux et al. (2003). The full data set is available through GenBank (accession numbers AJ511877 to AJ511987). } \usage{ data(woodmouse) } \format{ An object of class \code{"DNAbin"}. } \source{ Michaux, J. R., Magnanou, E., Paradis, E., Nieberding, C. and Libois, R. (2003) Mitochondrial phylogeography of the Woodmouse (\emph{Apodemus sylvaticus}) in the Western Palearctic region. \emph{Molecular Ecology}, \bold{12}, 685--697. } \seealso{ \code{\link{read.dna}}, \code{\link{DNAbin}}, \code{\link{dist.dna}} } \examples{ data(woodmouse) str(woodmouse) } \keyword{datasets} ape/man/where.Rd0000644000176200001440000000202414164530562013177 0ustar liggesusers\name{where} \alias{where} \title{Find Patterns in DNA Sequences} \description{ This function finds patterns in a single or a set of DNA or AA sequences. } \usage{ where(x, pattern) } \arguments{ \item{x}{an object inheriting the class either \code{"DNAbin"} or \code{"AAbin"}.} \item{pattern}{a character string to be searched in \code{x}.} } \details{ If \code{x} is a vector, the function returns a single vector giving the position(s) where the pattern was found. If \code{x} is a matrix or a list, it returns a list with the positions of the pattern for each sequence. Patterns may be overlapping. For instance, if \code{pattern = "tata"} and the sequence starts with `tatata', then the output will be c(1, 3). } \value{ a vector of integers or a list of such vectors. } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{image.DNAbin}}, \code{\link{AAbin}} } \examples{ data(woodmouse) where(woodmouse, "tata") ## with AA sequences: x <- trans(woodmouse, 2) where(x, "irk") } \keyword{manip} ape/man/rotate.Rd0000644000176200001440000000673414164530562013377 0ustar liggesusers\name{rotate} \alias{rotate} \alias{rotateConstr} \title{Swapping Sister Clades} \description{ For a given node, \code{rotate} exchanges the position of two clades descending from this node. It can handle dichotomies as well as polytomies. In the latter case, two clades from the polytomy are selected for swapping. \code{rotateConstr} rotates internal branches giving a constraint on the order of the tips. } \usage{ rotate(phy, node, polytom = c(1, 2)) rotateConstr(phy, constraint) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{node}{a vector of mode numeric or character specifying the number of the node.} \item{polytom}{a vector of mode numeric and length two specifying the two clades that should be exchanged in a polytomy.} \item{constraint}{a vector of mode character specifying the order of the tips as they should appear when plotting the tree (from bottom to top).} } \details{ \code{phy} can be either rooted or unrooted, contain polytomies and lack branch lengths. In the presence of very short branch lengths it is convenient to plot the phylogenetic tree without branch lengths in order to identify the number of the node in question. \code{node} can be any of the interior nodes of a phylogenetic tree including the root node. Number of the nodes can be identified by the nodelabels function. Alternatively, you can specify a vector of length two that contains either the number or the names of two tips that coalesce in the node of interest. If the node subtends a polytomy, any two clades of the the polytomy can be chosen by polytom. On a plotted phylogeny, the clades are numbered from bottom to top and polytom is used to index the two clades one likes to swop. } \value{ an object of class \code{"phylo"}. } \author{Christoph Heibl \email{heibl@lmu.de}, Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{nodelabels}}, \code{\link{root}}, \code{\link{drop.tip}}} \examples{ # create a random tree: tre <- rtree(25) # visualize labels of internal nodes: plot(tre, use.edge.length=FALSE) nodelabels() # rotate clades around node 30: tre.new <- rotate(tre, 30) # compare the results: par(mfrow=c(1,2)) # split graphical device plot(tre) # plot old tre plot(tre.new) # plot new tree # visualize labels of terminal nodes: plot(tre) tiplabels() # rotate clades containing nodes 12 and 20: tre.new <- rotate(tre, c(12, 21)) # compare the results: par(mfrow=c(1,2)) # split graphical device plot(tre) # plot old tre plot(tre.new) # plot new tree # or you migth just specify tiplabel names: tre.new <- rotate(tre, c("t3", "t14")) # compare the results: par(mfrow=c(1,2)) # devide graphical device plot(tre) # plot old tre plot(tre.new) # plot new tree # a simple example for rotateConstr: A <- read.tree(text = "((A,B),(C,D));") B <- read.tree(text = "(((D,C),B),A);") B <- rotateConstr(B, A$tip.label) plot(A); plot(B, d = "l") # something more interesting (from ?cophyloplot): tr1 <- rtree(40) ## drop 20 randomly chosen tips: tr2 <- drop.tip(tr1, sample(tr1$tip.label, size = 20)) ## rotate the root and reorder the whole: tr2 <- rotate(tr2, 21) tr2 <- read.tree(text = write.tree(tr2)) X <- cbind(tr2$tip.label, tr2$tip.label) # association matrix cophyloplot(tr1, tr2, assoc = X, space = 28) ## before reordering tr2 we have to find the constraint: co <- tr2$tip.label[order(match(tr2$tip.label, tr1$tip.label))] newtr2 <- rotateConstr(tr2, co) cophyloplot(tr1, newtr2, assoc = X, space = 28) } \keyword{manip} ape/man/compute.brtime.Rd0000644000176200001440000000326414164530562015031 0ustar liggesusers\name{compute.brtime} \alias{compute.brtime} \title{Compute and Set Branching Times} \description{ This function computes the branch lengths of a tree giving its branching times (aka node ages or heights). } \usage{ compute.brtime(phy, method = "coalescent", force.positive = NULL) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{method}{either \code{"coalescent"} (the default), or a numeric vector giving the branching times.} \item{force.positive}{a logical value (see details).} } \details{ By default, a set of random branching times is generated from a simple coalescent, and the option \code{force.positive} is set to \code{TRUE} so that no branch length is negative. If a numeric vector is passed to \code{method}, it is taken as the branching times of the nodes with respect to their numbers (i.e., the first element of \code{method} is the branching time of the node numbered \eqn{n + 1} [= the root], the second element of the node numbered \eqn{n + 2}, and so on), so \code{force.positive} is set to \code{FALSE}. This may result in negative branch lengths. To avoid this, one should use \code{force.positive = TRUE} in which case the branching times are eventually reordered. } \value{ An object of class \code{"phylo"} with branch lengths and ultrametric. } \author{Emmanuel Paradis} \seealso{ \code{\link{compute.brlen}}, \code{\link{branching.times}} } \examples{ tr <- rtree(10) layout(matrix(1:4, 2)) plot(compute.brtime(tr)); axisPhylo() plot(compute.brtime(tr, force.positive = FALSE)); axisPhylo() plot(compute.brtime(tr, 1:9)); axisPhylo() # a bit nonsense plot(compute.brtime(tr, 1:9, TRUE)); axisPhylo() layout(1) } \keyword{manip} ape/man/chronos.Rd0000644000176200001440000001303014164530562013537 0ustar liggesusers\name{chronos} \alias{chronos} \alias{makeChronosCalib} \alias{chronos.control} \alias{print.chronos} \title{Molecular Dating by Penalised Likelihood and Maximum Likelihood} \description{ \code{chronos} is the main function fitting a chronogram to a phylogenetic tree whose branch lengths are in number of substitution per sites. \code{makeChronosCalib} is a tool to prepare data frames with the calibration points of the phylogenetic tree. \code{chronos.control} creates a list of parameters to be passed to \code{chronos}. } \usage{ chronos(phy, lambda = 1, model = "correlated", quiet = FALSE, calibration = makeChronosCalib(phy), control = chronos.control()) \method{print}{chronos}(x, ...) makeChronosCalib(phy, node = "root", age.min = 1, age.max = age.min, interactive = FALSE, soft.bounds = FALSE) chronos.control(...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{lambda}{value of the smoothing parameter.} \item{model}{a character string specifying the model of substitution rate variation among branches. The possible choices are: ``correlated'', ``relaxed'', ``discrete'', ``clock'', or an unambiguous abbreviation of these.} \item{quiet}{a logical value; by default the calculation progress are displayed.} \item{calibration}{a data frame (see details).} \item{control}{a list of parameters controlling the optimisation procedure (see details).} \item{x}{an object of class \code{c("chronos", "phylo")}.} \item{node}{a vector of integers giving the node numbers for which a calibration point is given. The default is a short-cut for the root.} \item{age.min, age.max}{vectors of numerical values giving the minimum and maximum ages of the nodes specified in \code{node}.} \item{interactive}{a logical value. If \code{TRUE}, then \code{phy} is plotted and the user is asked to click close to a node and enter the ages on the keyboard.} \item{soft.bounds}{(currently unused)} \item{\dots}{in the case of \code{chronos.control}: one of the five parameters controlling optimisation (unused in the case of \code{print.chronos}).} } \details{ \code{chronos} replaces \code{chronopl} but with a different interface and some extensions (see References). The known dates (argument \code{calibration}) must be given in a data frame with the following column names: node, age.min, age.max, and soft.bounds (the last one is yet unused). For each row, these are, respectively: the number of the node in the ``phylo'' coding standard, the minimum age for this node, the maximum age, and a logical value specifying whether the bounds are soft. If age.min = age.max, this means that the age is exactly known. This data frame can be built with \code{makeChronosCalib} which returns by default a data frame with a single row giving age = 1 for the root. The data frame can be built interactively by clicking on the plotted tree. The argument \code{control} allows one to change some parameters of the optimisation procedure. This must be a list with names. The available options with their default values are: \itemize{ \item{tol = 1e-8: }{tolerance for the estimation of the substitution rates.} \item{iter.max = 1e4: }{the maximum number of iterations at each optimization step.} \item{eval.max = 1e4: }{the maximum number of function evaluations at each optimization step.} \item{nb.rate.cat = 10: }{the number of rate categories if \code{model = "discrete"} (set this parameter to 1 to fit a strict clock model).} \item{dual.iter.max = 20: }{the maximum number of alternative iterations between rates and dates.} \item{epsilon = 1e-6: }{the convergence diagnostic criterion.} } Using \code{model = "clock"} is actually a short-cut to \code{model = "discrete"} and setting \code{nb.rate.cat = 1} in the list passed to \code{control}. The command \code{chronos.control()} returns a list with the default values of these parameters. They may be modified by passing them to this function, or directly in the list. } \value{ \code{chronos} returns an object of class \code{c("chronos", "phylo")}. There is a print method for it. There are additional attributes which can be visualised with \code{str} or extracted with \code{attr}. \code{makeChronosCalib} returns a data frame. \code{chronos.control} returns a list. } \references{ Kim, J. and Sanderson, M. J. (2008) Penalized likelihood phylogenetic inference: bridging the parsimony-likelihood gap. \emph{Systematic Biology}, \bold{57}, 665--674. Paradis, E. (2013) Molecular dating of phylogenies by likelihood methods: a comparison of models and a new information criterion. \emph{Molecular Phylogenetics and Evolution}, \bold{67}, 436--444. Sanderson, M. J. (2002) Estimating absolute rates of molecular evolution and divergence times: a penalized likelihood approach. \emph{Molecular Biology and Evolution}, \bold{19}, 101--109. } \author{Emmanuel Paradis, Santiago Claramunt, Guillaume Louvel} \seealso{\code{\link{chronoMPL}}} \examples{ library(ape) tr <- rtree(10) ### the default is the correlated rate model: chr <- chronos(tr) ### strict clock model: ctrl <- chronos.control(nb.rate.cat = 1) chr.clock <- chronos(tr, model = "discrete", control = ctrl) ### How different are the rates? attr(chr, "rates") attr(chr.clock, "rates") \dontrun{ cal <- makeChronosCalib(tr, interactive = TRUE) cal ### if you made mistakes, you can edit the data frame with: ### fix(cal) chr <- chronos(tr, calibration = cal) } } \keyword{models} ape/man/balance.Rd0000644000176200001440000000201414164530562013451 0ustar liggesusers\name{balance} \alias{balance} \title{Balance of a Dichotomous Phylogenetic Tree} \usage{ balance(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \description{ This function computes the balance of a phylogenetic tree, that is for each node of the tree the numbers of descendants (i.e. tips) on each of its daughter-branch. The tree must be fully dichotomous. } \value{ a numeric matrix with two columns and one row for each node of the tree. The columns give the numbers of descendants on each daughter-branches (the order of both columns being arbitrary). If the phylogeny \code{phy} has an element \code{node.label}, this is used as rownames for the returned matrix; otherwise the numbers (of mode character) of the matrix \code{edge} of \code{phy} are used as rownames. } \references{ Aldous, D. J. (2001) Stochastic models and descriptive statistics for phylogenetic trees, from Yule to today. \emph{Statistical Science}, \bold{16}, 23--34. } \author{Emmanuel Paradis} \keyword{manip} ape/man/node.dating.Rd0000644000176200001440000001157714164530562014274 0ustar liggesusers\name{node.dating} \alias{node.dating} \alias{estimate.mu} \alias{estimate.dates} \title{node.dating} \description{ Estimate the dates of a rooted phylogenetic tree from the tip dates. } \usage{ estimate.mu(t, node.dates, p.tol = 0.05) estimate.dates(t, node.dates, mu = estimate.mu(t, node.dates), min.date = -.Machine$double.xmax, show.steps = 0, opt.tol = 1e-8, nsteps = 1000, lik.tol = 0, is.binary = is.binary.phylo(t)) } \arguments{ \item{t}{an object of class "phylo"} \item{node.dates}{a numeric vector of dates for the tips, in the same order as 't$tip.label' or a vector of dates for all of the nodes.} \item{p.tol}{p-value cutoff for failed regression.} \item{mu}{mutation rate.} \item{min.date}{the minimum bound on the dates of nodes} \item{show.steps}{print the log likelihood every show.steps. If 0 will supress output.} \item{opt.tol}{tolerance for optimization precision.} \item{lik.tol}{tolerance for likelihood comparison.} \item{nsteps}{the maximum number of steps to run.} \item{is.binary}{if TRUE, will run a faster optimization method that only works if the tree is binary; otherwise will use optimize() as the optimization method.} } \value{ The estimated mutation rate as a numeric vector of length one for estimate.mu. The estimated dates of all of the nodes of the tree as a numeric vector with length equal to the number of nodes in the tree. } \details{ This code duplicates the functionality of the program Tip.Dates (see references). The dates of the internal nodes of 't' are estimated using a maximum likelihood approach. 't' must be rooted and have branch lengths in units of expected substitutions per site. 'node.dates' can be either a numeric vector of dates for the tips or a numeric vector for all of the nodes of 't'. 'estimate.mu' will use all of the values given in 'node.dates' to estimate the mutation rate. Dates can be censored with NA. 'node.dates' must contain all of the tip dates when it is a parameter of 'estimate.dates'. If only tip dates are given, then 'estimate.dates' will run an initial step to estimate the dates of the internal nodes. If 'node.dates' contains dates for some of the nodes, 'estimate.dates' will use those dates as priors in the inital step. If all of the dates for nodes are given, then 'estimate.dates' will not run the inital step. If 'is.binary' is set to FALSE, 'estimate.dates' uses the "optimize" function as the optimization method. By default, R's "optimize" function uses a precision of ".Machine$double.eps^0.25", which is about 0.0001 on a 64-bit system. This should be set to a smaller value if the branch lengths of 't' are very short. If 'is.binary' is set to TRUE, estimate dates uses calculus to deterimine the maximum likelihood at each step, which is faster. The bounds of permissible values are reduced by 'opt.tol'. 'estimate.dates' has several criteria to decide how many steps it will run. If 'lik.tol' and 'nsteps' are both 0, then 'estimate.dates' will only run the initial step. If 'lik.tol' is greater than 0 and 'nsteps' is 0, then 'estimate.dates' will run until the difference between successive steps is less than 'lik.tol'. If 'lik.tol' is 0 and 'nsteps' is greater than 0, then 'estimate.dates' will run the inital step and then 'nsteps' steps. If 'lik.tol' and 'nsteps' are both greater than 0, then 'estimate.dates' will run the inital step and then either 'nsteps' steps or until the difference between successive steps is less than 'lik.tol'. } \note{ This model assumes that the tree follows a molecular clock. It only performs a rudimentary statistical test of the molecular clock hypothesis. } \author{Bradley R. Jones } \references{ Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a maximum likelihood approach. \emph{Journal of Molecular Evolution}, \bold{17}, 368--376. Rambaut, A. (2000) Estimating the rate of molecular evolution: incorporating non-contemporaneous sequences into maximum likelihood phylogenies. \emph{Bioinformatics}, \bold{16}, 395--399. Jones, Bradley R., and Poon, Art F. Y. (2016) node.dating: dating ancestors in phylogenetic trees in R \emph{Bioinformatics}, \bold{33}, 932--934. } \seealso{ \code{\link[stats]{optimize}, \link{rtt}}, \code{\link{plotTreeTime}} } \examples{ t <- rtree(100) tip.date <- rnorm(t$tip.label, mean = node.depth.edgelength(t)[1:Ntip(t)])^2 t <- rtt(t, tip.date) mu <- estimate.mu(t, tip.date) ## Run for 100 steps node.date <- estimate.dates(t, tip.date, mu, nsteps = 100) ## Run until the difference between successive log likelihoods is ## less than $10^{-4}$ starting with the 100th step's results node.date <- estimate.dates(t, node.date, mu, nsteps = 0, lik.tol = 1e-4) ## To rescale the tree over time t$edge.length <- node.date[t$edge[, 2]] - node.date[t$edge[, 1]] } \keyword{model} ape/man/write.dna.Rd0000644000176200001440000001051714164530562013766 0ustar liggesusers\name{write.dna} \alias{write.dna} \alias{write.FASTA} \title{Write DNA Sequences in a File} \usage{ write.dna(x, file, format = "interleaved", append = FALSE, nbcol = 6, colsep = " ", colw = 10, indent = NULL, blocksep = 1) write.FASTA(x, file, header = NULL, append = FALSE) } \arguments{ \item{x}{a list or a matrix of DNA sequences, or of AA sequences for \code{write.FASTA}.} \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} \item{format}{a character string specifying the format of the DNA sequences. Three choices are possible: \code{"interleaved"}, \code{"sequential"}, or \code{"fasta"}, or any unambiguous abbreviation of these.} \item{append}{a logical, if \code{TRUE} the data are appended to the file without erasing the data possibly existing in the file, otherwise the file (if it exists) is overwritten (\code{FALSE} the default).} \item{nbcol}{a numeric specifying the number of columns per row (6 by default); may be negative implying that the nucleotides are printed on a single line.} \item{colsep}{a character used to separate the columns (a single space by default).} \item{colw}{a numeric specifying the number of nucleotides per column (10 by default).} \item{indent}{a numeric or a character specifying how the blocks of nucleotides are indented (see details).} \item{blocksep}{a numeric specifying the number of lines between the blocks of nucleotides (this has an effect only if `format = "interleaved"').} \item{header}{a vector of mode character giving the header to be written in the FASTA file before the sequences. By default, there is no header.} } \description{ These functions write in a file a list of DNA sequences in sequential, interleaved, or FASTA format. \code{write.FASTA} can write either DNA or AA sequences. } \details{ Three formats are supported in the present function: see the help page of \code{\link{read.dna}} and the references below for a description. If the sequences have no names, then they are given "1", "2", ... as labels in the file. With the interleaved and sequential formats, the sequences must be all of the same length. The names of the sequences are not truncated. The argument \code{indent} specifies how the rows of nucleotides are indented. In the interleaved and sequential formats, the rows with the taxon names are never indented; the subsequent rows are indented with 10 spaces by default (i.e., if \code{indent = NULL}). In the FASTA format, the rows are not indented by default. This default behaviour can be modified by specifying a value to \code{indent}: the rows are then indented with ``indent'' (if it is a character) or `indent' spaces (if it is a numeric). For example, specifying \code{indent = " "} or \code{indent = 3} will have the same effect (use \code{indent = "\\t"} for a tabulation). The different options are intended to give flexibility in formatting the sequences. For instance, if the sequences are very long it may be judicious to remove all the spaces beween columns (colsep = ""), in the margins (indent = 0), and between the blocks (blocksep = 0) to produce a smaller file. \code{write.dna(, format = "fasta")} can be very slow if the sequences are long (> 10 kb). \code{write.FASTA} is much faster in this situation but the formatting is not flexible: each sequence is printed on a single line, which is OK for big files that are not intended to be open with a text editor. } \note{ Specifying a negative value for `nbcol' (meaning that the nucleotides are printed on a single line) gives the same output for the interleaved and sequential formats. The names of the sequences can be truncated with the function \code{\link{makeLabel}}. In particular, Clustal is limited to 30 characters, and PHYML seems limited to 99 characters. } \value{ None (invisible `NULL'). } \author{Emmanuel Paradis} \references{ Anonymous. FASTA format. \url{https://en.wikipedia.org/wiki/FASTA_format} Felsenstein, J. (1993) Phylip (Phylogeny Inference Package) version 3.5c. Department of Genetics, University of Washington. \url{http://evolution.genetics.washington.edu/phylip/phylip.html} } \seealso{ \code{\link{read.dna}}, \code{\link{read.GenBank}}, \code{\link{makeLabel}} } \keyword{IO} ape/man/compute.brlen.Rd0000644000176200001440000000437314164530562014653 0ustar liggesusers\name{compute.brlen} \alias{compute.brlen} \title{Branch Lengths Computation} \usage{ compute.brlen(phy, method = "Grafen", power = 1, ...) } \arguments{ \item{phy}{an object of class \code{phylo} representing the tree.} \item{method}{the method to be used to compute the branch lengths; this must be one of the followings: (i) \code{"Grafen"} (the default), (ii) a numeric vector, or (iii) a function.} \item{power}{The power at which heights must be raised (see below).} \item{\dots}{further argument(s) to be passed to \code{method} if it is a function.} } \description{ This function computes branch lengths of a tree using different methods. } \details{ Grafen's (1989) computation of branch lengths: each node is given a `height', namely the number of leaves of the subtree minus one, 0 for leaves. Each height is scaled so that root height is 1, and then raised at power 'rho' (> 0). Branch lengths are then computed as the difference between height of lower node and height of upper node. If one or several numeric values are provided as \code{method}, they are recycled if necessary. If a function is given instead, further arguments are given in place of \code{...} (they must be named, see examples). Zero-length branches are not treated as multichotomies, and thus may need to be collapsed (see \code{\link{di2multi}}). } \value{ An object of class \code{phylo} with branch lengths. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de} and Emmanuel Paradis} \references{ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical Transactions of the Royal society of London. Series B. Biological Sciences}, \bold{326}, 119--157. } \seealso{ \code{\link{read.tree}} for a description of \code{phylo} objects, \code{\link{di2multi}}, \code{\link{multi2di}} } \examples{ data(bird.orders) plot(compute.brlen(bird.orders, 1)) plot(compute.brlen(bird.orders, runif, min = 0, max = 5)) layout(matrix(1:4, 2, 2)) plot(compute.brlen(bird.orders, power=1), main=expression(rho==1)) plot(compute.brlen(bird.orders, power=3), main=expression(rho==3)) plot(compute.brlen(bird.orders, power=0.5), main=expression(rho==0.5)) plot(compute.brlen(bird.orders, power=0.1), main=expression(rho==0.1)) layout(1) } \keyword{manip} ape/man/read.gff.Rd0000644000176200001440000000326714164530562013553 0ustar liggesusers\name{read.gff} \alias{read.gff} \title{Read GFF Files} \description{ This function reads a file in general feature format version 3 (GFF3) and returns a data frame. } \usage{ read.gff(file, na.strings = c(".", "?"), GFF3 = TRUE) } \arguments{ \item{file}{a file name specified by a character string.} \item{na.strings}{the strings in the GFF file that will be converted as NA's (missing values).} \item{GFF3}{a logical value specifying whether if the file is formatted according to version 3 of GFF.} } \details{ The returned data frame has its (column) names correctly set (see References) and the categorical variables (seqid, source, type, strand, and phase) set as factors. This function should be more efficient than using \code{read.delim}. GFF2 (aka GTF) files can also be read: use \code{GFF3 = FALSE} to have the correct field names. Note that GFF2 files and GFF3 files have the same structure, although some fields are slightly different (see reference). The file can be gz-compressed (see examples), but not zipped. } \value{NULL} \author{Emmanuel Paradis} \references{ \url{https://en.wikipedia.org/wiki/General_feature_format} } \examples{ \dontrun{ ## requires to be connected on Internet d <- "https://ftp.ensembl.org/pub/release-86/gff3/homo_sapiens/" f <- "Homo_sapiens.GRCh38.86.chromosome.MT.gff3.gz" download.file(paste0(d, f), "mt_gff3.gz") ## If the above command doesn't work, you may copy/paste the full URL in ## a Web browser instead. gff.mito <- read.gff("mt_gff3.gz") ## the lengths of the sequence features: gff.mito$end - (gff.mito$start - 1) table(gff.mito$type) ## where the exons start: gff.mito$start[gff.mito$type == "exon"] } } \keyword{IO} ape/man/bionj.Rd0000644000176200001440000000231214164530562013166 0ustar liggesusers\name{BIONJ} \alias{bionj} \title{ Tree Estimation Based on an Improved Version of the NJ Algorithm } \description{ This function performs the BIONJ algorithm of Gascuel (1997). } \usage{ bionj(X) } \arguments{ \item{X}{a distance matrix; may be an object of class \code{"dist"}.} } \value{ an object of class \code{"phylo"}. } \references{ Gascuel, O. (1997) BIONJ: an improved version of the NJ algorithm based on a simple model of sequence data. \emph{Molecular Biology and Evolution}, \bold{14:}, 685--695. } \author{ original C code by Hoa Sien Cuong and Olivier Gascuel; adapted and ported to \R by Vincent Lefort \email{vincent.lefort@lirmm.fr} } \seealso{ \code{\link{nj}}, \code{\link{fastme}}, \code{\link{mvr}}, \code{\link{bionjs}}, \code{\link{SDM}}, \code{\link{dist.dna}} } \examples{ ### From Saitou and Nei (1987, Table 1): x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13, 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12, 5, 6, 10, 9, 13, 8) M <- matrix(0, 8, 8) M[lower.tri(M)] <- x M <- t(M) M[lower.tri(M)] <- x dimnames(M) <- list(1:8, 1:8) tr <- bionj(M) plot(tr, "u") ### a less theoretical example data(woodmouse) trw <- bionj(dist.dna(woodmouse)) plot(trw) } \keyword{models} ape/man/write.nexus.Rd0000644000176200001440000000300114164530562014354 0ustar liggesusers\name{write.nexus} \alias{write.nexus} \title{Write Tree File in Nexus Format} \usage{ write.nexus(..., file = "", translate = TRUE) } \arguments{ \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a series of such objects separated by commas, or (iii) a list containing such objects.} \item{file}{a file name specified by either a variable of mode character, or a double-quoted string; if \code{file = ""} (the default) then the tree is written on the standard output connection.} \item{translate}{a logical, if \code{TRUE} (the default) a translation of the tip labels is done which are replaced in the parenthetic representation with tokens.} } \description{ This function writes trees in a file with the NEXUS format. } \details{ If several trees are given, they must all have the same tip labels. If among the objects given some are not trees of class \code{"phylo"}, they are simply skipped and not written in the file. See \code{\link{write.tree}} for details on how tip (and node) labels are checked before being printed. } \value{ None (invisible `NULL'). } \references{ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an extensible file format for systematic information. \emph{Systematic Biology}, \bold{46}, 590--621. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.nexus}}, \code{\link{read.tree}}, \code{\link{write.tree}}, \code{\link{read.nexus.data}}, \code{\link{write.nexus.data}} } \keyword{manip} \keyword{IO} ape/man/corGrafen.Rd0000644000176200001440000000563114164530562014002 0ustar liggesusers\name{corGrafen} \alias{corGrafen} \alias{coef.corGrafen} \alias{corMatrix.corGrafen} \title{Grafen's (1989) Correlation Structure} \usage{ corGrafen(value, phy, form=~1, fixed = FALSE) \method{coef}{corGrafen}(object, unconstrained = TRUE, ...) \method{corMatrix}{corGrafen}(object, covariate = getCovariate(object), corr = TRUE, ...) } \arguments{ \item{value}{The \eqn{\rho}{rho} parameter} \item{phy}{An object of class \code{phylo} representing the phylogeny (branch lengths are ignored) to consider} \item{object}{An (initialized) object of class \code{corGrafen}} \item{corr}{a logical value. If 'TRUE' the function returns the correlation matrix, otherwise it returns the variance/covariance matrix.} \item{fixed}{an optional logical value indicating whether the coefficients should be allowed to vary in the optimization, or kept fixed at their initial value. Defaults to 'FALSE', in which case the coefficients are allowed to vary.} \item{form}{a one sided formula of the form ~ t, or ~ t | g, specifying the taxa covariate t and, optionally, a grouping factor g. A covariate for this correlation structure must be character valued, with entries matching the tip labels in the phylogenetic tree. When a grouping factor is present in form, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to ~ 1, which corresponds to using the order of the observations in the data as a covariate, and no groups.} \item{covariate}{an optional covariate vector (matrix), or list of covariate vectors (matrices), at which values the correlation matrix, or list of correlation matrices, are to be evaluated. Defaults to getCovariate(object).} \item{unconstrained}{a logical value. If 'TRUE' the coefficients are returned in unconstrained form (the same used in the optimization algorithm). If 'FALSE' the coefficients are returned in "natural", possibly constrained, form. Defaults to 'TRUE'} \item{\dots}{some methods for these generics require additional arguments. None are used in these methods.} } \description{ Grafen's (1989) covariance structure. Branch lengths are computed using Grafen's method (see \code{\link{compute.brlen}}). The covariance matrice is then the traditional variance-covariance matrix for a phylogeny. } \value{ An object of class \code{corGrafen} or the rho coefficient from an object of this class or the correlation matrix of an initialized object of this class. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}} \seealso{ \code{\link{corClasses}}, \code{\link{compute.brlen}}, \code{\link{vcv.phylo}}. } \references{ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical Transactions of the Royal society of London. Series B. Biological Sciences}, \bold{326}, 119--157. } \keyword{models} ape/man/label2table.Rd0000644000176200001440000000414114164530562014240 0ustar liggesusers\name{label2table} \alias{label2table} \alias{stripLabel} \alias{abbreviateGenus} \title{Label Management} \description{ These functions work on a vector of character strings storing bi- or trinomial species names, typically ``Genus_species_subspecies''. } \usage{ label2table(x, sep = NULL, as.is = FALSE) stripLabel(x, species = FALSE, subsp = TRUE, sep = NULL) abbreviateGenus(x, genus = TRUE, species = FALSE, sep = NULL) } \arguments{ \item{x}{a vector of mode character.} \item{sep}{the separator (a single character) between the taxonomic levels (see details).} \item{as.is}{a logical specifying whether to convert characters into factors (like in \code{\link[utils]{read.table}}).} \item{species, subsp, genus}{a logical specifying whether the taxonomic level is concerned by the operation.} } \details{ \code{label2table} returns a data frame with three columns named ``genus'', ``species'', and ``subspecies'' (with \code{NA} if the level is missing). \code{stripLabel} deletes the subspecies names from the input. If \code{species = TRUE}, the species names are also removed, thus returning only the genus names. \code{abbreviateGenus} abbreviates the genus names keeping only the first letter. If \code{species = TRUE}, the species names are abbreviated. By default, these functions try to guess what is the separator between the genus, species and/or subspecies names. If an underscore is present in the input, then this character is assumed to be the separator; otherwise, a space. If this does not work, you can specify \code{sep} to its appropriate value. } \value{ A vector of mode character or a data frame. } \author{Emmanuel Paradis} \seealso{ \code{\link{makeLabel}}, \code{\link{makeNodeLabel}}, \code{\link{mixedFontLabel}}, \code{\link{updateLabel}}, \code{\link{checkLabel}} } \examples{ x <- c("Panthera_leo", "Panthera_pardus", "Panthera_onca", "Panthera_uncia", "Panthera_tigris_altaica", "Panthera_tigris_amoyensis") label2table(x) stripLabel(x) stripLabel(x, TRUE) abbreviateGenus(x) abbreviateGenus(x, species = TRUE) abbreviateGenus(x, genus = FALSE, species = TRUE) } \keyword{manip} ape/man/corClasses.Rd0000644000176200001440000000336514164530562014177 0ustar liggesusers\name{corClasses} \alias{corClasses} \alias{corPhyl} \title{Phylogenetic Correlation Structures} \description{ Classes of phylogenetic correlation structures (\code{"corPhyl"}) available in \pkg{ape}. \itemize{ \item{corBrownian}{Brownian motion model (Felsenstein 1985)} \item{corMartins}{The covariance matrix defined in Martins and Hansen (1997)} \item{corGrafen}{The covariance matrix defined in Grafen (1989)} \item{corPagel}{The covariance matrix defined in Freckelton et al. (2002)} \item{corBlomberg}{The covariance matrix defined in Blomberg et al. (2003)} } See the help page of each class for references and detailed description. } \seealso{ \code{\link[nlme]{corClasses}} and \code{\link[nlme]{gls}} in the \pkg{nlme} librarie, \code{\link{corBrownian}}, \code{\link{corMartins}}, \code{\link{corGrafen}}, \code{\link{corPagel}}, \code{\link{corBlomberg}}, \code{\link{vcv}}, \code{\link{vcv2phylo}} } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}, Emmanuel Paradis} \examples{ library(nlme) txt <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);" tree.primates <- read.tree(text = txt) X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259) Species <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago") dat <- data.frame(Species = Species, X = X, Y = Y) m1 <- gls(Y ~ X, dat, correlation=corBrownian(1, tree.primates, form = ~Species)) summary(m1) m2 <- gls(Y ~ X, dat, correlation=corMartins(1, tree.primates, form = ~Species)) summary(m2) corMatrix(m2$modelStruct$corStruct) m3 <- gls(Y ~ X, dat, correlation=corGrafen(1, tree.primates, form = ~Species)) summary(m3) corMatrix(m3$modelStruct$corStruct) } \keyword{models} ape/man/zoom.Rd0000644000176200001440000000411214164530562013051 0ustar liggesusers\name{zoom} \alias{zoom} \title{Zoom on a Portion of a Phylogeny} \description{ This function plots simultaneously a whole phylogenetic tree (supposedly large) and a portion of it. } \usage{ zoom(phy, focus, subtree = FALSE, col = rainbow, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{focus}{a vector, either numeric or character, or a list of vectors specifying the tips to be focused on.} \item{subtree}{a logical indicating whether to show the context of the extracted subtrees.} \item{col}{a vector of colours used to show where the subtrees are in the main tree, or a function .} \item{\dots}{further arguments passed to \code{plot.phylo}.} } \details{ This function aims at exploring very large trees. The main argument is a phylogenetic tree, and the second one is a vector or a list of vectors specifying the tips to be focused on. The vector(s) can be either numeric and thus taken as the indices of the tip labels, or character in which case it is taken as the corresponding tip labels. The whole tree is plotted on the left-hand side in a narrower sub-window (about a quarter of the device) without tip labels. The subtrees consisting of the tips in `focus' are extracted and plotted on the right-hand side starting from the top left corner and successively column-wise. If the argument `col' is a vector of colours, as many colours as the number of subtrees must be given. The alternative is to give a function that will create colours or grey levels from the number of subtrees: see \code{\link[grDevices]{rainbow}} for some possibilities with colours. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{drop.tip}}, \code{\link[graphics]{layout}}, \code{\link[grDevices]{rainbow}}, \code{\link[grDevices]{grey}} } \examples{ \dontrun{ data(chiroptera) zoom(chiroptera, 1:20, subtree = TRUE) zoom(chiroptera, grep("Plecotus", chiroptera$tip.label)) zoom(chiroptera, list(grep("Plecotus", chiroptera$tip.label), grep("Pteropus", chiroptera$tip.label))) } } \keyword{hplot} ape/man/as.bitsplits.Rd0000644000176200001440000000435514164530562014515 0ustar liggesusers\name{as.bitsplits} \alias{as.bitsplits} \alias{as.bitsplits.prop.part} \alias{print.bitsplits} \alias{sort.bitsplits} \alias{bitsplits} \alias{countBipartitions} \alias{as.prop.part} \alias{as.prop.part.bitsplits} \title{Split Frequencies and Conversion Among Split Classes} \description{ \code{bitsplits} returns the bipartitions (aka splits) for a single tree or a list of trees. If at least one tree is rooted, an error is returned. \code{countBipartitions} returns the frequencies of the bipartitions from a reference tree (phy) observed in a list of trees (X), all unrooted. \code{as.bitsplits} and \code{as.prop.part} are generic functions for converting between the \code{"bitsplits"} and \code{"prop.part"} classes. } \usage{ bitsplits(x) countBipartitions(phy, X) as.bitsplits(x) \method{as.bitsplits}{prop.part}(x) \method{print}{bitsplits}(x, ...) \method{sort}{bitsplits}(x, decreasing = FALSE, ...) as.prop.part(x, ...) \method{as.prop.part}{bitsplits}(x, include.trivial = FALSE, ...) } \arguments{ \item{x}{an object of the appropriate class.} \item{phy}{an object of class \code{"phylo"}.} \item{X}{an object of class \code{"multiPhylo"}.} \item{decreasing}{a logical value to sort the bipartitions in increasing (the default) or decreasing order of their frequency.} \item{include.trivial}{a logical value specifying whether to include the trivial split with all tips in the returned object.} \item{\dots}{further arguments passed to or from other methods.} } \details{ These functions count bipartitions as defined by internal branches, so they not work only with unrooted trees. The structure of the class \code{"bitsplits"} is described in a separate document on ape's web site. } \value{ \code{bitsplits}, \code{as.bitsplits}, and \code{sort} return an object of class \code{"bitsplits"}. \code{countBipartitions} returns a vector of integers. \code{as.prop.part} returns an object of class \code{"prop.part"}. } \author{Emmanuel Paradis} \seealso{\code{\link{prop.part}}, \code{\link{is.compatible}}} \examples{ tr <- rtree(20) pp <- prop.part(tr) as.bitsplits(pp) ## works only with unrooted trees (ape 5.5): countBipartitions(rtree(10, rooted = FALSE), rmtree(100, 10, rooted = FALSE)) } \keyword{manip} ape/man/Initialize.corPhyl.Rd0000644000176200001440000000166514164530562015617 0ustar liggesusers\name{Initialize.corPhyl} \alias{Initialize.corPhyl} \title{Initialize a `corPhyl' Structure Object} \usage{ \method{Initialize}{corPhyl}(object, data, ...) } \arguments{ \item{object}{An object inheriting from class \code{corPhyl}.} \item{data}{The data to use. If it contains rownames, they are matched with the tree tip labels, otherwise data are supposed to be in the same order than tip labels and a warning is sent.} \item{\dots}{some methods for this generic require additional arguments. None are used in this method.} } \description{ Initialize a \code{corPhyl} correlation structure object. Does the same as \code{Initialize.corStruct}, but also checks the row names of data and builds an index. } \value{ An initialized object of same class as \code{object}. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}} \seealso{ \code{\link{corClasses}}, \code{\link[nlme]{Initialize.corStruct}}. } \keyword{models} \keyword{manip} ape/man/plotTreeTime.Rd0000644000176200001440000000306614164530562014511 0ustar liggesusers\name{plotTreeTime} \alias{plotTreeTime} \title{Plot Tree With Time Axis} \description{ This function plots a non-ultrametric tree where the tips are not contemporary together with their dates on the x-axis. } \usage{ plotTreeTime(phy, tip.dates, show.tip.label = FALSE, y.lim = NULL, color = TRUE, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{tip.dates}{a vector of the same length than the number of tips in \code{phy} (see details).} \item{show.tip.label}{a logical value; see \code{\link{plot.phylo}}.} \item{y.lim}{by default, one fifth of the plot is left below the tree; use this option to change this behaviour.} \item{color}{a logical value specifying whether to use colors for the lines linking the tips to the time axis. If \code{FALSE}, a grey scale is used.} \item{\dots}{other arguments to be passed to \code{plot.phylo}.} } \details{ The vector \code{tip.dates} may be numeric or of class \dQuote{\link[base]{Date}}. In either case, the time axis is set accordingly. The length of this vector must be equal to the number of tips of the tree: the dates are matched to the tips numbers. Missing values are allowed. } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{estimate.dates}} } \examples{ dates <- as.Date(.leap.seconds) tr <- rtree(length(dates)) plotTreeTime(tr, dates) ## handling NA's: dates[11:26] <- NA plotTreeTime(tr, dates) ## dates can be on an arbitrary scale, e.g., [-1, 1]: plotTreeTime(tr, runif(Ntip(tr), -1, 1)) } \keyword{hplot} ape/man/multiphylo.Rd0000644000176200001440000000374014164530562014301 0ustar liggesusers\name{multiphylo} \alias{multiphylo} \alias{[.multiPhylo} \alias{[[.multiPhylo} \alias{$.multiPhylo} \alias{[<-.multiPhylo} \alias{[[<-.multiPhylo} \alias{$<-.multiPhylo} \title{Manipulating Lists of Trees} \description{ These are extraction and replacement operators for lists of trees stored in the class \code{"multiPhylo"}. } \usage{ \method{[}{multiPhylo}(x, i) \method{[[}{multiPhylo}(x, i) \method{$}{multiPhylo}(x, name) \method{[}{multiPhylo}(x, ...) <- value \method{[[}{multiPhylo}(x, ...) <- value \method{$}{multiPhylo}(x, ...) <- value } \arguments{ \item{x, value}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{i}{index(ices) of the tree(s) to select from a list; this may be a vector of integers, logicals, or names.} \item{name}{a character string specifying the tree to be extracted.} \item{\dots}{index(ices) of the tree(s) to replace; this may be a vector of integers, logicals, or names.} } \details{ The subsetting operator \code{[} keeps the class correctly (\code{"multiPhylo"}). The replacement operators check the labels of \code{value} if \code{x} has a single vector of tip labels for all trees (see examples). } \value{ An object of class \code{"phylo"} (\code{[[}, \code{$}) or of class \code{"multiPhylo"} (\code{[} and the replacement operators). } \author{Emmanuel Paradis} \seealso{ \code{\link{summary.phylo}}, \code{\link{c.phylo}} } \examples{ x <- rmtree(10, 20) names(x) <- paste("tree", 1:10, sep = "") x[1:5] x[1] # subsetting x[[1]] # extraction x$tree1 # same than above x[[1]] <- rtree(20) y <- .compressTipLabel(x) ## up to here 'x' and 'y' have exactly the same information ## but 'y' has a unique vector of tip labels for all the trees x[[1]] <- rtree(10) # no error try(y[[1]] <- rtree(10)) # error try(x[1] <- rtree(20)) # error ## use instead one of the two: x[1] <- list(rtree(20)) x[1] <- c(rtree(20)) x[1:5] <- rmtree(5, 20) # replacement x[11:20] <- rmtree(10, 20) # elongation x # 20 trees } \keyword{manip} ape/man/alview.Rd0000644000176200001440000000303414164530562013356 0ustar liggesusers\name{alview} \alias{alview} \title{Print DNA or AA Sequence Alignement} \description{ This function displays in the console or a file an alignment of DNA or AAsequences. The first sequence is printed on the first row and the bases of the other sequences are replaced by dots if they are identical with the first sequence. } \usage{ alview(x, file = "", uppercase = TRUE, showpos = TRUE) } \arguments{ \item{x}{a matrix or a list of DNA sequences (class \code{"DNAbin"}) or a matrix of AA sequences (class \code{"AAbin"}).} \item{file}{a character string giving the name of the file where to print the sequences; by default, they are printed in the console.} \item{uppercase}{a logical specifying whether to print the bases as uppercase letters.} \item{showpos}{either a logical value specifying whether to display the site positions, or a numeric vector giving these positions (see examples).} } \details{ The first line of the output shows the position of the last column of the printed alignment. } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{image.DNAbin}}, \code{\link{alex}}, \code{\link{clustal}}, \code{\link{checkAlignment}}, \code{\link{all.equal.DNAbin}} } \examples{ data(woodmouse) alview(woodmouse[, 1:50]) alview(woodmouse[, 1:50], uppercase = FALSE) ## display only some sites: j <- c(10, 49, 125, 567) # just random x <- woodmouse[, j] alview(x, showpos = FALSE) # no site position displayed alview(x, showpos = j) \dontrun{ alview(woodmouse, file = "woodmouse.txt") } } \keyword{IO} ape/man/mat5M3ID.Rd0000644000176200001440000000051414164530562013352 0ustar liggesusers\name{mat5M3ID} \alias{mat5M3ID} \title{Five Trees} \description{ Three partly similar trees, two independent trees. } \usage{ data(mat5M3ID) } \format{ A data frame with 250 observations and 50 variables. } \source{ Data provided by V. Campbell. } \seealso{ \code{\link{mat5Mrand}}, \code{\link{mat3}} } \keyword{datasets} ape/man/all.equal.phylo.Rd0000644000176200001440000000512414164530562015101 0ustar liggesusers\encoding{utf8} \name{all.equal.phylo} \alias{all.equal.phylo} \title{Global Comparison of two Phylogenies} \usage{ \method{all.equal}{phylo}(target, current, use.edge.length = TRUE, use.tip.label = TRUE, index.return = FALSE, tolerance = .Machine$double.eps ^ 0.5, scale = NULL, \dots) } \arguments{ \item{target}{an object of class \code{"phylo"}.} \item{current}{an object of class \code{"phylo"}.} \item{use.edge.length}{if \code{FALSE} only the topologies are compared; the default is \code{TRUE}.} \item{use.tip.label}{if \code{FALSE} the unlabelled trees are compared; the default is \code{TRUE}.} \item{index.return}{if \code{TRUE} the function returns a two-column matrix giving the correspondence between the nodes of both trees.} \item{tolerance}{the numeric tolerance used to compare the branch lengths.} \item{scale}{a positive number, comparison of branch lengths is made after scaling (i.e., dividing) them by this number.} \item{\dots}{further arguments passed to or from other methods.} } \description{ This function makes a global comparison of two phylogenetic trees. } \details{ This function is meant to be an adaptation of the generic function \code{all.equal} for the comparison of phylogenetic trees. A single phylogenetic tree may have several representations in the Newick format and in the \code{"phylo"} class of objects used in `ape'. One aim of the present function is to be able to identify whether two objects of class \code{"phylo"} represent the same phylogeny. } \note{ The algorithm used here does not work correctly for the comparison of topologies (i.e., ignoring tip labels) of unrooted trees. This also affects \code{\link{unique.multiPhylo}} which calls the present function. See: \url{https://www.mail-archive.com/r-sig-phylo@r-project.org/msg01445.html}. } \value{ A logical value, or a two-column matrix. } \author{\enc{Benoît}{Benoit} Durand \email{b.durand@alfort.AFSSA.FR}} \seealso{ \code{\link[base]{all.equal}} for the generic \R function, \code{\link{comparePhylo}} } \examples{ ### maybe the simplest example of two representations ### for the same rooted tree...: t1 <- read.tree(text = "(a:1,b:1);") t2 <- read.tree(text = "(b:1,a:1);") all.equal(t1, t2) ### ... compare with this: identical(t1, t2) ### one just slightly more complicated...: t3 <- read.tree(text = "((a:1,b:1):1,c:2);") t4 <- read.tree(text = "(c:2,(a:1,b:1):1);") all.equal(t3, t4) # == all.equal.phylo(t3, t4) ### ... here we force the comparison as lists: all.equal.list(t3, t4) } \keyword{manip} ape/man/hivtree.Rd0000644000176200001440000000155214164530562013540 0ustar liggesusers\name{hivtree} \alias{hivtree} \alias{hivtree.newick} \alias{hivtree.table} \title{Phylogenetic Tree of 193 HIV-1 Sequences} \description{ This data set describes an estimated clock-like phylogeny of 193 HIV-1 group M sequences sampled in the Democratic Republic of Congo. } \usage{ data(hivtree.newick) data(hivtree.table) } \format{ \code{hivtree.newick} is a string with the tree in Newick format. The data frame \code{hivtree.table} contains the corresponding internode distances. } \source{This is a data example from Strimmer and Pybus (2001).} \references{ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history of DNA sequences using the generalized skyline plot. \emph{Molecular Biology and Evolution}, \bold{18}, 2298--2305. } \seealso{ \code{\link{coalescent.intervals}}, \code{\link{collapsed.intervals}} } \keyword{datasets} ape/man/corphylo.Rd0000644000176200001440000003123414164530562013731 0ustar liggesusers\name{corphylo} \alias{corphylo} \alias{print.corphylo} \title{Correlations among Multiple Traits with Phylogenetic Signal} \description{ This function calculates Pearson correlation coefficients for multiple continuous traits that may have phylogenetic signal, allowing users to specify measurement error as the standard error of trait values at the tips of the phylogenetic tree. Phylogenetic signal for each trait is estimated from the data assuming that trait evolution is given by a Ornstein-Uhlenbeck process. Thus, the function allows the estimation of phylogenetic signal in multiple traits while incorporating correlations among traits. It is also possible to include independent variables (covariates) for each trait to remove possible confounding effects. corphylo() returns the correlation matrix for trait values, estimates of phylogenetic signal for each trait, and regression coefficients for independent variables affecting each trait. } \usage{ corphylo(X, U = list(), SeM = NULL, phy = NULL, REML = TRUE, method = c("Nelder-Mead", "SANN"), constrain.d = FALSE, reltol = 10^-6, maxit.NM = 1000, maxit.SA = 1000, temp.SA = 1, tmax.SA = 1, verbose = FALSE) \method{print}{corphylo}(x, digits = max(3, getOption("digits") - 3), ...) } \arguments{ \item{X}{a n x p matrix with p columns containing the values for the n taxa. Rows of X should have rownames matching the taxon names in phy.} \item{U}{a list of p matrices corresponding to the p columns of X, with each matrix containing independent variables for the corresponding column of X. The rownames of each matrix within U must be the same as X, or alternatively, the order of values in rows must match those in X. If U is omitted, only the mean (aka intercept) for each column of X is estimated. If U[[i]] is NULL, only an intercept is estimated for X[, i]. If all values of U[[i]][j] are the same, this variable is automatically dropped from the analysis (i.e., there is no offset in the regression component of the model).} \item{SeM}{a n x p matrix with p columns containing standard errors of the trait values in X. The rownames of SeM must be the same as X, or alternatively, the order of values in rows must match those in X. If SeM is omitted, the trait values are assumed to be known without error. If only some traits have mesurement errors, the remaining traits can be given zero-valued standard errors.} \item{phy}{a phylo object giving the phylogenetic tree. The rownames of phy must be the same as X, or alternatively, the order of values in rows must match those in X.} \item{REML}{whether REML or ML is used for model fitting.} \item{method}{in optim(), either Nelder-Mead simplex minimization or SANN (simulated annealing) minimization is used. If SANN is used, it is followed by Nelder-Mead minimization.} \item{constrain.d}{if constrain.d is TRUE, the estimates of d are constrained to be between zero and 1. This can make estimation more stable and can be tried if convergence is problematic. This does not necessarily lead to loss of generality of the results, because before using corphylo, branch lengths of phy can be transformed so that the "starter" tree has strong phylogenetic signal.} \item{reltol}{a control parameter dictating the relative tolerance for convergence in the optimization; see optim().} \item{maxit.NM}{a control parameter dictating the maximum number of iterations in the optimization with Nelder-Mead minimization; see optim().} \item{maxit.SA}{a control parameter dictating the maximum number of iterations in the optimization with SANN minimization; see optim().} \item{temp.SA}{a control parameter dictating the starting temperature in the optimization with SANN minimization; see optim().} \item{tmax.SA}{a control parameter dictating the number of function evaluations at each temperature in the optimization with SANN minimization; see optim().} \item{verbose}{if TRUE, the model logLik and running estimates of the correlation coefficients and values of d are printed each iteration during optimization.} \item{x}{an objects of class corphylo.} \item{digits}{the number of digits to be printed.} \item{\dots}{arguments passed to and from other methods.} } \details{ For the case of two variables, the function estimates parameters for the model of the form, for example, \deqn{X[1] = B[1,0] + B[1,1] * u[1,1] + \epsilon[1]} \deqn{X[2] = B[2,0] + B[2,1] * u[2,1] + \epsilon[2]} \deqn{\epsilon ~ Gaussian(0, V) } where \eqn{B[1,0]}, \eqn{B[1,1]}, \eqn{B[2,0]}, and \eqn{B[2,1]} are regression coefficients, and \eqn{V} is a variance-covariance matrix containing the correlation coefficient r, parameters of the OU process \eqn{d1} and \eqn{d2}, and diagonal matrices \eqn{M1} and \eqn{M2} of measurement standard errors for \eqn{X[1]} and \eqn{X[2]}. The matrix \eqn{V} is \eqn{2n x 2n}, with \eqn{n x n} blocks given by \deqn{V[1,1] = C[1,1](d1) + M1} \deqn{V[1,2] = C[1,2](d1,d2)} \deqn{V[2,1] = C[2,1](d1,d2)} \deqn{V[2,2] = C[2,2](d2) + M2} where \eqn{C[i,j](d1,d2)} are derived from phy under the assumption of joint OU evolutionary processes for each trait (see Zheng et al. 2009). This formulation extends in the obvious way to more than two traits. } \value{ An object of class "corphylo". \item{cor.matrix}{the p x p matrix of correlation coefficients.} \item{d}{values of d from the OU process for each trait.} \item{B}{estimates of the regression coefficients, including intercepts. Coefficients are named according to the list U. For example, B1.2 is the coefficient corresponding to U[[1]][, 2], and if column 2 in U[[1]] is named "colname2", then the coefficient will be B1.colname2. Intercepts have the form B1.0.} \item{B.se}{standard errors of the regression coefficients.} \item{B.cov}{covariance matrix for regression coefficients.} \item{B.zscore}{Z scores for the regression coefficients.} \item{B.pvalue}{tests for the regression coefficients being different from zero.} \item{logLik}{he log likelihood for either the restricted likelihood (REML = TRUE) or the overall likelihood (REML = FALSE).} \item{AIC}{AIC for either the restricted likelihood (REML = TRUE) or the overall likelihood (REML = FALSE).} \item{BIC}{BIC for either the restricted likelihood (REML = TRUE) or the overall likelihood (REML = FALSE).} \item{REML}{whether REML is used rather than ML (TRUE or FALSE).} \item{constrain.d}{whether or not values of d were constrained to be between 0 and 1 (TRUE or FALSE).} \item{XX}{values of X in vectorized form, with each trait X[, i] standardized to have mean zero and standard deviation one.} \item{UU}{design matrix with values in UU corresponding to XX; each variable U[[i]][, j] is standardized to have mean zero and standard deviation one.} \item{MM}{vector of measurement standard errors corresponding to XX, with the standard errors suitably standardized.} \item{Vphy}{the phylogenetic covariance matrix computed from phy and standardized to have determinant equal to one.} \item{R}{covariance matrix of trait values relative to the standardized values of XX.} \item{V}{overall estimated covariance matrix of residuals for XX including trait correlations, phylogenetic signal, and measurement error variances. This matrix can be used to simulate data for parametric bootstrapping. See examples.} \item{C}{matrix V excluding measurement error variances.} \item{convcode}{he convergence code provided by optim().} \item{niter}{number of iterations performed by optim().} } \author{Anthony R. Ives} \references{ Zheng, L., A. R. Ives, T. Garland, B. R. Larget, Y. Yu, and K. F. Cao. 2009. New multivariate tests for phylogenetic signal and trait correlations applied to ecophysiological phenotypes of nine \emph{Manglietia} species. \emph{Functional Ecology} \bold{23}:1059--1069. } \examples{ ## Simple example using data without correlations or phylogenetic ## signal. This illustrates the structure of the input data. phy <- rcoal(10, tip.label = 1:10) X <- matrix(rnorm(20), nrow = 10, ncol = 2) rownames(X) <- phy$tip.label U <- list(NULL, matrix(rnorm(10, mean = 10, sd = 4), nrow = 10, ncol = 1)) rownames(U[[2]]) <- phy$tip.label SeM <- matrix(c(0.2, 0.4), nrow = 10, ncol = 2) rownames(SeM) <- phy$tip.label corphylo(X = X, SeM = SeM, U = U, phy = phy, method = "Nelder-Mead") \dontrun{ ## Simulation example for the correlation between two variables. The ## example compares the estimates of the correlation coefficients from ## corphylo when measurement error is incorporated into the analyses with ## three other cases: (i) when measurement error is excluded, (ii) when ## phylogenetic signal is ignored (assuming a "star" phylogeny), and (iii) ## neither measurement error nor phylogenetic signal are included. ## In the simulations, variable 2 is associated with a single ## independent variable. This requires setting up a list U that has 2 ## elements: element U[[1]] is NULL and element U[[2]] is a n x 1 vector ## containing simulated values of the independent variable. # Set up parameter values for simulating data n <- 50 phy <- rcoal(n, tip.label = 1:n) R <- matrix(c(1, 0.7, 0.7, 1), nrow = 2, ncol = 2) d <- c(0.3, .95) B2 <- 1 Se <- c(0.2, 1) SeM <- matrix(Se, nrow = n, ncol = 2, byrow = T) rownames(SeM) <- phy$tip.label # Set up needed matrices for the simulations p <- length(d) star <- stree(n) star$edge.length <- array(1, dim = c(n, 1)) star$tip.label <- phy$tip.label Vphy <- vcv(phy) Vphy <- Vphy/max(Vphy) Vphy <- Vphy/exp(determinant(Vphy)$modulus[1]/n) tau <- matrix(1, nrow = n, ncol = 1) %*% diag(Vphy) - Vphy C <- matrix(0, nrow = p * n, ncol = p * n) for (i in 1:p) for (j in 1:p) { Cd <- (d[i]^tau * (d[j]^t(tau)) * (1 - (d[i] * d[j])^Vphy))/(1 - d[i] * d[j]) C[(n * (i - 1) + 1):(i * n), (n * (j - 1) + 1):(j * n)] <- R[i, j] * Cd } MM <- matrix(SeM^2, ncol = 1) V <- C + diag(as.numeric(MM)) ## Perform a Cholesky decomposition of Vphy. This is used to generate ## phylogenetic signal: a vector of independent normal random variables, ## when multiplied by the transpose of the Cholesky deposition of Vphy will ## have covariance matrix equal to Vphy. iD <- t(chol(V)) # Perform Nrep simulations and collect the results Nrep <- 100 cor.list <- matrix(0, nrow = Nrep, ncol = 1) cor.noM.list <- matrix(0, nrow = Nrep, ncol = 1) cor.noP.list <- matrix(0, nrow = Nrep, ncol = 1) cor.noMP.list <- matrix(0, nrow = Nrep, ncol = 1) d.list <- matrix(0, nrow = Nrep, ncol = 2) d.noM.list <- matrix(0, nrow = Nrep, ncol = 2) B.list <- matrix(0, nrow = Nrep, ncol = 3) B.noM.list <- matrix(0, nrow = Nrep, ncol = 3) B.noP.list <- matrix(0, nrow = Nrep, ncol = 3) for (rep in 1:Nrep) { XX <- iD %*% rnorm(2 * n) X <- matrix(XX, nrow = n, ncol = 2) rownames(X) <- phy$tip.label U <- list(NULL, matrix(rnorm(n, mean = 2, sd = 10), nrow = n, ncol = 1)) rownames(U[[2]]) <- phy$tip.label colnames(U[[2]]) <- "V1" X[,2] <- X[,2] + B2[1] * U[[2]][,1] - B2[1] * mean(U[[2]][,1]) z <- corphylo(X = X, SeM = SeM, U = U, phy = phy, method = "Nelder-Mead") z.noM <- corphylo(X = X, U = U, phy = phy, method = "Nelder-Mead") z.noP <- corphylo(X = X, SeM = SeM, U = U, phy = star, method = "Nelder-Mead") cor.list[rep] <- z$cor.matrix[1, 2] cor.noM.list[rep] <- z.noM$cor.matrix[1, 2] cor.noP.list[rep] <- z.noP$cor.matrix[1, 2] cor.noMP.list[rep] <- cor(cbind(lm(X[,1] ~ 1)$residuals, lm(X[,2] ~ U[[2]])$residuals))[1,2] d.list[rep, ] <- z$d d.noM.list[rep, ] <- z.noM$d B.list[rep, ] <- z$B B.noM.list[rep, ] <- z.noM$B B.noP.list[rep, ] <- z.noP$B show(c(rep, z$convcode, z$cor.matrix[1, 2], z$d)) } correlation <- rbind(R[1, 2], mean(cor.list), mean(cor.noM.list), mean(cor.noP.list), mean(cor.noMP.list)) rownames(correlation) <- c("True", "With SeM and Phy", "Without SeM", "Without Phy", "Without Phy or SeM") correlation signal.d <- rbind(d, colMeans(d.list), colMeans(d.noM.list)) rownames(signal.d) <- c("True", "With SeM and Phy", "Without SeM") signal.d est.B <- rbind(c(0, 0, B2), colMeans(B.list), colMeans(B.noM.list), colMeans(B.noP.list)) rownames(est.B) <- c("True", "With SeM and Phy", "Without SeM", "Without Phy") colnames(est.B) <- rownames(z$B) est.B # Example simulation output # correlation # [,1] # True 0.7000000 # With SeM and Phy 0.7055958 # Without SeM 0.3125253 # Without Phy 0.4054043 # Without Phy or SeM 0.3476589 # signal.d # [,1] [,2] # True 0.300000 0.9500000 # With SeM and Phy 0.301513 0.9276663 # Without SeM 0.241319 0.4872675 # est.B # B1.0 B2.0 B2.V1 # True 0.00000000 0.0000000 1.0000000 # With SeM and Phy -0.01285834 0.2807215 0.9963163 # Without SeM 0.01406953 0.3059110 0.9977796 # Without Phy 0.02139281 0.3165731 0.9942140 }} \keyword{regression} ape/man/vcv2phylo.Rd0000644000176200001440000000151314164530562014023 0ustar liggesusers\name{vcv2phylo} \alias{vcv2phylo} \title{Variance-Covariance Matrix to Tree} \description{ This function transforms a variance-covariance matrix into a phylogenetic tree. } \usage{ vcv2phylo(mat, tolerance = 1e-7) } \arguments{ \item{mat}{a square symmetric (positive-definite) matrix.} \item{tolerance}{the numeric tolerance used to compare the branch lengths.} } \details{ The function tests if the matrix is symmetric and positive-definite (i.e., all its eigenvalues positive within the specified tolerance). } \value{ an object of class \code{"phylo"}. } \author{Simon Blomberg} \seealso{ \code{\link{vcv}}, \code{\link{corPhyl}} } \examples{ tr <- rtree(10) V <- vcv(tr) # VCV matrix assuming Brownian motion z <- vcv2phylo(V) identical(tr, z) # FALSE all.equal(tr, z) # TRUE } \keyword{manip} \keyword{multivariate} ape/man/matexpo.Rd0000644000176200001440000000101514164530562013541 0ustar liggesusers\name{matexpo} \alias{matexpo} \title{Matrix Exponential} \usage{ matexpo(x) } \arguments{ \item{x}{a square matrix of mode numeric.} } \description{ This function computes the exponential of a square matrix using a spectral decomposition. } \value{ a numeric matrix of the same dimensions than `x'. } \author{Emmanuel Paradis} \examples{ ### a simple rate matrix: m <- matrix(0.1, 4, 4) diag(m) <- -0.3 ### towards equilibrium: for (t in c(1, 5, 10, 50)) print(matexpo(m*t)) } \keyword{array} \keyword{multivariate} ape/man/c.phylo.Rd0000644000176200001440000000367114164530562013452 0ustar liggesusers\name{c.phylo} \alias{c.phylo} \alias{c.multiPhylo} \alias{.compressTipLabel} \alias{.uncompressTipLabel} \title{Building Lists of Trees} \description{ These functions help to build lists of trees of class \code{"multiPhylo"}. } \usage{ \method{c}{phylo}(..., recursive = TRUE) \method{c}{multiPhylo}(..., recursive = TRUE) .compressTipLabel(x, ref = NULL) .uncompressTipLabel(x) } \arguments{ \item{\dots}{one or several objects of class \code{"phylo"} and/or \code{"multiPhylo"}.} \item{recursive}{see details.} \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{ref}{an optional vector of mode character to constrain the order of the tips. By default, the order from the first tree is used.} } \details{ These \code{c} methods check all the arguments, and return by default a list of single trees unless some objects are not trees or lists of trees, in which case \code{recursive} is switched to FALSE and a warning message is given. If \code{recursive = FALSE}, the objects are simply concatenated into a list. Before \pkg{ape} 4.0, \code{recursive} was always set to FALSE. \code{.compressTipLabel} transforms an object of class \code{"multiPhylo"} by checking that all trees have the same tip labels and renumbering the tips in the \code{edge} matrix so that the tip numbers are also the same taking the first tree as the reference (duplicated labels are not allowed). The returned object has a unique vector of tip labels (\code{attr(x, "TipLabel")}). \code{.uncompressTipLabel} does the reverse operation. } \value{ An object of class \code{"multiPhylo"}. } \author{Emmanuel Paradis} \seealso{\code{\link{summary.phylo}}, \code{\link{multiphylo}}} \examples{ x <- c(rtree(4), rtree(2)) x y <- c(rtree(4), rtree(4)) z <- c(x, y) z print(z, TRUE) try(.compressTipLabel(x)) # error a <- .compressTipLabel(y) .uncompressTipLabel(a) # back to y ## eventually compare str(a) and str(y) } \keyword{manip} ape/man/MPR.Rd0000644000176200001440000000446214164530562012533 0ustar liggesusers\name{MPR} \alias{MPR} \title{Most Parsimonious Reconstruction} \description{ This function does ancestral character reconstruction by parsimony as described in Hanazawa et al. (1995) and modified by Narushima and Hanazawa (1997). } \usage{ MPR(x, phy, outgroup) } \arguments{ \item{x}{a vector of integers.} \item{phy}{an object of class \code{"phylo"}; the tree must be unrooted and fully dichotomous.} \item{outgroup}{an integer or a character string giving the tip of \code{phy} used as outgroup.} } \details{ Hanazawa et al. (1995) and Narushima and Hanazawa (1997) used Farris's (1970) and Swofford and Maddison's (1987) framework to reconstruct ancestral states using parsimony. The character is assumed to take integer values. The algorithm finds the sets of values for each node as intervals with lower and upper values. It is recommended to root the tree with the outgroup before the analysis, so plotting the values with \code{\link{nodelabels}} is simple. } \value{ a matrix of integers with two columns named ``lower'' and ``upper'' giving the lower and upper values of the reconstructed sets for each node. } \references{ Farris, J. M. (1970) Methods for computing Wagner trees. \emph{Systematic Zoology}, \bold{19}, 83--92. Hanazawa, M., Narushima, H. and Minaka, N. (1995) Generating most parsimonious reconstructions on a tree: a generalization of the Farris--Swofford--Maddison method. \emph{Discrete Applied Mathematics}, \bold{56}, 245--265. Narushima, H. and Hanazawa, M. (1997) A more efficient algorithm for MPR problems in phylogeny. \emph{Discrete Applied Mathematics}, \bold{80}, 231--238. Swofford, D. L. and Maddison, W. P. (1987) Reconstructing ancestral character states under Wagner parsimony. \emph{Mathematical Biosciences}, \bold{87}, 199--229. }\author{Emmanuel Paradis} \seealso{ \code{\link{ace}}, \code{\link{root}}, \code{\link{nodelabels}} } \examples{ ## the example in Narushima and Hanazawa (1997): tr <- read.tree(text = "(((i,j)c,(k,l)b)a,(h,g)e,f)d;") x <- c(1, 3, 0, 6, 5, 2, 4) names(x) <- letters[6:12] (o <- MPR(x, tr, "f")) plot(tr) nodelabels(paste0("[", o[, 1], ",", o[, 2], "]")) tiplabels(x[tr$tip.label], adj = -2) ## some random data: x <- rpois(30, 1) tr <- rtree(30, rooted = FALSE) MPR(x, tr, "t1") } \keyword{models} ape/man/as.phylo.formula.Rd0000644000176200001440000000344314164530562015274 0ustar liggesusers\name{as.phylo.formula} \alias{as.phylo.formula} \title{Conversion from Taxonomy Variables to Phylogenetic Trees} \description{ The function \code{as.phylo.formula} (short form \code{as.phylo}) builds a phylogenetic tree (an object of class \code{phylo}) from a set of nested taxonomic variables. } \usage{ \method{as.phylo}{formula}(x, data = parent.frame(), collapse = TRUE, ...) } \arguments{ \item{x}{a right-side formula describing the taxonomic relationship: \code{~C1/C2/.../Cn}.} \item{data}{the data.frame where to look for the variables (default to user's workspace).} \item{collapse}{a logical value specifying whether to collapse single nodes in the returned tree (see details).} \item{\dots}{further arguments to be passed from other methods.} } \details{ Taxonomic variables must be nested and passed in the correct order: the higher clade must be on the left of the formula, for instance \code{~Order/Family/Genus/Species}. In most cases, the resulting tree will be unresolved and will contain polytomies. The option \code{collapse = FALSE} has for effect to add single nodes in the tree when a given higher level has only one element in the level below (e.g., a monospecific genus); see the example below. } \value{ an object of class \code{"phylo"}. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}, Eric Marcon and Klaus Schliep} \seealso{ \code{\link{as.phylo}}, \code{\link{read.tree}} for a description of \code{"phylo"} objects, \code{\link{multi2di}} } \examples{ data(carnivora) frm <- ~SuperFamily/Family/Genus/Species tr <- as.phylo(frm, data = carnivora, collapse=FALSE) tr$edge.length <- rep(1, nrow(tr$edge)) plot(tr, show.node.label=TRUE) Nnode(tr) ## compare with: Nnode(as.phylo(frm, data = carnivora, collapse = FALSE)) } \keyword{manip} ape/man/nj.Rd0000644000176200001440000000236014164530562012477 0ustar liggesusers\name{nj} \alias{nj} \title{Neighbor-Joining Tree Estimation} \description{ This function performs the neighbor-joining tree estimation of Saitou and Nei (1987). } \usage{ nj(X) } \arguments{ \item{X}{a distance matrix; may be an object of class ``dist''.} } \value{ an object of class \code{"phylo"}. } \references{ Saitou, N. and Nei, M. (1987) The neighbor-joining method: a new method for reconstructing phylogenetic trees. \emph{Molecular Biology and Evolution}, \bold{4}, 406--425. Studier, J. A. and Keppler, K. J. (1988) A note on the neighbor-joining algorithm of Saitou and Nei. \emph{Molecular Biology and Evolution}, \bold{5}, 729--731. } \author{Emmanuel Paradis} \seealso{ \code{\link{write.tree}}, \code{\link{read.tree}}, \code{\link{dist.dna}}, \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}} } \examples{ ### From Saitou and Nei (1987, Table 1): x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13, 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12, 5, 6, 10, 9, 13, 8) M <- matrix(0, 8, 8) M[lower.tri(M)] <- x M <- t(M) M[lower.tri(M)] <- x dimnames(M) <- list(1:8, 1:8) tr <- nj(M) plot(tr, "u") ### a less theoretical example data(woodmouse) trw <- nj(dist.dna(woodmouse)) plot(trw) } \keyword{models} ape/man/plot.varcomp.Rd0000644000176200001440000000121014164530562014505 0ustar liggesusers\name{plot.varcomp} \alias{plot.varcomp} \title{Plot Variance Components} \description{ Plot previously estimated variance components. } \usage{ \method{plot}{varcomp}(x, xlab = "Levels", ylab = "Variance", type = "b", ...) } \arguments{ \item{x}{ A \var{varcomp} object} \item{xlab}{ x axis label} \item{ylab}{ y axis label } \item{type}{ plot type ("l", "p" or "b", see \code{\link{plot}})} \item{\dots}{Further argument sent to the \code{\link[lattice]{xyplot}} function.} } \value{ The same as \code{\link[lattice]{xyplot}}. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}} \seealso{\code{\link{varcomp}}} \keyword{hplot} ape/man/is.binary.tree.Rd0000644000176200001440000000227314164530562014727 0ustar liggesusers\name{is.binary} \alias{is.binary} \alias{is.binary.phylo} \alias{is.binary.multiPhylo} \alias{is.binary.tree} \title{Test for Binary Tree} \description{ This function tests whether a phylogenetic tree is binary. } \usage{ is.binary(phy) \method{is.binary}{phylo}(phy) \method{is.binary}{multiPhylo}(phy) \method{is.binary}{tree}(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} } \details{ The test differs whether the tree is rooted or not. An urooted tree is considered binary if all its nodes are of degree three (i.e., three edges connect to each node). A rooted tree is considered binary if all nodes (including the root node) have exactly two descendant nodes, so that they are of degree three expect the root which is of degree 2. \code{is.binary.tree} is deprecated and will be removed soon: currently it calls \code{is.binary}. } \value{ a logical vector. } \seealso{ \code{\link{is.rooted}}, \code{\link{is.ultrametric}}, \code{\link{multi2di}} } \author{Emmanuel Paradis} \examples{ is.binary(rtree(10)) is.binary(rtree(10, rooted = FALSE)) is.binary(stree(10)) x <- setNames(rmtree(10, 10), LETTERS[1:10]) is.binary(x) } \keyword{logic} ape/man/cynipids.Rd0000644000176200001440000000152214164530562013711 0ustar liggesusers\name{data.nex} \docType{data} \alias{data.nex} \alias{cynipids} \title{NEXUS Data Example} \description{ Example of Protein data in NEXUS format (Maddison et al., 1997). Data is written in interleaved format using a single DATA block. Original data from Rokas et al (2002). } \usage{data(cynipids)} \format{ASCII text in NEXUS format} \references{ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an extensible file format for systematic information. \emph{Systematic Biology}, \bold{46}, 590--621. Rokas, A., Nylander, J. A. A., Ronquist, F. and Stone, G. N. (2002) A maximum likelihood analysis of eight phylogenetic markers in Gallwasps (Hymenoptera: Cynipidae): implications for insect phylogenetic studies. \emph{Molecular Phylogenetics and Evolution}, \bold{22}, 206--219. } \keyword{datasets} ape/man/coalescent.intervals.Rd0000644000176200001440000000275714164530562016230 0ustar liggesusers\name{coalescent.intervals} \alias{coalescent.intervals} \alias{coalescent.intervals.phylo} \alias{coalescent.intervals.default} \title{Coalescent Intervals} \usage{ coalescent.intervals(x) } \arguments{ \item{x}{either an ultra-metric phylogenetic tree (i.e. an object of class \code{"phylo"}) or, alternatively, a vector of interval lengths.} } \description{ This function extracts or generates information about coalescent intervals (number of lineages, interval lengths, interval count, total depth) from a phylogenetic tree or a list of internode distances. The input tree needs to be ultra-metric (i.e. clock-like). } \value{ An object of class \code{"coalescentIntervals"} with the following entries: \item{lineages}{ A vector with the number of lineages at the start of each coalescent interval.} \item{interval.length}{ A vector with the length of each coalescent interval.} \item{interval.count}{ The total number of coalescent intervals.} \item{total.depth}{ The sum of the lengths of all coalescent intervals.} } \seealso{ \code{\link{branching.times}}, \code{\link{collapsed.intervals}}, \code{\link{read.tree}}. } \author{Korbinian Strimmer} \examples{ data("hivtree.newick") # example tree in NH format tree.hiv <- read.tree(text = hivtree.newick) # load tree ci <- coalescent.intervals(tree.hiv) # from tree ci data("hivtree.table") # same tree, but in table format ci <- coalescent.intervals(hivtree.table$size) # from vector of interval lengths ci } \keyword{manip} ape/man/checkAlignment.Rd0000644000176200001440000000271414164530562015007 0ustar liggesusers\name{checkAlignment} \alias{checkAlignment} \title{Check DNA Alignments} \description{ This function performs a series of diagnostics on a DNA alignement. } \usage{ checkAlignment(x, check.gaps = TRUE, plot = TRUE, what = 1:4) } \arguments{ \item{x}{an object of class \code{"DNAbin"}.} \item{check.gaps}{a logical value specifying whether to check the distribution of alignment gaps.} \item{plot}{a logical value specifying whether to do the plots.} \item{what}{an integer value giving the plot to be done. By default, four plots are done on the same figure.} } \details{ This function prints on the console a series of diagnostics on the set a aligned DNA sequences. If alignment gaps are present, their width distribution is analysed, as well as the width of contiguous base segments. The pattern of nucleotide diversity on each site is also analysed, and a relevant table is printed. If \code{plot = TRUE}, four plots are done: an image of the alignement, the distribution of gap widths (if present), the Shannon index of nucleotide diversity along the sequence, and the number of observed bases along the sequence. If the sequences contain many gaps, it might be better to set \code{check.gaps = FALSE} to skip the analysis of contiguous segments. } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{alview}}, \code{\link{image.DNAbin}}, \code{\link{all.equal.DNAbin}} } \examples{ data(woodmouse) checkAlignment(woodmouse) layout(1) }ape/man/mvr.Rd0000644000176200001440000000221014164530562012666 0ustar liggesusers\name{mvr} \alias{mvr} \alias{mvrs} \title{Minimum Variance Reduction} \description{ Phylogenetic tree construction based on the minimum variance reduction. } \usage{ mvr(X, V) mvrs(X, V, fs = 15) } \arguments{ \item{X}{a distance matrix.} \item{V}{a variance matrix.} \item{fs}{agglomeration criterion parameter: it is coerced as an integer and must at least equal to one.} } \details{ The MVR method can be seen as a version of BIONJ which is not restricted to the Poison model of variance (Gascuel 2000). } \value{ an object of class \code{"phylo"}. } \references{ Criscuolo, A. and Gascuel, O. (2008). Fast NJ-like algorithms to deal with incomplete distance matrices. \emph{BMC Bioinformatics}, 9. Gascuel, O. (2000). Data model and classification by trees: the minimum variance reduction (MVR) method. \emph{Journal of Classification}, \bold{17}, 67--99. } \author{Andrei Popescu} \seealso{ \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}}, \code{\link{SDM}} } \examples{ data(woodmouse) rt <- dist.dna(woodmouse, variance = TRUE) v <- attr(rt, "variance") tr <- mvr(rt, v) plot(tr, "u") } \keyword{models} ape/man/parafit.Rd0000644000176200001440000001657414164530562013532 0ustar liggesusers\name{parafit} \alias{parafit} \alias{print.parafit} \alias{gopher.D} \alias{lice.D} \alias{HP.links} \title{ Test of host-parasite coevolution } \description{ Function \code{\link{parafit}} tests the hypothesis of coevolution between a clade of hosts and a clade of parasites. The null hypothesis (H0) of the global test is that the evolution of the two groups, as revealed by the two phylogenetic trees and the set of host-parasite association links, has been independent. Tests of individual host-parasite links are also available as an option. The method, which is described in detail in Legendre et al. (2002), requires some estimates of the phylogenetic trees or phylogenetic distances, and also a description of the host-parasite associations (H-P links) observed in nature. } \usage{ parafit(host.D, para.D, HP, nperm = 999, test.links = FALSE, seed = NULL, correction = "none", silent = FALSE) } \arguments{ \item{host.D }{ A matrix of phylogenetic or patristic distances among the hosts (object class: \code{matrix}, \code{data.frame} or \code{dist}). A matrix of patristic distances exactly represents the information in a phylogenetic tree. } \item{para.D }{ A matrix of phylogenetic or patristic distances among the parasites (object class: \code{matrix}, \code{data.frame} or \code{dist}). A matrix of patristic distances exactly represents the information in a phylogenetic tree. } \item{HP }{ A rectangular matrix with hosts as rows and parasites as columns. The matrix contains 1's when a host-parasite link has been observed in nature between the host in the row and the parasite in the column, and 0's otherwise. } \item{nperm}{ Number of permutations for the tests. If \code{nperm = 0}, permutation tests will not be computed. The default value is \code{nperm = 999}. For large data files, the permutation test is rather slow since the permutation procedure is not compiled. } \item{test.links }{ \code{test.links = TRUE} will test the significance of individual host-parasite links. Default: \code{test.links = FALSE}. } \item{seed }{ \code{seed = NULL} (default): a seed is chosen at random by the function. That seed is used as the starting point for all tests of significance, i.e. the global H-P test and the tests of individual H-P links if they are requested. Users can select a seed of their choice by giving any integer value to \code{seed}, for example \code{seed = -123456}. Running the function again with the same seed value will produce the exact same test results. } \item{correction}{ Correction methods for negative eigenvalues (details below): \code{correction="lingoes"} and \code{correction="cailliez"}. Default value: \code{"none"}. } \item{silent}{ Informative messages and the time to compute the tests will not be written to the \R console if silent=TRUE. Useful when the function is called by a numerical simulation function. } } \details{ Two types of test are produced by the program: a global test of coevolution and, optionally, a test on the individual host-parasite (H-P) link. The function computes principal coordinates for the host and the parasite distance matrices. The principal coordinates (all of them) act as a complete representation of either the phylogenetic distance matrix or the phylogenetic tree. Phylogenetic distance matrices are normally Euclidean. Patristic distance matrices are additive, thus they are metric and Euclidean. Euclidean matrices are fully represented by real-valued principal coordinate axes. For non-Euclidean matrices, negative eigenvalues are produced; complex principal coordinate axes are associated with the negative eigenvalues. So, the program rejects matrices that are not Euclidean and stops. Negative eigenvalues can be corrected for by one of two methods: the Lingoes or the Caillez correction. It is up to the user to decide which correction method should be applied. This is done by selecting the option \code{correction="lingoes"} or \code{correction="cailliez"}. Details on these correction methods are given in the help file of the \code{pcoa} function. The principle of the global test is the following (H0: independent evolution of the hosts and parasites): (1) Compute matrix D = C t(A) B. Note: D is a fourth-corner matrix (sensu Legendre et al. 1997), where A is the H-P link matrix, B is the matrix of principal coordinates computed from the host.D matrix, and C is the matrix of principal coordinates computed from the para.D matrix. (2) Compute the statistic ParaFitGlobal, the sum of squares of all values in matrix D. (3) Permute at random, separately, each row of matrix A, obtaining matrix A.perm. Compute D.perm = C %*% t(A.perm) %*% B, and from it, compute a permuted value ParaFitGlobal.perm for the statistic. Save this value in a vector trace.perm for the tests of individual links (below). (4) Repeat step 4 a large number of times. (5) Add the reference value of ParaFitGlobal to the distribution of ParaFitGlobal.perm values. Calculate the permutational probability associated to ParaFitGlobal. The test of each individual H-P link is carried out as follows (H0: this particular link is random): (1) Remove one link (k) from matrix A. (2) Compute matrix D = C t(A) B. (3a) Compute trace(k), the sum of squares of all values in matrix D. (3b) Compute the statistic ParaFitLink1 = (trace - trace(k)) where trace is the ParaFitGlobal statistic. (3c) Compute the statistic ParaFitLink2 = (trace - trace(k)) / (tracemax - trace) where tracemax is the maximum value that can be taken by trace. (4) Permute at random, separately, each row of matrix A, obtaining A.perm. Use the same sequences of permutations as were used in the test of ParaFitGlobal. Using the values of trace and trace.perm saved during the global test, compute the permuted values of the two statistics, ParaFit1.perm and ParaFit2.perm. (5) Repeat step 4 a large number of times. (6) Add the reference value of ParaFit1 to the distribution of ParaFit1.perm values; add the reference value of ParaFit2 to the distribution of ParaFit2.perm values. Calculate the permutational probabilities associated to ParaFit1 and ParaFit2. The \code{print.parafit} function prints out the results of the global test and, optionally, the results of the tests of the individual host-parasite links. } \value{ \item{ParaFitGlobal }{The statistic of the global H-P test. } \item{p.global }{The permutational p-value associated with the ParaFitGlobal statistic. } \item{link.table }{The results of the tests of individual H-P links, including the ParaFitLink1 and ParaFitLink2 statistics and the p-values obtained from their respective permutational tests. } \item{para.per.host }{Number of parasites per host. } \item{host.per.para }{Number of hosts per parasite. } \item{nperm }{Number of permutations for the tests. } } \author{ Pierre Legendre, Universite de Montreal } \references{ Hafner, M. S, P. D. Sudman, F. X. Villablanca, T. A. Spradling, J. W. Demastes and S. A. Nadler. 1994. Disparate rates of molecular evolution in cospeciating hosts and parasites. \emph{Science}, \bold{265}, 1087--1090. Legendre, P., Y. Desdevises and E. Bazin. 2002. A statistical test for host-parasite coevolution. \emph{Systematic Biology}, \bold{51(2)}, 217--234. } \seealso{\code{\link{pcoa}} } \examples{ ## Gopher and lice data from Hafner et al. (1994) data(gopher.D) data(lice.D) data(HP.links) res <- parafit(gopher.D, lice.D, HP.links, nperm=99, test.links=TRUE) # res # or else: print(res) } \keyword{ multivariate } ape/man/write.nexus.data.Rd0000644000176200001440000000557414164530562015305 0ustar liggesusers\name{write.nexus.data} \alias{write.nexus.data} \title{Write Character Data in NEXUS Format} \description{ This function writes in a file a list of data in the NEXUS format. The names of the vectors of the list are used as taxon names. For the moment, only sequence data (DNA or protein) are supported. } \usage{ write.nexus.data(x, file, format = "dna", datablock = TRUE, interleaved = TRUE, charsperline = NULL, gap = NULL, missing = NULL) } \arguments{ \item{x}{a matrix or a list of data each made of a single vector of mode character where each element is a character state (e.g., \dQuote{A}, \dQuote{C}, \dots) Objects of class of \dQuote{DNAbin} are accepted.} \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} \item{format}{a character string specifying the format of the sequences. Four choices are possible: \code{"dna"} (the default) \code{"protein"}, \code{"standard"} or \code{"continuous"} or any unambiguous abbreviation of these (case insensitive).} \item{datablock}{a logical, if \code{TRUE} the data are written in a single DATA block. If \code{FALSE}, the data are written in TAXA and CHARACTER blocks. Default is \code{TRUE}.} \item{interleaved}{a logical, if \code{TRUE} the data is written in interleaved format with number of characters per line as specified with \code{charsperline = numerical_value}. If \code{FALSE}, the data are written in sequential format. Default is \code{TRUE}.} \item{charsperline}{a numeric value specifying the number of characters per line when used with \code{interleaved = TRUE}. Default is 80.} \item{gap}{a character specifying the symbol for gap. Default is \dQuote{\code{-}}.} \item{missing}{a character specifying the symbol for missing data. Default is \dQuote{\code{?}}.} } \details{ If the sequences have no names, then they are given \dQuote{1}, \dQuote{2}, ..., as names in the file. Sequences must be all of the same length. } \value{ None (invisible \sQuote{NULL}). } \references{ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an extensible file format for systematic information. \emph{Systematic Biology}, \bold{46}, 590--621. } \author{Johan Nylander \email{nylander@scs.fsu.edu} and Thomas Guillerme} \seealso{ \code{\link{read.nexus}},\code{\link{write.nexus}}, \code{\link{read.nexus.data}} } \examples{ \dontrun{ ## Write interleaved DNA data with 100 characters per line in a DATA block data(woodmouse) write.nexus.data(woodmouse, file= "wood.ex.nex", interleaved = TRUE, charsperline = 100) ## Write sequential DNA data in TAXA and CHARACTERS blocks data(cynipids) write.nexus.data(cynipids, file = "cyn.ex.nex", format = "protein", datablock = FALSE, interleaved = FALSE) unlink(c("wood.ex.nex", "cyn.ex.nex")) }} \keyword{file} ape/man/node.depth.Rd0000644000176200001440000000226114164530562014120 0ustar liggesusers\name{node.depth} \alias{node.depth} \alias{node.depth.edgelength} \alias{node.height} \title{Depth and Heights of Nodes and Tips} \description{ These functions return the depths or heights of nodes and tips. } \usage{ node.depth(phy, method = 1) node.depth.edgelength(phy) node.height(phy, clado.style = FALSE) } \arguments{ \item{phy}{an object of class "phylo".} \item{method}{an integer value (1 or 2); 1: the node depths are proportional to the number of tips descending from each node, 2: they are evenly spaced.} \item{clado.style}{a logical value; if \code{TRUE}, the node heights are calculated for a cladogram.} } \details{ \code{node.depth} computes the depth of a node depending on the value of \code{method} (see the option \code{node.depth} in \code{\link{plot.phylo}}). The value of 1 is given to the tips. \code{node.depth.edgelength} does the same but using branch lengths. \code{node.height} computes the heights of nodes and tips as plotted by a phylogram or a cladogram. } \value{ A numeric vector indexed with the node numbers of the matrix `edge' of \code{phy}. } \author{Emmanuel Paradis} \seealso{\code{\link{plot.phylo}}} \keyword{manip} ape/man/is.monophyletic.Rd0000644000176200001440000000360614164530562015220 0ustar liggesusers\name{is.monophyletic} \alias{is.monophyletic} \title{ Is Group Monophyletic } \usage{ is.monophyletic(phy, tips, reroot = !is.rooted(phy), plot = FALSE, ...) } \description{ This function tests whether a list of tip labels is monophyletic on a given tree. } \arguments{ \item{phy}{ a phylogenetic tree description of class \code{"phylo"}. } \item{tips}{ a vector of mode numeric or character specifying the tips to be tested. } \item{reroot}{ a logical. If \code{FALSE}, then the input tree is not unrooted before the test. } \item{plot}{ a logical. If \code{TRUE}, then the tree is plotted with the specified group \code{tips} highlighted. } \item{\dots}{ further arguments passed to \code{plot}. } } \details{ If \code{phy} is rooted, the test is done on the rooted tree, otherwise the tree is first unrooted, then arbitrarily rerooted, in order to be independent on the current position of the root. That is, the test asks if \code{tips} could be monophyletic given any favourably rooting of \code{phy}. If \code{phy} is unrooted the test is done on an unrooted tree, unless \code{reroot = FALSE} is specified. If tip labels in the list \code{tips} are given as characters, they need to be spelled as in the object \code{phy}. } \value{ \code{TRUE} or \code{FALSE}. } \author{ Johan Nylander \email{jnylander@users.sourceforge.net} } \seealso{ \code{\link{which.edge}}, \code{\link{drop.tip}}, \code{\link{mrca}}. } \examples{ ## Test one monophyletic and one paraphyletic group on the bird.orders tree \dontrun{data("bird.orders")} \dontrun{is.monophyletic(phy = bird.orders, tips = c("Ciconiiformes", "Gruiformes"))} \dontrun{is.monophyletic(bird.orders, c("Passeriformes", "Ciconiiformes", "Gruiformes"))} \dontshow{\dontrun{rm(bird.orders)}} } \keyword{utilities} ape/man/rDNAbin.Rd0000644000176200001440000000262114164530562013345 0ustar liggesusers\name{rDNAbin} \alias{rDNAbin} \title{Random DNA Sequences} \description{ This function generates random sets of DNA sequences. } \usage{ rDNAbin(n, nrow, ncol, base.freq = rep(0.25, 4), prefix = "Ind_") } \arguments{ \item{n}{a vector of integers giving the lengths of the sequences. Can be missing in which case \code{nrow} and \code{ncol} must be given.} \item{nrow, ncol}{two single integer values giving the number of sequences and the number of sites, respectively (ignored if \code{n} is given).} \item{base.freq}{the base frequencies.} \item{prefix}{the prefix used to give labels to the sequences; by default these are Ind_1, \dots Ind_n (or Ind_nrow).} } \details{ If \code{n} is used, this function generates a list with sequence lengths given by the values in \code{n}. If \code{n} is missing, a matrix is generated. The purpose of this function is to generate a set of sequences of a specific size. To simulate sequences on a phylogenetic tree, see \code{\link[phangorn]{simSeq}} in \pkg{phangorn} (very efficient), and the package \pkg{phylosim} (more for pedagogy). } \value{ an object of class \code{"DNAbin"}. } \note{ It is not recommended to use this function to generate objects larger than two billion bases (2 Gb). } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}} } \examples{ rDNAbin(1:10) rDNAbin(rep(10, 10)) rDNAbin(nrow = 10, ncol = 10) } \keyword{datagen} ape/man/ladderize.Rd0000644000176200001440000000137714164530562014042 0ustar liggesusers\name{ladderize} \alias{ladderize} \title{Ladderize a Tree} \usage{ ladderize(phy, right = TRUE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{right}{a logical specifying whether the smallest clade is on the right-hand side (when the tree is plotted upwards), or the opposite (if \code{FALSE}).} } \description{ This function reorganizes the internal structure of the tree to get the ladderized effect when plotted. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{reorder.phylo}} } \examples{ tr <- rcoal(50) layout(matrix(1:4, 2, 2)) plot(tr, main = "normal") plot(ladderize(tr), main = "right-ladderized") plot(ladderize(tr, FALSE), main = "left-ladderized") layout(matrix(1, 1)) } \keyword{manip} ape/man/compar.lynch.Rd0000644000176200001440000000511014164530562014461 0ustar liggesusers\name{compar.lynch} \alias{compar.lynch} \title{Lynch's Comparative Method} \usage{ compar.lynch(x, G, eps = 1e-4) } \arguments{ \item{x}{eiher a matrix, a vector, or a data.frame containing the data with species as rows and variables as columns.} \item{G}{a matrix that can be interpreted as an among-species correlation matrix.} \item{eps}{a numeric value to detect convergence of the EM algorithm.} } \description{ This function computes the heritable additive value and the residual deviation for continous characters, taking into account the phylogenetic relationships among species, following the comparative method described in Lynch (1991). } \details{ The parameter estimates are computed following the EM (expectation-maximization) algorithm. This algorithm usually leads to convergence but may lead to local optima of the likelihood function. It is recommended to run several times the function in order to detect these potential local optima. The `optimal' value for \code{eps} depends actually on the range of the data and may be changed by the user in order to check the stability of the parameter estimates. Convergence occurs when the differences between two successive iterations of the EM algorithm leads to differences between both residual and additive values less than or equal to \code{eps}. } \note{ The present function does not perform the estimation of ancestral phentoypes as proposed by Lynch (1991). This will be implemented in a future version. } \value{ A list with the following components: \item{vare}{estimated residual variance-covariance matrix.} \item{vara}{estimated additive effect variance covariance matrix.} \item{u}{estimates of the phylogeny-wide means.} \item{A}{addtitive value estimates.} \item{E}{residual values estimates.} \item{lik}{logarithm of the likelihood for the entire set of observed taxon-specific mean.} } \references{ Lynch, M. (1991) Methods for the analysis of comparative data in evolutionary biology. \emph{Evolution}, \bold{45}, 1065--1080. } \author{Julien Claude \email{julien.claude@umontpellier.fr}} \seealso{ \code{\link{pic}}, \code{\link{compar.gee}} } \examples{ ### The example in Lynch (1991) cat("((((Homo:0.21,Pongo:0.21):0.28,", "Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);", file = "ex.tre", sep = "\n") tree.primates <- read.tree("ex.tre") unlink("ex.tre") X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259) compar.lynch(cbind(X, Y), G = vcv.phylo(tree.primates, cor = TRUE)) } \keyword{regression} ape/man/yule.cov.Rd0000644000176200001440000000773514164530562013647 0ustar liggesusers\name{yule.cov} \alias{yule.cov} \title{Fits the Yule Model With Covariates} \usage{ yule.cov(phy, formula, data = NULL) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{formula}{a formula specifying the model to be fitted.} \item{data}{the name of the data frame where the variables in \code{formula} are to be found; by default, the variables are looked for in the global environment.} } \description{ This function fits by maximum likelihood the Yule model with covariates, that is a birth-only model where speciation rate is determined by a generalized linear model. } \details{ The model fitted is a generalization of the Yule model where the speciation rate is determined by: \deqn{\ln\frac{\lambda_i}{1 - \lambda_i} = \beta_1 x_{i1} + \beta_2 x_{i2} + \dots + \alpha }{ln(li / (1 - li)) = b1 xi1 + b2 xi2 + ... a} where \eqn{\lambda_i}{li} is the speciation rate for species i, \eqn{x_{i1}, x_{i2}, \dots}{xi1, xi2, ...} are species-specific variables, and \eqn{\beta_1, \beta_2, \dots, \alpha}{b1, b2, ..., a} are parameters to be estimated. The term on the left-hand side above is a logit function often used in generalized linear models for binomial data (see \code{\link[stats]{family}}). The above model can be written in matrix form: \deqn{\mathrm{logit} \lambda_i = x_i' \beta}{logit li = xi' b} The standard-errors of the parameters are computed with the second derivatives of the log-likelihood function. (See References for other details on the estimation procedure.) The function needs three things: \itemize{ \item a phylogenetic tree which may contain multichotomies; \item a formula which specifies the predictors of the model described above: this is given as a standard \R formula and has no response (no left-hand side term), for instance: \code{~ x + y}, it can include interactions (\code{~ x + a * b}) (see \code{\link[stats]{formula}} for details); \item the predictors specified in the formula must be accessible to the function (either in the global space, or though the \code{data} option); they can be numeric vectors or factors. The length and the order of these data are important: the number of values (length) must be equal to the number of tips of the tree + the number of nodes. The order is the following: first the values for the tips in the same order than for the labels, then the values for the nodes sequentially from the root to the most terminal nodes (i.e., in the order given by \code{phy$edge}). } The user must obtain the values for the nodes separately. Note that the method in its present implementation assumes that the change in a species trait is more or less continuous between two nodes or between a node and a tip. Thus reconstructing the ancestral values with a Brownian motion model may be consistent with the present method. This can be done with the function \code{\link{ace}}. } \value{ A NULL value is returned, the results are simply printed. The output includes the deviance of the null (intercept-only) model and a likelihood-ratio test of the fitted model against the null model. Note that the deviance of the null model is different from the one returned by \code{\link{yule}} because of the different parametrizations. } \references{ Paradis, E. (2005) Statistical analysis of diversification with species traits. \emph{Evolution}, \bold{59}, 1--12. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.gof}}, \code{\link{diversi.time}}, \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule}} } \examples{ ### a simple example with some random data data(bird.orders) x <- rnorm(45) # the tree has 23 tips and 22 nodes ### the standard-error for x should be as large as ### the estimated parameter yule.cov(bird.orders, ~ x) ### another example with a tree that has a multichotomy data(bird.families) y <- rnorm(272) # 137 tips + 135 nodes yule.cov(bird.families, ~ y) } \keyword{models} ape/man/diversi.gof.Rd0000644000176200001440000000571414164530562014315 0ustar liggesusers\encoding{utf8} \name{diversi.gof} \alias{diversi.gof} \title{Tests of Constant Diversification Rates} \usage{ diversi.gof(x, null = "exponential", z = NULL) } \arguments{ \item{x}{a numeric vector with the branching times.} \item{null}{a character string specifying the null distribution for the branching times. Only two choices are possible: either \code{"exponential"}, or \code{"user"}.} \item{z}{used if \code{null = "user"}; gives the expected distribution under the model.} } \description{ This function computes two tests of the distribution of branching times using the \enc{Cramér}{Cramer}--von Mises and Anderson--Darling goodness-of-fit tests. By default, it is assumed that the diversification rate is constant, and an exponential distribution is assumed for the branching times. In this case, the expected distribution under this model is computed with a rate estimated from the data. Alternatively, the user may specify an expected cumulative density function (\code{z}): in this case, \code{x} and \code{z} must be of the same length. See the examples for how to compute the latter from a sample of expected branching times. } \details{ The \enc{Cramér}{Cramer}--von Mises and Anderson--Darling tests compare the empirical density function (EDF) of the observations to an expected cumulative density function. By contrast to the Kolmogorov--Smirnov test where the greatest difference between these two functions is used, in both tests all differences are taken into account. The distributions of both test statistics depend on the null hypothesis, and on whether or not some parameters were estimated from the data. However, these distributions are not known precisely and critical values were determined by Stephens (1974) using simulations. These critical values were used for the present function. } \value{ A NULL value is returned, the results are simply printed. } \references{ Paradis, E. (1998) Testing for constant diversification rates using molecular phylogenies: a general approach based on statistical tests for goodness of fit. \emph{Molecular Biology and Evolution}, \bold{15}, 476--479. Stephens, M. A. (1974) EDF statistics for goodness of fit and some comparisons. \emph{Journal of the American Statistical Association}, \bold{69}, 730--737. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.time}} \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{yule}}, \code{\link{yule.cov}} } \examples{ data(bird.families) x <- branching.times(bird.families) ### suppose we have a sample of expected branching times `y'; ### for simplicity, take them from a uniform distribution: y <- runif(500, 0, max(x) + 1) # + 1 to avoid A2 = Inf ### now compute the expected cumulative distribution: x <- sort(x) N <- length(x) ecdf <- numeric(N) for (i in 1:N) ecdf[i] <- sum(y <= x[i])/500 ### finally do the test: diversi.gof(x, "user", z = ecdf) } \keyword{univar} ape/man/CADM.global.Rd0000644000176200001440000002134414164530562014036 0ustar liggesusers\name{CADM.global} \alias{CADM} \alias{CADM.global} \alias{CADM.post} \title{ Congruence among distance matrices } \description{ Function \code{\link{CADM.global}} compute and test the coefficient of concordance among several distance matrices through a permutation test. Function \code{\link{CADM.post}} carries out a posteriori permutation tests of the contributions of individual distance matrices to the overall concordance of the group. Use in phylogenetic analysis: to identify congruence among distance matrices (D) representing different genes or different types of data. Congruent D matrices correspond to data tables that can be used together in a combined phylogenetic or other type of multivariate analysis. } \usage{ CADM.global(Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL, silent=FALSE) CADM.post (Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL, mult="holm", mantel=FALSE, silent=FALSE) } \arguments{ \item{Dmat}{ A text file listing the distance matrices one after the other, with or without blank lines in-between. Each matrix is in the form of a square distance matrix with 0's on the diagonal. } \item{nmat}{ Number of distance matrices in file Dmat. } \item{n}{ Number of objects in each distance matrix. All matrices must have the same number of objects. } \item{nperm}{ Number of permutations for the tests of significance. } \item{make.sym}{ TRUE: turn asymmetric matrices into symmetric matrices by averaging the two triangular portions. FALSE: analyse asymmetric matrices as they are. } \item{weights}{ A vector of positive weights for the distance matrices. Example: weights = c(1,2,3). NULL (default): all matrices have same weight in the calculation of W. } \item{mult}{ Method for correcting P-values in multiple testing. The methods are "holm" (default), "sidak", and "bonferroni". The Bonferroni correction is overly conservative; it is not recommended. It is included to allow comparisons with the other methods. } \item{mantel}{ TRUE: Mantel statistics will be computed from ranked distances, as well as permutational P-values. FALSE (default): Mantel statistics and tests will not be computed. } \item{silent}{ TRUE: informative messages will not be printed, but stopping messages will. Option useful for simulation work. FALSE: informative messages will be printed. } } \details{ \code{Dmat} must contain two or more distance matrices, listed one after the other, all of the same size, and corresponding to the same objects in the same order. Raw data tables can be transformed into distance matrices before comparison with other such distance matrices, or with data that have been obtained as distance matrices, e.g. serological or DNA hybridization data. The distances will be transformed to ranks before computation of the coefficient of concordance and other statistics. \code{CADM.global} tests the global null hypothesis that all matrices are incongruent. If the global null is rejected, function \code{CADM.post} can be used to identify the concordant (H0 rejected) and discordant matrices (H0 not rejected) in the group. If a distance matrix has a negative value for the \code{Mantel.mean} statistic, that matrix clearly does not belong to the group. Remove that matrix (if there are more than one, remove first the matrix that has the most strongly negative value for \code{Mantel.mean}) and run the analysis again. The corrections used for multiple testing are applied to the list of P-values (P) produced in the a posteriori tests; they take into account the number of tests (k) carried out simulatenously (number of matrices, parameter \code{nmat}). The Holm correction is computed after ordering the P-values in a list with the smallest value to the left. Compute adjusted P-values as: \deqn{P_{corr} = (k-i+1)*P}{P_corr = (k-i+1)*P} where i is the position in the ordered list. Final step: from left to right, if an adjusted \eqn{P_{corr}}{P_corr} in the ordered list is smaller than the one occurring at its left, make the smallest one equal to the largest one. The Sidak correction is: \deqn{P_{corr} = 1 - (1 - P)^k}{P_corr = 1 - (1 - P)^k} The Bonferonni correction is: \deqn{P_{corr} = k*P}{P_corr = k*P} } \value{ \code{CADM.global} produces a small table containing the W, Chi2, and Prob.perm statistics described in the following list. \code{CADM.post} produces a table stored in element \code{A_posteriori_tests}, containing Mantel.mean, Prob, and Corrected.prob statistics in rows; the columns correspond to the k distance matrices under study, labeled Dmat.1 to Dmat.k. If parameter \code{mantel} is TRUE, tables of Mantel statistics and P-values are computed among the matrices. \item{W }{Kendall's coefficient of concordance, W (Kendall and Babington Smith 1939; see also Legendre 2010). } \item{Chi2 }{Friedman's chi-square statistic (Friedman 1937) used in the permutation test of W. } \item{Prob.perm }{Permutational probability. } \item{Mantel.mean }{Mean of the Mantel correlations, computed on rank-transformed distances, between the distance matrix under test and all the other matrices in the study. } \item{Prob }{Permutational probabilities, uncorrected. } \item{Corrected prob }{Permutational probabilities corrected using the method selected in parameter \code{mult}. } \item{Mantel.cor }{Matrix of Mantel correlations, computed on rank-transformed distances, among the distance matrices. } \item{Mantel.prob }{One-tailed P-values associated with the Mantel correlations of the previous table. The probabilities are computed in the right-hand tail. H0 is tested against the alternative one-tailed hypothesis that the Mantel correlation under test is positive. No correction is made for multiple testing. } } \references{ Campbell, V., Legendre, P. and Lapointe, F.-J. (2009) Assessing congruence among ultrametric distance matrices. \emph{Journal of Classification}, \bold{26}, 103--117. Campbell, V., Legendre, P. and Lapointe, F.-J. (2011) The performance of the Congruence Among Distance Matrices (CADM) test in phylogenetic analysis. \emph{BMC Evolutionary Biology}, \bold{11}, 64. Friedman, M. (1937) The use of ranks to avoid the assumption of normality implicit in the analysis of variance. \emph{Journal of the American Statistical Association}, \bold{32}, 675--701. Kendall, M. G. and Babington Smith, B. (1939) The problem of m rankings. \emph{Annals of Mathematical Statistics}, \bold{10}, 275--287. Lapointe, F.-J., Kirsch, J. A. W. and Hutcheon, J. M. (1999) Total evidence, consensus, and bat phylogeny: a distance-based approach. \emph{Molecular Phylogenetics and Evolution}, \bold{11}, 55--66. Legendre, P. (2010) Coefficient of concordance. Pp. 164-169 in: Encyclopedia of Research Design, Vol. 1. N. J. Salkind, ed. SAGE Publications, Inc., Los Angeles. Legendre, P. and Lapointe, F.-J. (2004) Assessing congruence among distance matrices: single malt Scotch whiskies revisited. \emph{Australian and New Zealand Journal of Statistics}, \bold{46}, 615--629. Legendre, P. and Lapointe, F.-J. (2005) Congruence entre matrices de distance. P. 178-181 in: Makarenkov, V., G. Cucumel et F.-J. Lapointe [eds] Comptes rendus des 12emes Rencontres de la Societe Francophone de Classification, Montreal, 30 mai - 1er juin 2005. Siegel, S. and Castellan, N. J., Jr. (1988) \emph{Nonparametric statistics for the behavioral sciences. 2nd edition}. New York: McGraw-Hill. } \author{Pierre Legendre, Universite de Montreal} \examples{ # Examples 1 and 2: 5 genetic distance matrices computed from simulated DNA # sequences representing 50 taxa having evolved along additive trees with # identical evolutionary parameters (GTR+ Gamma + I). Distance matrices were # computed from the DNA sequence matrices using a p distance corrected with the # same parameters as those used to simulate the DNA sequences. See Campbell et # al. (2009) for details. # Example 1: five independent additive trees. Data provided by V. Campbell. data(mat5Mrand) res.global <- CADM.global(mat5Mrand, 5, 50) # Example 2: three partly similar trees, two independent trees. # Data provided by V. Campbell. data(mat5M3ID) res.global <- CADM.global(mat5M3ID, 5, 50) res.post <- CADM.post(mat5M3ID, 5, 50, mantel=TRUE) # Example 3: three matrices respectively representing Serological # (asymmetric), DNA hybridization (asymmetric) and Anatomical (symmetric) # distances among 9 families. Data from Lapointe et al. (1999). data(mat3) res.global <- CADM.global(mat3, 3, 9, nperm=999) res.post <- CADM.post(mat3, 3, 9, nperm=999, mantel=TRUE) # Example 4, showing how to bind two D matrices (cophenetic matrices # in this example) into a file using rbind(), then run the global test. a <- rtree(5) b <- rtree(5) A <- cophenetic(a) B <- cophenetic(b) x <- rownames(A) B <- B[x, x] M <- rbind(A, B) CADM.global(M, 2, 5) } \keyword{ multivariate } \keyword{ nonparametric } ape/man/diversity.contrast.test.Rd0000644000176200001440000001022314164530562016721 0ustar liggesusers\name{diversity.contrast.test} \alias{diversity.contrast.test} \title{Diversity Contrast Test} \description{ This function performs the diversity contrast test comparing pairs of sister-clades. } \usage{ diversity.contrast.test(x, method = "ratiolog", alternative = "two.sided", nrep = 0, ...) } \arguments{ \item{x}{a matrix or a data frame with at least two columns: the first one gives the number of species in clades with a trait supposed to increase or decrease diversification rate, and the second one the number of species in the sister-clades without the trait. Each row represents a pair of sister-clades.} \item{method}{a character string specifying the kind of test: \code{"ratiolog"} (default), \code{"proportion"}, \code{"difference"}, \code{"logratio"}, or any unambiguous abbreviation of these.} \item{alternative}{a character string defining the alternative hypothesis: \code{"two.sided"} (default), \code{"less"}, \code{"greater"}, or any unambiguous abbreviation of these.} \item{nrep}{the number of replications of the randomization test; by default, a Wilcoxon test is done.} \item{\dots}{arguments passed to the function \code{\link[stats]{wilcox.test}}.} } \details{ If \code{method = "ratiolog"}, the test described in Barraclough et al. (1996) is performed. If \code{method = "proportion"}, the version in Barraclough et al. (1995) is used. If \code{method = "difference"}, the signed difference is used (Sargent 2004). If \code{method = "logratio"}, then this is Wiegmann et al.'s (1993) version. These four tests are essentially different versions of the same test (Vamosi and Vamosi 2005, Vamosi 2007). See Paradis (2012) for a comparison of their statistical performance with other tests. If \code{nrep = 0}, a Wilcoxon test is done on the species diversity contrasts with the null hypothesis is that they are distributed around zero. If \code{nrep > 0}, a randomization procedure is done where the signs of the diversity contrasts are randomly chosen. This is used to create a distribution of the test statistic which is compared with the observed value (the sum of the diversity contrasts). } \value{ a single numeric value with the \emph{P}-value. } \references{ Barraclough, T. G., Harvey, P. H. and Nee, S. (1995) Sexual selection and taxonomic diversity in passerine birds. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{259}, 211--215. Barraclough, T. G., Harvey, P. H., and Nee, S. (1996) Rate of \emph{rbc}L gene sequence evolution and species diversification in flowering plants (angiosperms). \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{263}, 589--591. Paradis, E. (2012) Shift in diversification in sister-clade comparisons: a more powerful test. \emph{Evolution}, \bold{66}, 288--295. Sargent, R. D. (2004) Floral symmetry affects speciation rates in angiosperms. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{271}, 603--608. Vamosi, S. M. (2007) Endless tests: guidelines for analysing non-nested sister-group comparisons. An addendum. \emph{Evolutionary Ecology Research}, \bold{9}, 717. Vamosi, S. M. and Vamosi, J. C. (2005) Endless tests: guidelines for analysing non-nested sister-group comparisons. \emph{Evolutionary Ecology Research}, \bold{7}, 567--579. Wiegmann, B., Mitter, C. and Farrell, B. 1993. Diversification of carnivorous parasitic insects: extraordinary radiation or specialized dead end? \emph{American Naturalist}, \bold{142}, 737--754. } \author{Emmanuel Paradis} \seealso{ \code{\link{slowinskiguyer.test}}, \code{\link{mcconwaysims.test}} \code{\link{richness.yule.test}} } \examples{ ### data from Vamosi & Vamosi (2005): fleshy <- c(1, 1, 1, 1, 1, 3, 3, 5, 9, 16, 33, 40, 50, 100, 216, 393, 850, 947,1700) dry <- c(2, 64, 300, 89, 67, 4, 34, 10, 150, 35, 2, 60, 81, 1, 3, 1, 11, 1, 18) x <- cbind(fleshy, dry) diversity.contrast.test(x) diversity.contrast.test(x, alt = "g") diversity.contrast.test(x, alt = "g", nrep = 1e4) slowinskiguyer.test(x) mcconwaysims.test(x) } \keyword{htest} ape/man/rtt.Rd0000644000176200001440000000512514164530562012703 0ustar liggesusers\name{rtt} \alias{rtt} \title{Root a Tree by Root-to-Tip Regression} \description{ This function roots a phylogenetic tree with dated tips in the location most compatible with the assumption of a strict molecular clock. } \usage{ rtt(t, tip.dates, ncpu = 1, objective = correlation, opt.tol = .Machine$double.eps^0.25) } \arguments{ \item{t}{an object of class \code{"phylo"}.} \item{tip.dates}{a vector of sampling times associated to the tips of \code{t}, in the same order as \code{t$tip.label}.} \item{ncpu}{number of cores to use.} \item{objective}{one of \code{"correlation"}, \code{"rms"}, or \code{"rsquared"}.} \item{opt.tol}{tolerance for optimization precision.} } \details{ This function duplicates one part the functionality of the program Path-O-Gen (see references). The root position is chosen to produce the best linear regression of root-to-tip distances against sampling times. \code{t} must have branch lengths in units of expected substitutions per site. \code{tip.dates} should be a vector of sampling times, in any time unit, with time increasing toward the present. For example, this may be in units of ``days since study start'' or ``years since 10,000 BCE'', but not ``millions of yearsago''. Setting \code{ncpu} to a value larger than 1 requires the \code{parallel} library. \code{objective} is the measure which will be used to define the ``goodness'' of a regression fit. It may be one of \code{"correlation"} (strongest correlation between tip date and distance from root), \code{"rms"} (lowest root-mean-squared error), or \code{"rsquared"} (highest R-squared value). \code{opt.tol} is used to optimize the location of the root along the best branch. By default, R's \code{optimize} function uses a precision of \code{.Machine$double.eps^0.25}, which is about 0.0001 on a 64-bit system. This should be set to a smaller value if the branch lengths of \code{t} are very short. } \value{ an object of class \code{"phylo"}. } \note{ This function only chooses the best root. It does not rescale the branch lengths to time, or perform a statistical test of the molecular clock hypothesis. } \author{ Rosemary McCloskey\email{rmccloskey@cfenet.ubc.ca}, Emmanuel Paradis } \references{ Rambaut, A. (2009). Path-O-Gen: temporal signal investigation tool. Rambaut, A. (2000). Estimating the rate of molecular evolution: incorporating non-contemporaneous sequences into maximum likelihood phylogenies. \emph{Bioinformatics}, \bold{16}, 395-399. } \examples{ t <- rtree(100) tip.date <- rnorm(t$tip.label)^2 rtt(t, tip.date) } ape/man/rTraitCont.Rd0000644000176200001440000000747014164530562014170 0ustar liggesusers\name{rTraitCont} \alias{rTraitCont} \title{Continuous Character Simulation} \usage{ rTraitCont(phy, model = "BM", sigma = 0.1, alpha = 1, theta = 0, ancestor = FALSE, root.value = 0, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{model}{a character (either \code{"BM"} or \code{"OU"}) or a function specifying the model (see details).} \item{sigma}{a numeric vector giving the standard-deviation of the random component for each branch (can be a single value).} \item{alpha}{if \code{model = "OU"}, a numeric vector giving the strength of the selective constraint for each branch (can be a single value).} \item{theta}{if \code{model = "OU"}, a numeric vector giving the optimum for each branch (can be a single value).} \item{ancestor}{a logical value specifying whether to return the values at the nodes as well (by default, only the values at the tips are returned).} \item{root.value}{a numeric giving the value at the root.} \item{\dots}{further arguments passed to \code{model} if it is a function.} } \description{ This function simulates the evolution of a continuous character along a phylogeny. The calculation is done recursively from the root. See Paradis (2012, pp. 232 and 324) for an introduction. } \details{ There are three possibilities to specify \code{model}: \itemize{ \item{\code{"BM"}:}{a Browian motion model is used. If the arguments \code{sigma} has more than one value, its length must be equal to the the branches of the tree. This allows to specify a model with variable rates of evolution. You must be careful that branch numbering is done with the tree in ``postorder'' order: to see the order of the branches you can use: \code{tr <- reorder(tr, "po"); plor(tr); edgelabels()}. The arguments \code{alpha} and \code{theta} are ignored.} \item{\code{"OU"}:}{an Ornstein-Uhlenbeck model is used. The above indexing rule is used for the three parameters \code{sigma}, \code{alpha}, and \code{theta}. This may be interesting for the last one to model varying phenotypic optima. The exact updating formula from Gillespie (1996) are used which are reduced to BM formula if \code{alpha = 0}.} \item{A function:}{it must be of the form \code{foo(x, l)} where \code{x} is the trait of the ancestor and \code{l} is the branch length. It must return the value of the descendant. The arguments \code{sigma}, \code{alpha}, and \code{theta} are ignored.} }} \value{ A numeric vector with names taken from the tip labels of \code{phy}. If \code{ancestor = TRUE}, the node labels are used if present, otherwise, ``Node1'', ``Node2'', etc. } \references{ Gillespie, D. T. (1996) Exact numerical simulation of the Ornstein-Uhlenbeck process and its integral. \emph{Physical Review E}, \bold{54}, 2084--2091. Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{rTraitDisc}}, \code{\link{rTraitMult}}, \code{\link{ace}} } \examples{ data(bird.orders) rTraitCont(bird.orders) # BM with sigma = 0.1 ### OU model with two optima: tr <- reorder(bird.orders, "postorder") plot(tr) edgelabels() theta <- rep(0, Nedge(tr)) theta[c(1:4, 15:16, 23:24)] <- 2 ## sensitive to 'alpha' and 'sigma': rTraitCont(tr, "OU", theta = theta, alpha=.1, sigma=.01) ### an imaginary model with stasis 0.5 time unit after a node, then ### BM evolution with sigma = 0.1: foo <- function(x, l) { if (l <= 0.5) return(x) x + (l - 0.5)*rnorm(1, 0, 0.1) } tr <- rcoal(20, br = runif) rTraitCont(tr, foo, ancestor = TRUE) ### a cumulative Poisson process: bar <- function(x, l) x + rpois(1, l) (x <- rTraitCont(tr, bar, ancestor = TRUE)) plot(tr, show.tip.label = FALSE) Y <- x[1:20] A <- x[-(1:20)] nodelabels(A) tiplabels(Y) } \keyword{datagen} ape/man/corMartins.Rd0000644000176200001440000000571414164530562014217 0ustar liggesusers\name{corMartins} \alias{corMartins} \alias{coef.corMartins} \alias{corMatrix.corMartins} \title{Martins's (1997) Correlation Structure} \usage{ corMartins(value, phy, form = ~1, fixed = FALSE) \method{coef}{corMartins}(object, unconstrained = TRUE, ...) \method{corMatrix}{corMartins}(object, covariate = getCovariate(object), corr = TRUE, ...) } \arguments{ \item{value}{The \eqn{\alpha}{alpha} parameter} \item{phy}{An object of class \code{phylo} representing the phylogeny (with branch lengths) to consider} \item{object}{An (initialized) object of class \code{corMartins}} \item{corr}{a logical value. If 'TRUE' the function returns the correlation matrix, otherwise it returns the variance/covariance matrix.} \item{fixed}{an optional logical value indicating whether the coefficients should be allowed to vary in the optimization, ok kept fixed at their initial value. Defaults to 'FALSE', in which case the coefficients are allowed to vary.} \item{form}{a one sided formula of the form ~ t, or ~ t | g, specifying the taxa covariate t and, optionally, a grouping factor g. A covariate for this correlation structure must be character valued, with entries matching the tip labels in the phylogenetic tree. When a grouping factor is present in form, the correlation structure is assumed to apply only to observations within the same grouping level; observations with different grouping levels are assumed to be uncorrelated. Defaults to ~ 1, which corresponds to using the order of the observations in the data as a covariate, and no groups.} \item{covariate}{an optional covariate vector (matrix), or list of covariate vectors (matrices), at which values the correlation matrix, or list of correlation matrices, are to be evaluated. Defaults to getCovariate(object).} \item{unconstrained}{a logical value. If 'TRUE' the coefficients are returned in unconstrained form (the same used in the optimization algorithm). If 'FALSE' the coefficients are returned in "natural", possibly constrained, form. Defaults to 'TRUE'} \item{\dots}{some methods for these generics require additional arguments. None are used in these methods.} } \description{ Martins and Hansen's (1997) covariance structure: \deqn{V_{ij} = \gamma \times e^{-\alpha t_{ij}}}{% Vij = gamma . exp(-alpha . tij)} where \eqn{t_{ij}}{tij} is the phylogenetic distance between taxa \eqn{i}{i} and \eqn{j}{j} and \eqn{\gamma}{gamma} is a constant. } \value{ An object of class \code{corMartins} or the alpha coefficient from an object of this class or the correlation matrix of an initialized object of this class. } \author{Julien Dutheil \email{dutheil@evolbio.mpg.de}} \seealso{ \code{\link{corClasses}}. } \references{ Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative method: a general approach to incorporating phylogenetic information into the analysis of interspecific data. \emph{American Naturalist}, \bold{149}, 646--667. } \keyword{models} ape/man/lmorigin.Rd0000644000176200001440000001216614164530562013715 0ustar liggesusers\name{lmorigin} \alias{lmorigin} \alias{print.lmorigin} \alias{lmorigin.ex1} \alias{lmorigin.ex2} \title{ Multiple regression through the origin } \description{ Function \code{\link{lmorigin}} computes a multiple linear regression and performs tests of significance of the equation parameters (F-test of R-square and t-tests of regression coefficients) using permutations. The regression line can be forced through the origin. Testing the significance in that case requires a special permutation procedure. This option was developed for the analysis of independent contrasts, which requires regression through the origin. A permutation test, described by Legendre & Desdevises (2009), is needed to analyze contrasts that are not normally distributed. } \usage{ lmorigin(formula, data, origin=TRUE, nperm=999, method=NULL, silent=FALSE) } \arguments{ \item{formula }{ A formula specifying the bivariate model, as in \code{\link{lm}} and \code{\link{aov}}. } \item{data}{ A data frame containing the two variables specified in the formula. } \item{origin}{ \code{origin = TRUE} (default) to compute regression through the origin; \code{origin = FALSE} to compute multiple regression with estimation of the intercept. } \item{nperm}{ Number of permutations for the tests. If \code{nperm = 0}, permutation tests will not be computed. The default value is \code{nperm = 999}. For large data files, the permutation test is rather slow since the permutation procedure is not compiled. } \item{method}{ \code{method = "raw"} computes t-tests of the regression coefficients by permutation of the raw data. \code{method = "residuals"} computes t-tests of the regression coefficients by permutation of the residuals of the full model. If \code{method = NULL}, permutation of the raw data is used to test the regression coefficients in regression through the origin; permutation of the residuals of the full model is used to test the regression coefficients in ordinary multiple regression. } \item{silent}{ Informative messages and the time to compute the tests will not be written to the \R console if silent=TRUE. Useful when the function is called by a numerical simulation function. } } \details{ The permutation F-test of R-square is always done by permutation of the raw data. When there is a single explanatory variable, permutation of the raw data is used for the t-test of the single regression coefficient, whatever the method chosen by the user. The rationale is found in Anderson & Legendre (1999). The \code{print.lmorigin} function prints out the results of the parametric tests (in all cases) and the results of the permutational tests (when nperm > 0). } \value{ \item{reg }{The regression output object produced by function \code{lm}. } \item{p.param.t.2tail }{Parametric probabilities for 2-tailed tests of the regression coefficients. } \item{p.param.t.1tail }{Parametric probabilities for 1-tailed tests of the regression coefficients. Each test is carried out in the direction of the sign of the coefficient. } \item{p.perm.t.2tail }{Permutational probabilities for 2-tailed tests of the regression coefficients. } \item{p.perm.t.1tail }{Permutational probabilities for 1-tailed tests of the regression coefficients. Each test is carried out in the direction of the sign of the coefficient. } \item{p.perm.F }{Permutational probability for the F-test of R-square. } \item{origin }{TRUE is regression through the origin has been computed, FALSE if multiple regression with estimation of the intercept has been used. } \item{nperm }{Number of permutations used in the permutation tests. } \item{method }{Permutation method for the t-tests of the regression coefficients: \code{method = "raw"} or \code{method = "residuals"}. } \item{var.names }{Vector containing the names of the variables used in the regression. } \item{call }{The function call.} } \author{ Pierre Legendre, Universite de Montreal } \references{ Anderson, M. J. and Legendre, P. (1999) An empirical comparison of permutation methods for tests of partial regression coefficients in a linear model. \emph{Journal of Statistical Computation and Simulation}, \bold{62}, 271--303. Legendre, P. and Desdevises, Y. (2009) Independent contrasts and regression through the origin. \emph{Journal of Theoretical Biology}, \bold{259}, 727--743. Sokal, R. R. and Rohlf, F. J. (1995) \emph{Biometry - The principles and practice of statistics in biological research. Third edition.} New York: W. H. Freeman. } \examples{ ## Example 1 from Sokal & Rohlf (1995) Table 16.1 ## SO2 air pollution in 41 cities of the USA data(lmorigin.ex1) out <- lmorigin(SO2 ~ ., data=lmorigin.ex1, origin=FALSE, nperm=99) out ## Example 2: Contrasts computed on the phylogenetic tree of Lamellodiscus ## parasites. Response variable: non-specificity index (NSI); explanatory ## variable: maximum host size. Data from Table 1 of Legendre & Desdevises ## (2009). data(lmorigin.ex2) out <- lmorigin(NSI ~ MaxHostSize, data=lmorigin.ex2, origin=TRUE, nperm=99) out ## Example 3: random numbers y <- rnorm(50) X <- as.data.frame(matrix(rnorm(250),50,5)) out <- lmorigin(y ~ ., data=X, origin=FALSE, nperm=99) out } \keyword{ multivariate } ape/man/is.compatible.Rd0000644000176200001440000000134414164530562014622 0ustar liggesusers\name{is.compatible} \alias{is.compatible} \alias{is.compatible.bitsplits} \alias{arecompatible} \title{Check Compatibility of Splits} \description{ \code{is.compatible} is a generic function with a method for the class \code{"bitsplits"}. It checks whether a set of splits is compatible using the \code{arecompatible} function. } \usage{ is.compatible(obj) \method{is.compatible}{bitsplits}(obj) arecompatible(x, y, n) } \arguments{ \item{obj}{an object of class \code{"bitsplits"}.} \item{x, y}{a vector of mode raw\code{}.} \item{n}{the number of taxa in the splits.} } \value{ \code{TRUE} if the splits are compatible, \code{FALSE} otherwise. } \author{Andrei Popescu} \seealso{\code{\link{as.bitsplits}}} \keyword{manip} ape/man/stree.Rd0000644000176200001440000000252414164530562013214 0ustar liggesusers\name{stree} \alias{stree} \title{Generates Systematic Regular Trees} \usage{ stree(n, type = "star", tip.label = NULL) } \arguments{ \item{n}{an integer giving the number of tips in the tree.} \item{type}{a character string specifying the type of tree to generate; four choices are possible: \code{"star"}, \code{"balanced"}, \code{"left"}, \code{"right"}, or any unambiguous abbreviation of these.} \item{tip.label}{a character vector giving the tip labels; if not specified, the tips "t1", "t2", ..., are given.} } \description{ This function generates trees with regular shapes. } \details{ The types of trees generated are: \itemize{ \item{``star''}{a star (or comb) tree with a single internal node.} \item{``balanced''}{a fully balanced dichotomous rooted tree; \code{n} must be a power of 2 (2, 4, 8, \dots).} \item{``left''}{a fully unbalanced rooted tree where the largest clade is on the left-hand side when the tree is plotted upwards.} \item{``right''}{same than above but in the other direction.} } } \value{ An object of class \code{"phylo"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{compute.brlen}}, \code{\link{rtree}} } \examples{ layout(matrix(1:4, 2, 2)) plot(stree(100)) plot(stree(128, "balanced")) plot(stree(100, "left")) plot(stree(100, "right")) } \keyword{datagen} ape/man/pic.Rd0000644000176200001440000000530514164530562012645 0ustar liggesusers\name{pic} \alias{pic} \title{Phylogenetically Independent Contrasts} \description{ Compute the phylogenetically independent contrasts using the method described by Felsenstein (1985). } \usage{ pic(x, phy, scaled = TRUE, var.contrasts = FALSE, rescaled.tree = FALSE) } \arguments{ \item{x}{a numeric vector.} \item{phy}{an object of class \code{"phylo"}.} \item{scaled}{logical, indicates whether the contrasts should be scaled with their expected variances (default to \code{TRUE}).} \item{var.contrasts}{logical, indicates whether the expected variances of the contrasts should be returned (default to \code{FALSE}).} \item{rescaled.tree}{logical, if \code{TRUE} the rescaled tree is returned together with the main results.} } \details{ If \code{x} has names, its values are matched to the tip labels of \code{phy}, otherwise its values are taken to be in the same order than the tip labels of \code{phy}. The user must be careful here since the function requires that both series of names perfectly match. If both series of names do not match, the values in the \code{x} are taken to be in the same order than the tip labels of \code{phy}, and a warning message is issued. } \value{ either a vector of phylogenetically independent contrasts (if \code{var.contrasts = FALSE}), or a two-column matrix with the phylogenetically independent contrasts in the first column and their expected variance in the second column (if \code{var.contrasts = TRUE}). If the tree has node labels, these are used as labels of the returned object. If \code{rescaled.tree = TRUE}, a list is returned with two elements named ``contr'' with the above results and ``rescaled.tree'' with the tree and its rescaled branch lengths (see Felsenstein 1985). } \references{ Felsenstein, J. (1985) Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1--15. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{compar.gee}}, \code{\link{compar.lynch}}, \code{\link{pic.ortho}}, \code{\link{varCompPhylip}} } \examples{ ### The example in Phylip 3.5c (originally from Lynch 1991) cat("((((Homo:0.21,Pongo:0.21):0.28,", "Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);", file = "ex.tre", sep = "\n") tree.primates <- read.tree("ex.tre") X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259) names(X) <- names(Y) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago") pic.X <- pic(X, tree.primates) pic.Y <- pic(Y, tree.primates) cor.test(pic.X, pic.Y) lm(pic.Y ~ pic.X - 1) # both regressions lm(pic.X ~ pic.Y - 1) # through the origin unlink("ex.tre") # delete the file "ex.tre" } \keyword{regression} ape/man/nodepath.Rd0000644000176200001440000000142714164530562013675 0ustar liggesusers\name{nodepath} \alias{nodepath} \title{Find Paths of Nodes} \description{ This function finds paths of nodes in a tree. The nodes can be internal and/or terminal (i.e., tips). } \usage{ nodepath(phy, from = NULL, to = NULL) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{from, to}{integers giving node or tip numbers.} } \details{ By default, this function returns all the paths from the root to each tip of the tree. If both arguments \code{from} and \code{to} are specified, the shortest path of nodes linking them is returned. } \value{ a list of vectors of integers (by default), or a single vector of integers. } \author{Emmanuel Paradis} \seealso{\code{\link{getMRCA}}} \examples{ tr <- rtree(2) nodepath(tr) nodepath(tr, 1, 2) } \keyword{manip} ape/man/yule.Rd0000644000176200001440000000326314164530562013051 0ustar liggesusers\name{yule} \alias{yule} \title{Fits the Yule Model to a Phylogenetic Tree} \usage{ yule(phy, use.root.edge = FALSE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{use.root.edge}{a logical specifying whether to consider the root edge in the calculations.} } \description{ This function fits by maximum likelihood a Yule model, i.e., a birth-only model to the branching times computed from a phylogenetic tree. } \details{ The tree must be fully dichotomous. The maximum likelihood estimate of the speciation rate is obtained by the ratio of the number of speciation events on the cumulative number of species through time; these two quantities are obtained with the number of nodes in the tree, and the sum of the branch lengths, respectively. If there is a `root.edge' element in the phylogenetic tree, and \code{use.root.edge = TRUE}, then it is assumed that it has a biological meaning and is counted as a branch length, and the root is counted as a speciation event; otherwise the number of speciation events is the number of nodes - 1. The standard-error of lambda is computed with the second derivative of the log-likelihood function. } \value{ An object of class "yule" which is a list with the following components: \item{lambda}{the maximum likelihood estimate of the speciation (birth) rate.} \item{se}{the standard-error of lambda.} \item{loglik}{the log-likelihood at its maximum.} } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.gof}}, \code{\link{diversi.time}}, \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule.cov}} } \keyword{models} ape/man/subtreeplot.Rd0000644000176200001440000000347314164530562014446 0ustar liggesusers\name{subtreeplot} \alias{subtreeplot} \title{Zoom on a Portion of a Phylogeny by Successive Clicks} \description{ This function plots simultaneously a whole phylogenetic tree (supposedly large) and a portion of it determined by clicking on the nodes of the phylogeny. On exit, returns the last subtree visualized. } \usage{ subtreeplot(x, wait=FALSE, ...) } \arguments{ \item{x}{an object of class \code{"phylo"}.} \item{wait}{a logical indicating whether the node beeing processed should be printed (useful for big phylogenies).} \item{\dots}{further arguments passed to \code{plot.phylo}.} } \details{ This function aims at easily exploring very large trees. The main argument is a phylogenetic tree, and the second one is a logical indicating whether a waiting message should be printed while the calculation is being processed. The whole tree is plotted on the left-hand side in half of the device. The subtree is plotted on the right-hand side in the other half. The user clicks on the nodes in the complete tree and the subtree corresponding to this node is ploted in the right-hand side. There is no limit for the number of clicks that can be done. On exit, the subtree on the right hand side is returned. To use a subtree as the new tree in which to zoom, the user has to use the function many times. This can however be done in a single command line (see example 2). } \author{Damien de Vienne \email{damien.de-vienne@u-psud.fr}} \seealso{ \code{\link{plot.phylo}}, \code{\link{drop.tip}}, \code{\link{subtrees}} } \examples{ \dontrun{ #example 1: simple tree1 <- rtree(50) tree2 <- subtreeplot(tree1, wait = TRUE) # on exit, tree2 will be a subtree of tree1 #example 2: more than one zoom tree1 <- rtree(60) tree2 <- subtreeplot(subtreeplot(subtreeplot(tree1))) # allow three succssive zooms } } \keyword{hplot} ape/man/compar.ou.Rd0000644000176200001440000001054414164530562013776 0ustar liggesusers\name{compar.ou} \alias{compar.ou} \title{Ornstein--Uhlenbeck Model for Continuous Characters} \usage{ compar.ou(x, phy, node = NULL, alpha = NULL) } \arguments{ \item{x}{a numeric vector giving the values of a continuous character.} \item{phy}{an object of class \code{"phylo"}.} \item{node}{a vector giving the number(s) of the node(s) where the parameter `theta' (the trait optimum) is assumed to change. The node(s) can be specified with their labels if \code{phy} has node labels. By default there is no change (same optimum thoughout lineages).} \item{alpha}{the value of \eqn{\alpha}{alpha} to be used when fitting the model. By default, this parameter is estimated (see details).} } \description{ This function fits an Ornstein--Uhlenbeck model giving a phylogenetic tree, and a continuous character. The user specifies the node(s) where the optimum changes. The parameters are estimated by maximum likelihood; their standard-errors are computed assuming normality of these estimates. } \details{ The Ornstein--Uhlenbeck (OU) process can be seen as a generalization of the Brownian motion process. In the latter, characters are assumed to evolve randomly under a random walk, that is change is equally likely in any direction. In the OU model, change is more likely towards the direction of an optimum (denoted \eqn{\theta}{theta}) with a strength controlled by a parameter denoted \eqn{\alpha}{alpha}. The present function fits a model where the optimum parameter \eqn{\theta}{theta}, is allowed to vary throughout the tree. This is specified with the argument \code{node}: \eqn{\theta}{theta} changes after each node whose number is given there. Note that the optimum changes \emph{only} for the lineages which are descendants of this node. Hansen (1997) recommends to not estimate \eqn{\alpha}{alpha} together with the other parameters. The present function allows this by giving a numeric value to the argument \code{alpha}. By default, this parameter is estimated, but this seems to yield very large standard-errors, thus validating Hansen's recommendation. In practice, a ``poor man estimation'' of \eqn{\alpha}{alpha} can be done by repeating the function call with different values of \code{alpha}, and selecting the one that minimizes the deviance (see Hansen 1997 for an example). If \code{x} has names, its values are matched to the tip labels of \code{phy}, otherwise its values are taken to be in the same order than the tip labels of \code{phy}. The user must be careful here since the function requires that both series of names perfectly match, so this operation may fail if there is a typing or syntax error. If both series of names do not match, the values in the \code{x} are taken to be in the same order than the tip labels of \code{phy}, and a warning message is issued. } \note{ The inversion of the variance-covariance matrix in the likelihood function appeared as somehow problematic. The present implementation uses a Cholevski decomposition with the function \code{\link[base]{chol2inv}} instead of the usual function \code{\link[base]{solve}}. } \value{ an object of class \code{"compar.ou"} which is list with the following components: \item{deviance}{the deviance (= -2 * loglik).} \item{para}{a data frame with the maximum likelihood estimates and their standard-errors.} \item{call}{the function call.} } \references{ Hansen, T. F. (1997) Stabilizing selection and the comparative analysis of adaptation. \emph{Evolution}, \bold{51}, 1341--1351. } \author{Emmanuel Paradis} \seealso{ \code{\link{ace}}, \code{\link{compar.lynch}}, \code{\link{corBrownian}}, \code{\link{corMartins}}, \code{\link{pic}} } \examples{ data(bird.orders) ### This is likely to give you estimates close to 0, 1, and 0 ### for alpha, sigma^2, and theta, respectively: compar.ou(x <- rnorm(23), bird.orders) ### Much better with a fixed alpha: compar.ou(x, bird.orders, alpha = 0.1) ### Let us 'mimick' the effect of different optima ### for the two clades of birds... x <- c(rnorm(5, 0), rnorm(18, 5)) ### ... the model with two optima: compar.ou(x, bird.orders, node = 25, alpha = .1) ### ... and the model with a single optimum: compar.ou(x, bird.orders, node = NULL, alpha = .1) ### => Compare both models with the difference in deviances ## which follows a chi^2 with df = 1. } \keyword{models} ape/man/dnds.Rd0000644000176200001440000000501614164530562013021 0ustar liggesusers\name{dnds} \alias{dnds} \title{dN/dS Ratio} \description{ This function computes the pairwise ratios dN/dS for a set of aligned DNA sequences using Li's (1993) method. } \usage{ dnds(x, code = 1, codonstart = 1, quiet = FALSE, details = FALSE, return.categories = FALSE) } \arguments{ \item{x}{an object of class \code{"DNAbin"} (matrix or list) with the aligned sequences.} \item{code}{an integer value giving the genetic code to be used. Currently, the codes 1 to 6 are supported.} \item{codonstart}{an integer giving where to start the translation. This should be 1, 2, or 3, but larger values are accepted and have for effect to start the translation further within the sequence.} \item{quiet}{single logical value: whether to indicate progress of calculations.} \item{details}{single logical value (see details).} \item{return.categories}{a logical value: if \code{TRUE}, a matrix of the same size than \code{x} is returned giving the degeneracy category of each base in the original alignment.} } \details{ Since \pkg{ape} 5.6, the degeneracy of each codon is calculated directly from the genetic code using the function \code{\link{trans}}. A consequence is that ambiguous bases are ignored (see \code{\link{solveAmbiguousBases}}). If \code{details = TRUE}, a table is printed for each pair of sequences giving the numbers of transitions and transversions for each category of degeneracy (nondegenerate, twofold, and fourfold). This is helpful when non-meaningful values are returned (e.g., NaN, Inf, negative values). } \value{ an object of class \code{"dist"}, or a numeric matrix if \code{return.categories = TRUE}. } \references{ Li, W.-H. (1993) Unbiased estimation of the rates of synonymous and nonsynonymous substitution. \emph{Journal of Molecular Evolution}, \bold{36}, 96--99. } \author{Emmanuel Paradis} \seealso{ \code{\link{AAbin}}, \code{\link{trans}}, \code{\link{alview}}, \code{\link{solveAmbiguousBases}} } \examples{ data(woodmouse) res <- dnds(woodmouse, quiet = TRUE) # NOT correct res2 <- dnds(woodmouse, code = 2, quiet = TRUE) # using the correct code identical(res, res2) ## There a few N's in the woodmouse data, but this does not affect ## greatly the results: res3 <- dnds(solveAmbiguousBases(woodmouse), code = 2, quiet = TRUE) cor(res, res3) ## a simple example showing the usefulness of 'details = TRUE' X <- as.DNAbin(matrix(c("C", "A", "G", "G", "T", "T"), 2, 3)) alview(X) dnds(X, quiet = TRUE) # NaN + warnings dnds(X, details = TRUE) # only a TV at a nondegenerate site }ape/man/cophenetic.phylo.Rd0000644000176200001440000000165114164530562015345 0ustar liggesusers\name{cophenetic.phylo} \alias{cophenetic.phylo} \alias{dist.nodes} \title{Pairwise Distances from a Phylogenetic Tree} \usage{ \method{cophenetic}{phylo}(x) dist.nodes(x) } \arguments{ \item{x}{an object of class \code{"phylo"}.} } \description{ \code{cophenetic.phylo} computes the pairwise distances between the pairs of tips from a phylogenetic tree using its branch lengths. \code{dist.nodes} does the same but between all nodes, internal and terminal, of the tree. } \value{ a numeric matrix with colnames and rownames set to the names of the tips (as given by the element \code{tip.label} of the argument \code{phy}), or, in the case of \code{dist.nodes}, the numbers of the tips and the nodes (as given by the element \code{edge}). } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}} to read tree files in Newick format, \code{\link[stats]{cophenetic}} for the generic function } \keyword{manip} ape/man/read.GenBank.Rd0000644000176200001440000000664414164530562014320 0ustar liggesusers\name{read.GenBank} \alias{read.GenBank} \title{Read DNA Sequences from GenBank via Internet} \usage{ read.GenBank(access.nb, seq.names = access.nb, species.names = TRUE, as.character = FALSE, chunk.size = 400, quiet = TRUE) } \description{ This function connects to the GenBank database, and reads nucleotide sequences using accession numbers given as arguments. } \arguments{ \item{access.nb}{a vector of mode character giving the accession numbers.} \item{seq.names}{the names to give to each sequence; by default the accession numbers are used.} \item{species.names}{a logical indicating whether to attribute the species names to the returned object.} \item{as.character}{a logical controlling whether to return the sequences as an object of class \code{"DNAbin"} (the default).} \item{chunk.size}{the number of sequences downloaded together (see details).} \item{quiet}{a logical value indicating whether to show the progress of the downloads. If \code{TRUE}, will also print the (full) name of the FASTA file containing the downloaded sequences.} } \details{ The function uses the site \url{https://www.ncbi.nlm.nih.gov/} from where the sequences are retrieved. If \code{species.names = TRUE}, the returned list has an attribute \code{"species"} containing the names of the species taken from the field ``ORGANISM'' in GenBank. Since \pkg{ape} 3.6, this function retrieves the sequences in FASTA format: this is more efficient and more flexible (scaffolds and contigs can be read) than what was done in previous versions. The option \code{gene.names} has been removed in \pkg{ape} 5.4; this information is also present in the description. Setting \code{species.names = FALSE} is much faster (could be useful if you read a series of scaffolds or contigs, or if you already have the species names). The argument \code{chunk.size} is set by default to 400 which is likely to work in many cases. If an error occurs such as ``Cannot open file \dots'' showing the list of the accession numbers, then you may try decreasing \code{chunk.size} to 200 or 300. If \code{quiet = FALSE}, the display is done chunk by chunk, so the message ``Downloading sequences: 400 / 400 ...'' means that the download from sequence 1 to sequence 400 is under progress (it is not possible to display a more accurate message because the download method depends on the platform). } \value{ A list of DNA sequences made of vectors of class \code{"DNAbin"}, or of single characters (if \code{as.character = TRUE}) with two attributes (species and description). } \seealso{ \code{\link{read.dna}}, \code{\link{write.dna}}, \code{\link{dist.dna}}, \code{\link{DNAbin}} } \author{Emmanuel Paradis} \examples{ ## This won't work if your computer is not connected ## to the Internet ## Get the 8 sequences of tanagers (Ramphocelus) ## as used in Paradis (1997) ref <- c("U15717", "U15718", "U15719", "U15720", "U15721", "U15722", "U15723", "U15724") ## Copy/paste or type the following commands if you ## want to try them. \dontrun{ Rampho <- read.GenBank(ref) ## get the species names: attr(Rampho, "species") ## build a matrix with the species names and the accession numbers: cbind(attr(Rampho, "species"), names(Rampho)) ## print the first sequence ## (can be done with `Rampho$U15717' as well) Rampho[[1]] ## the description from each FASTA sequence: attr(Rampho, "description") } } \keyword{IO} ape/DESCRIPTION0000644000176200001440000001377514166047412012547 0ustar liggesusersPackage: ape Version: 5.6-1 Date: 2021-12-27 Title: Analyses of Phylogenetics and Evolution Authors@R: c(person("Emmanuel", "Paradis", role = c("aut", "cre", "cph"), email = "Emmanuel.Paradis@ird.fr", comment = c(ORCID = "0000-0003-3092-2199")), person("Simon", "Blomberg", role = c("aut", "cph"), comment = c(ORCID = "0000-0003-1062-0839")), person("Ben", "Bolker", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-2127-0443")), person("Joseph", "Brown", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-3835-8062")), person("Santiago", "Claramunt", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-8926-5974")), person("Julien", "Claude", role = c("aut", "cph"), , comment = c(ORCID = "0000-0002-9267-1228")), person("Hoa Sien", "Cuong", role = c("aut", "cph")), person("Richard", "Desper", role = c("aut", "cph")), person("Gilles", "Didier", role = c("aut", "cph"), comment = c(ORCID = "0000-0003-0596-9112")), person("Benoit", "Durand", role = c("aut", "cph")), person("Julien", "Dutheil", role = c("aut", "cph"), comment = c(ORCID = "0000-0001-7753-4121")), person("RJ", "Ewing", role = c("aut", "cph")), person("Olivier", "Gascuel", role = c("aut", "cph")), person("Thomas", "Guillerme", role = c("aut", "cph"), comment = c(ORCID = "0000-0003-4325-1275")), person("Christoph", "Heibl", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-7655-3299")), person("Anthony", "Ives", role = c("aut", "cph"), comment = c(ORCID = "0000-0001-9375-9523")), person("Bradley", "Jones", role = c("aut", "cph"), comment = c(ORCID = "0000-0003-4498-1069")), person("Franz", "Krah", role = c("aut", "cph"), comment = c(ORCID = "0000-0001-7866-7508")), person("Daniel", "Lawson", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-5311-6213")), person("Vincent", "Lefort", role = c("aut", "cph")), person("Pierre", "Legendre", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-3838-3305")), person("Jim", "Lemon", role = c("aut", "cph")), person("Guillaume", "Louvel", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-7745-0785")), person("Eric", "Marcon", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-5249-321X")), person("Rosemary", "McCloskey", role = c("aut", "cph"), comment = c(ORCID = "0000-0002-9772-8553")), person("Johan", "Nylander", role = c("aut", "cph")), person("Rainer", "Opgen-Rhein", role = c("aut", "cph")), person("Andrei-Alin", "Popescu", role = c("aut", "cph")), person("Manuela", "Royer-Carenzi", role = c("aut", "cph")), person("Klaus", "Schliep", role = c("aut", "cph"), comment = c(ORCID = "0000-0003-2941-0161")), person("Korbinian", "Strimmer", role = c("aut", "cph"), comment = c(ORCID = "0000-0001-7917-2056")), person("Damien", "de Vienne", role = c("aut", "cph"), comment = c(ORCID = "0000-0001-9532-5251"))) Depends: R (>= 3.2.0) Suggests: gee, expm, igraph, phangorn Imports: nlme, lattice, graphics, methods, stats, tools, utils, parallel, Rcpp (>= 0.12.0) LinkingTo: Rcpp ZipData: no Description: Functions for reading, writing, plotting, and manipulating phylogenetic trees, analyses of comparative data in a phylogenetic framework, ancestral character analyses, analyses of diversification and macroevolution, computing distances from DNA sequences, reading and writing nucleotide sequences as well as importing from BioConductor, and several tools such as Mantel's test, generalized skyline plots, graphical exploration of phylogenetic data (alex, trex, kronoviz), estimation of absolute evolutionary rates and clock-like trees using mean path lengths and penalized likelihood, dating trees with non-contemporaneous sequences, translating DNA into AA sequences, and assessing sequence alignments. Phylogeny estimation can be done with the NJ, BIONJ, ME, MVR, SDM, and triangle methods, and several methods handling incomplete distance matrices (NJ*, BIONJ*, MVR*, and the corresponding triangle method). Some functions call external applications (PhyML, Clustal, T-Coffee, Muscle) whose results are returned into R. License: GPL-2 | GPL-3 URL: http://ape-package.ird.fr/ Encoding: UTF-8 NeedsCompilation: yes Packaged: 2022-01-03 08:20:07 UTC; paradis Author: Emmanuel Paradis [aut, cre, cph] (), Simon Blomberg [aut, cph] (), Ben Bolker [aut, cph] (), Joseph Brown [aut, cph] (), Santiago Claramunt [aut, cph] (), Julien Claude [aut, cph] (), Hoa Sien Cuong [aut, cph], Richard Desper [aut, cph], Gilles Didier [aut, cph] (), Benoit Durand [aut, cph], Julien Dutheil [aut, cph] (), RJ Ewing [aut, cph], Olivier Gascuel [aut, cph], Thomas Guillerme [aut, cph] (), Christoph Heibl [aut, cph] (), Anthony Ives [aut, cph] (), Bradley Jones [aut, cph] (), Franz Krah [aut, cph] (), Daniel Lawson [aut, cph] (), Vincent Lefort [aut, cph], Pierre Legendre [aut, cph] (), Jim Lemon [aut, cph], Guillaume Louvel [aut, cph] (), Eric Marcon [aut, cph] (), Rosemary McCloskey [aut, cph] (), Johan Nylander [aut, cph], Rainer Opgen-Rhein [aut, cph], Andrei-Alin Popescu [aut, cph], Manuela Royer-Carenzi [aut, cph], Klaus Schliep [aut, cph] (), Korbinian Strimmer [aut, cph] (), Damien de Vienne [aut, cph] () Maintainer: Emmanuel Paradis Repository: CRAN Date/Publication: 2022-01-07 14:32:42 UTC ape/build/0000755000176200001440000000000014164530667012132 5ustar liggesusersape/build/vignette.rds0000644000176200001440000000040414164530667014467 0ustar liggesusersRM @]?P"n "]\K]Y/s:{o, !:15 B֤NI,gELŁk!)_!H"PۚjzoHYy-7z ˢ WsmMkdj`̧>UұMzyHR a<1'XY y%Efk\ TUutOi)Ў*N90\ape/build/partial.rdb0000644000176200001440000001655714164530636014271 0ustar liggesusers]VHY Yl" ^ LyiMJS=S-2)eIJcڧs1tO\SfRDH$3sByo]ƪ4MzNti]DNhZ7l>h9=m{ߝ,Nzic"j۬Z﯑"V)¿s_GV.NZ{-j_o|/yH7'B@+JzaÝW OF* TNBcYR1agKx+sH1gH^ʒ 3zq$ 3<(Kj_xN7ȵM i#VxZQg9Fɾ?}cO]0۾lS7!mJ! r4^} "Wē.v\eǰ ,M0\I)6z"C%yWF:$bM@ݑ(y"ţ;b7 \>e͇/8=cOi&>0aOhCbSi/>fy_!Ht18TӲ\Ht>qJ~TkT5.w]_nΊF,]0, 5ϴtӍڮ Ɇؕt+NgxR63C,3R^F8lh'I5􈕨ɯDn2Xoc+n!l0x|, GW__ x_|? G/yG! 3;FE2*_)9E43h@֎1g?r/n1zƵ,WSECɌHK1H\Uk HBxt/o H0awbZ~vD9 #zKw=˱kkGb7! *hejY!"5 u3kźMC',C $,>D8SZ7_T~:4r]b9)tsU,<Z騀/PoD1b֏lo3J hrIY/'in@es. ,yG=y28셔t fz=}+(湀x2ωJ{bR@<7}8 ]xZk,+TwuG|Sx̯UY0SizpgߴvhǏo X&v-c1C*}7kTۭ<؎jYJ{M("D^Ouw&$_縣WgY:Ug~qk8Wh-Z8I>| [-X5[8& [4zH-|P\/U0< Ziy7YY1KzEG&dfRcOV$sJYTԽާӦ-srQe]q'=q8 # 4+koO犷O =fs0UZ<"l[O1m$ ])aHƁSRM?] i(SHt edZV>+U HMx<7KZw=eZh砤ܿO.^:(I ˠ+x:%gG%sR TNFZlf+JHY랒og@OK7֤(Bkh[hX^]Tgz]̥F'[9:h+T.>Hw]d<'(lǡH-[<ʟ̄+WRCKJ2={Ruq.7ZvZv:g{+!)hW'vZsWS\l8vygw_TliaތloIb>{K \`x:[.c%ŝ'1r!Cʽct,@wvUލ#3zHi# B2 jw;5L3VW]aGo`;zr!ɨņec7L,@UI<*6<%fwP+_V4+ 4l'\˳ K֠H sgR_<6セ,1?ܝ>02M&-}#[0>ӯ:>c? F#+P r62l%Ap'#ɹބ铜WvsHtm)<: M캁AOAKaI%I.'A+ uK_>B̦elCz WEwgD @gw3bx2_)NAbX;.-My#OK4)S1Y0COYhdyhb-{e!1'4t Xx!ag9Rz{6U1|D~ɮA=O>>oeLJKӦ_Vgd,phf5,G }}$8&Q&vזXݟHUY{"ᦁϵΎB>f"Gsɒd==jd+пF&gSk2egaŮ[`sk1`0at|؁@k+@ VTɶ\l8@_$Ojn(j5/V2h+b/o(T$&,-駮/G'J%klx48Ἤ5: T鮝w G&Gӊ-xTxRP I[(p&#vdg7Aw0xCJ]n'ؚW4{iڪhp $NL eytE`ҳ.LwLRDFlEfn⭌c~)t puVS\*!Q&Zǎq`vGHb{*S85ܶdmd\ZGm^f%p~",zlE - `b6ٺ=xf?y5we~~oo/_*ӝ.d%:̹Μoۯcryٙ; _/z  oOTv_~^O Qo`:WmŠCL7J+w0y9?%Jy$}z#Is8 ]/;U$ mnc$tF7am$7'COj}̾VZ&Qru@Mm=QP0phfJQ| $ 3 tO1j .ܖ$݄ZiA^WA??ĕ=+ɢ$!Gv+0]:VkA@ OVYcU~ϭ5ݝeQWuO`_JV䟡RBa[ʊl0M:jwtQ*קgӝ4B%'Up˴M-^K$%d̳sLR"(jY(+N'^T{j<Ѯԛov z1p"\>J'$;Z7wk<~:J9]#7'ӏ'[|wnn%iwcXA+ԅOjPSu=}xU7+?~㮬?Pʶ9=989s8籸_\x<_+[i݄{^xVxP  tvVKm"CPF&-BnT$z_aͦ+Za./Ɩ9J7j(6-{1nM/N.a">3wMҕ`?7`郈(/?g[-6z@'>j$䴻~#] B#qTddŲ+Fōf2`8Y(o#R~!!8; e-FJOFmyAs0}ڿ&\[TyҫfyEњ{OfT$ex2fOWU7*eS`",_׽]I`|8z\{9Tɸ,̲W뛛X\Y\|}sR;졗[O?ӬEl_l@1T[C<# WLK=1n fwz>fВzR$M# RŘLоC|b%xðe !U4Ш}Mc ,0Ρ]wJmfiOM5).єm ѕ'$ 5 5< V-$]_84 `#uگ;Fc-W֩e M 107 vmnp\v+&ARmV+m׌z;,8 h'd_-:et28&Ŷv[* >i)ܭ(vuz_P7YyH98t[r8izΫ +^gbOĵm1״LGHB 5yQD j_8GY޶6adC-}?1_5~'1޽}} k@̻cB,cyw1:^OWo|o孅 ʋf,";ǟ JSf('Xct&jCV#edhj0Rz>B5>v,O[ k_Ujape/src/0000755000176200001440000000000014164530667011622 5ustar liggesusersape/src/dist_nodes.c0000644000176200001440000000263614164530562014122 0ustar liggesusers/* dist_nodes.c 2012-08-14 */ /* Copyright 2012 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #define DINDEX2(i, j) i + NM * j /* The algorithm is pretty simple: the tree must be in cladewise order because the edges are visited contiguously. Each edge gives trivially one distance, then by moving up along the edge matrix, one finds nodes that have already been visited and the distance matrix can be updated. */ void dist_nodes(int *n, int *m, int *e1, int *e2, double *el, int *N, double *D) /* n: nb of tips, m: nb of nodes, N: nb of edges */ { int i, j, k, a, d, NM = *n + *m, ROOT; double x; ROOT = e1[0]; d = e2[0]; /* the 2 nodes of the 1st edge */ D[DINDEX2(ROOT, d)] = D[DINDEX2(d, ROOT)] = el[0]; /* the 1st edge gives the 1st distance */ /* go down along the edge matrix starting at the 2nd edge: */ for (i = 1; i < *N; i++) { a = e1[i]; d = e2[i]; x = el[i]; /* get the i-th nodes and branch length */ D[DINDEX2(a, d)] = D[DINDEX2(d, a)] = x; /* then go up along the edge matrix from the i-th edge to visit the nodes already visited and update the distances: */ for (j = i - 1; j >= 0; j--) { k = e2[j]; if (k == a) continue; D[DINDEX2(k, d)] = D[DINDEX2(d, k)] = D[DINDEX2(a, k)] + x; } if (k != ROOT) D[DINDEX2(ROOT, d)] = D[DINDEX2(d, ROOT)] = D[DINDEX2(ROOT, a)] + x; } } ape/src/me.h0000644000176200001440000000635314164530562012375 0ustar liggesusers/* me.h 2012-04-30 */ /* Copyright 2007-2008 Vincent Lefort, modified by Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #ifndef NONE #define NONE 0 #endif #ifndef UP #define UP 1 #endif #ifndef DOWN #define DOWN 2 #endif #ifndef LEFT #define LEFT 3 #endif #ifndef RIGHT #define RIGHT 4 #endif #ifndef SKEW #define SKEW 5 #endif #ifndef MAX_LABEL_LENGTH #define MAX_LABEL_LENGTH 30 #endif //#ifndef NODE_LABEL_LENGTH //#define NODE_LABEL_LENGTH 30 //#endif #ifndef EDGE_LABEL_LENGTH #define EDGE_LABEL_LENGTH 30 #endif #ifndef MAX_DIGITS #define MAX_DIGITS 20 #endif /* #ifndef INPUT_SIZE */ /* #define INPUT_SIZE 100 */ /* #endif */ #ifndef MAX_INPUT_SIZE #define MAX_INPUT_SIZE 100000 #endif #ifndef EPSILON #define EPSILON 1.E-06 #endif #ifndef ReadOpenParenthesis #define ReadOpenParenthesis 0 #endif #ifndef ReadSubTree #define ReadSubTree 1 #endif #ifndef ReadLabel #define ReadLabel 2 #endif #ifndef ReadWeight #define ReadWeight 3 #endif #ifndef AddEdge #define AddEdge 4 #endif #define XINDEX(i, j) n*(i - 1) - i*(i - 1)/2 + j - i - 1 typedef struct word { char name[MAX_LABEL_LENGTH]; struct word *suiv; } WORD; typedef struct pointers { WORD *head; WORD *tail; } POINTERS; typedef struct node { int label; /* char label[NODE_LABEL_LENGTH]; */ struct edge *parentEdge; struct edge *leftEdge; struct edge *middleEdge; struct edge *rightEdge; int index; int index2; } node; typedef struct edge { char label[EDGE_LABEL_LENGTH]; struct node *tail; /*for edge (u,v), u is the tail, v is the head*/ struct node *head; int bottomsize; /*number of nodes below edge */ int topsize; /*number of nodes above edge */ double distance; double totalweight; } edge; typedef struct tree { char name[MAX_LABEL_LENGTH]; struct node *root; int size; double weight; } tree; typedef struct set { struct node *firstNode; struct set *secondNode; } set; void me_b(double *X, int *N, int *labels, int *nni, int *spr, int *tbr, int *edge1, int *edge2, double *el); void me_o(double *X, int *N, int *labels, int *nni, int *edge1, int *edge2, double *el); double **initDoubleMatrix(int d); double **loadMatrix (double *X, int *labels, int n, set *S); set *addToSet(node *v, set *X); node *makeNewNode(int label, int i); node *makeNode(int label, edge *parentEdge, int index); node *copyNode(node *v); edge *siblingEdge(edge *e); edge *makeEdge(char *label, node *tail, node *head, double weight); tree *newTree(); void updateSizes(edge *e, int direction); tree *detrifurcate(tree *T); void compareSets(tree *T, set *S); void partitionSizes(tree *T); edge *depthFirstTraverse(tree *T, edge *e); edge *findBottomLeft(edge *e); edge *moveRight(edge *e); edge *topFirstTraverse(tree *T, edge *e); edge *moveUpRight(edge *e); void freeMatrix(double **D, int size); void freeSet(set *S); void freeTree(tree *T); void freeSubTree(edge *e); int leaf(node *v); /* int whiteSpace(char c); */ /* node *decodeNewickSubtree(char *treeString, tree *T, int *uCount); */ /* tree *readNewickString (char *str, int numLeaves); */ void subtree2phylo(node *parent, int *edge1, int *edge2, double *el, int *ilab); void tree2phylo(tree *T, int *edge1, int *edge2, double *el, int *ilab, int n); ape/src/plot_phylo.c0000644000176200001440000000514414164530562014155 0ustar liggesusers/* plot_phylo.c (2017-04-25) */ /* Copyright 2004-2017 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include void node_depth_edgelength(int *edge1, int *edge2, int *nedge, double *edge_length, double *xx) { int i; /* We do a preorder tree traversal starting from the bottom */ /* of `edge'; we assume `xx' has 0 for the root and the tree */ /* is in pruningwise order. */ for (i = *nedge - 1; i >= 0; i--) xx[edge2[i] - 1] = xx[edge1[i] - 1] + edge_length[i]; } void node_depth(int *ntip, int *e1, int *e2, int *nedge, double *xx, int *method) /* method == 1: the node depths are proportional to the number of tips method == 2: the node depths are evenly spaced */ { int i; /* First set the coordinates for all tips */ for (i = 0; i < *ntip; i++) xx[i] = 1; /* Then compute recursively for the nodes; we assume `xx' has */ /* been initialized with 0's which is true if it has been */ /* created in R (the tree must be in pruningwise order) */ if (*method == 1) { for (i = 0; i < *nedge; i++) xx[e1[i] - 1] = xx[e1[i] - 1] + xx[e2[i] - 1]; } else { /* *method == 2 */ for (i = 0; i < *nedge; i++) { /* if a value > 0 has already been assigned to the ancestor node of this edge, check that the descendant node is not at the same level or more */ if (xx[e1[i] - 1]) if (xx[e1[i] - 1] >= xx[e2[i] - 1] + 1) continue; xx[e1[i] - 1] = xx[e2[i] - 1] + 1; } } } void node_height(int *edge1, int *edge2, int *nedge, double *yy) { int i, n; double S; /* The coordinates of the tips have been already computed */ S = 0; n = 0; for (i = 0; i < *nedge - 1; i++) { S += yy[edge2[i] - 1]; n++; if (edge1[i + 1] != edge1[i]) { yy[edge1[i] - 1] = S/n; S = 0; n = 0; } } /* do the last edge */ /* i = *nedge - 1; */ S += yy[edge2[i] - 1]; n++; yy[edge1[i] - 1] = S/n; } void node_height_clado(int *ntip, int *edge1, int *edge2, int *nedge, double *xx, double *yy) { int i, j, n; double S; i = 1; node_depth(ntip, edge1, edge2, nedge, xx, &i); /* The coordinates of the tips have been already computed */ S = 0; n = 0; for (i = 0; i < *nedge - 1; i++) { j = edge2[i] - 1; S += yy[j] * xx[j]; n += xx[j]; if (edge1[i + 1] != edge1[i]) { yy[edge1[i] - 1] = S/n; S = 0; n = 0; } } /* do the last edge */ /* i = *nedge - 1; */ j = edge2[i] - 1; S += yy[j] * xx[j]; n += xx[j]; yy[edge1[i] - 1] = S/n; } ape/src/mat_expo.c0000644000176200001440000000352714164530562013603 0ustar liggesusers/* matexpo.c 2021-09-27 */ /* Copyright 2007-2021 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #define USE_FC_LEN_T #include #include #ifndef FCONE # define FCONE #endif void mat_expo(double *P, int *nr) /* This function computes the exponential of a nr x nr matrix */ { double *U, *vl, *WR, *Uinv, *WI, *work; int i, j, k, l, info, *ipiv, n = *nr, nc = n*n, lw = nc << 1; char yes = 'V', no = 'N'; U = (double *)R_alloc(nc, sizeof(double)); vl = (double *)R_alloc(n, sizeof(double)); WR = (double *)R_alloc(n, sizeof(double)); Uinv = (double *)R_alloc(nc, sizeof(double)); WI = (double *)R_alloc(n, sizeof(double)); work = (double *)R_alloc(lw, sizeof(double)); ipiv = (int *)R_alloc(nc, sizeof(int)); /* The matrix is not symmetric, so we use 'dgeev'. We take the real part of the eigenvalues -> WR and the right eigenvectors (vr) -> U */ F77_CALL(dgeev)(&no, &yes, &n, P, &n, WR, WI, vl, &n, U, &n, work, &lw, &info FCONE FCONE); /* It is not necessary to sort the eigenvalues... Copy U -> P */ memcpy(P, U, nc*sizeof(double)); /* For the inversion, we first make Uinv an identity matrix */ memset(Uinv, 0, nc*sizeof(double)); for (i = 0; i < nc; i += n + 1) Uinv[i] = 1; /* The matrix is not symmetric, so we use 'dgesv'. This subroutine puts the result in Uinv (B) (P [= U] is erased) */ F77_CALL(dgesv)(&n, &n, P, &n, ipiv, Uinv, &n, &info); /* The matrix product of U with the eigenvalues diagonal matrix: */ for (i = 0; i < n; i++) for (j = 0; j < n; j++) U[j + i*n] *= exp(WR[i]); /* The second matrix product with U^-1 */ memset(P, 0, nc*sizeof(double)); for (k = 0; k < n; k++) { for (l = 0; l < n; l++) { lw = l + k*n; for (i = 0 + n*k, j = l; j < nc; i++, j += n) P[lw] += U[j]*Uinv[i]; } } } ape/src/delta_plot.c0000644000176200001440000000312414164530562014107 0ustar liggesusers/* delta_plot.c 2011-06-23 */ /* Copyright 2010-2011 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include void delta_plot(double *D, int *size, int *nbins, int *counts, double *deltabar) { int x, y, u, v; /* same notation than in Holland et al. 2002 */ int n = *size, nb = *nbins; double dxy, dxu, dxv, dyu, dyv, duv, A, B, C, delta; int xy, xu, xv, yu, yv, uv, i; for (x = 0; x < n - 3; x++) { xy = x*n - x*(x + 1)/2; /* do NOT factorize */ for (y = x + 1; y < n - 2; y++, xy++) { yu = y*n - y*(y + 1)/2; /* do NOT factorize */ dxy = D[xy]; xu = xy + 1; for (u = y + 1; u < n - 1; u++, xu++, yu++) { uv = u*n - u*(u + 1)/2; /* do NOT factorize */ dxu = D[xu]; dyu = D[yu]; xv = xu + 1; yv = yu + 1; for (v = u + 1; v < n; v++, xv++, yv++, uv++) { dxv = D[xv]; dyv = D[yv]; duv = D[uv]; A = dxv + dyu; B = dxu + dyv; C = dxy + duv; if (A == B && B == C) delta = 0; else while (1) { if (C <= B && B <= A) {delta = (A - B)/(A - C); break;} if (B <= C && C <= A) {delta = (A - C)/(A - B); break;} if (A <= C && C <= B) {delta = (B - C)/(B - A); break;} if (C <= A && A <= B) {delta = (B - A)/(B - C); break;} if (A <= B && B <= C) {delta = (C - B)/(C - A); break;} if (B <= A && A <= C) {delta = (C - A)/(C - B); break;} } /* if (delta == 1) i = nb - 1; else */ i = delta * nb; counts[i] += 1; deltabar[x] += delta; deltabar[y] += delta; deltabar[u] += delta; deltabar[v] += delta; } } } } } ape/src/bNNI.c0000644000176200001440000002500314164530562012546 0ustar liggesusers/* bNNI.c 2013-09-26 */ /* Copyright 2007 Vincent Lefort */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" /*boolean leaf(node *v); edge *siblingEdge(edge *e); edge *depthFirstTraverse(tree *T, edge *e); edge *findBottomLeft(edge *e); edge *topFirstTraverse(tree *T, edge *e); edge *moveUpRight(edge *e);*/ void limitedFillTableUp(edge *e, edge *f, double **A, edge *trigger); void assignBMEWeights(tree *T, double **A); //void updateAveragesMatrix(tree *T, double **A, node *v,int direction); void bNNItopSwitch(tree *T, edge *e, int direction, double **A); int bNNIEdgeTest(edge *e, tree *T, double **A, double *weight); void updatePair(double **A, edge *nearEdge, edge *farEdge, node *closer, node *further, double dcoeff, int direction); int *initPerm(int size); void reHeapElement(int *p, int *q, double *v, int length, int i); void pushHeap(int *p, int *q, double *v, int length, int i); void popHeap(int *p, int *q, double *v, int length, int i); void bNNIRetestEdge(int *p, int *q, edge *e,tree *T, double **avgDistArray, double *weights, int *location, int *possibleSwaps) { int tloc; tloc = location[e->head->index+1]; location[e->head->index+1] = bNNIEdgeTest(e,T,avgDistArray,weights + e->head->index+1); if (NONE == location[e->head->index+1]) { if (NONE != tloc) popHeap(p,q,weights,(*possibleSwaps)--,q[e->head->index+1]); } else { if (NONE == tloc) pushHeap(p,q,weights,(*possibleSwaps)++,q[e->head->index+1]); else reHeapElement(p,q,weights,*possibleSwaps,q[e->head->index+1]); } } int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh); void permInverse(int *p, int *q, int length); void weighTree(tree *T) { edge *e; T->weight = 0; for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e)) T->weight += e->distance; } //void bNNI(tree *T, double **avgDistArray, int *count) void bNNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies) { edge *e;//, *centerEdge deleted by EP, 2013-09-26, see also below edge **edgeArray; int *p, *location, *q; int i,j; int possibleSwaps; double *weights; p = initPerm(T->size+1); q = initPerm(T->size+1); edgeArray = (edge **) malloc((T->size+1)*sizeof(double)); weights = (double *) malloc((T->size+1)*sizeof(double)); location = (int *) malloc((T->size+1)*sizeof(int)); double epsilon = 0.0; for (i=0; isize+1;i++) { weights[i] = 0.0; location[i] = NONE; } /* if (verbose) { assignBMEWeights(T,avgDistArray); weighTree(T); }*/ e = findBottomLeft(T->root->leftEdge); while (NULL != e) { edgeArray[e->head->index+1] = e; location[e->head->index+1] = bNNIEdgeTest(e,T,avgDistArray,weights + e->head->index + 1); e = depthFirstTraverse(T,e); } possibleSwaps = makeThreshHeap(p,q,weights,T->size+1,0.0); permInverse(p,q,T->size+1); /*we put the negative values of weights into a heap, indexed by p with the minimum value pointed to by p[1]*/ /*p[i] is index (in edgeArray) of edge with i-th position in the heap, q[j] is the position of edge j in the heap */ while (weights[p[1]] + epsilon < 0) { /* centerEdge = edgeArray[p[1]]; apparently unused later, deleted by EP, 2013-09-26 */ (*count)++; /* if (verbose) { T->weight = T->weight + weights[p[1]]; printf("New tree weight is %lf.\n",T->weight); }*/ bNNItopSwitch(T,edgeArray[p[1]],location[p[1]],avgDistArray); location[p[1]] = NONE; weights[p[1]] = 0.0; /*after the bNNI, this edge is in optimal configuration*/ popHeap(p,q,weights,possibleSwaps--,1); /*but we must retest the other edges of T*/ /*CHANGE 2/28/2003 expanding retesting to _all_ edges of T*/ e = depthFirstTraverse(T,NULL); while (NULL != e) { bNNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); e = depthFirstTraverse(T,e); } } free(p); free(q); free(location); free(edgeArray); free(weights); assignBMEWeights(T,avgDistArray); } /*This function is the meat of the average distance matrix recalculation*/ /*Idea is: we are looking at the subtree rooted at rootEdge. The subtree rooted at closer is closer to rootEdge after the NNI, while the subtree rooted at further is further to rootEdge after the NNI. direction tells the direction of the NNI with respect to rootEdge*/ void updateSubTreeAfterNNI(double **A, node *v, edge *rootEdge, node *closer, node *further, double dcoeff, int direction) { edge *sib; switch(direction) { case UP: /*rootEdge is below the center edge of the NNI*/ /*recursive calls to subtrees, if necessary*/ if (NULL != rootEdge->head->leftEdge) updateSubTreeAfterNNI(A, v, rootEdge->head->leftEdge, closer, further, 0.5*dcoeff,UP); if (NULL != rootEdge->head->rightEdge) updateSubTreeAfterNNI(A, v, rootEdge->head->rightEdge, closer, further, 0.5*dcoeff,UP); updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, UP); sib = siblingEdge(v->parentEdge); A[rootEdge->head->index][v->index] = A[v->index][rootEdge->head->index] = 0.5*A[rootEdge->head->index][sib->head->index] + 0.5*A[rootEdge->head->index][v->parentEdge->tail->index]; break; case DOWN: /*rootEdge is above the center edge of the NNI*/ sib = siblingEdge(rootEdge); if (NULL != sib) updateSubTreeAfterNNI(A, v, sib, closer, further, 0.5*dcoeff, SKEW); if (NULL != rootEdge->tail->parentEdge) updateSubTreeAfterNNI(A, v, rootEdge->tail->parentEdge, closer, further, 0.5*dcoeff, DOWN); updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, DOWN); A[rootEdge->head->index][v->index] = A[v->index][rootEdge->head->index] = 0.5*A[rootEdge->head->index][v->leftEdge->head->index] + 0.5*A[rootEdge->head->index][v->rightEdge->head->index]; break; case SKEW: /*rootEdge is in subtree skew to v*/ if (NULL != rootEdge->head->leftEdge) updateSubTreeAfterNNI(A, v, rootEdge->head->leftEdge, closer, further, 0.5*dcoeff,SKEW); if (NULL != rootEdge->head->rightEdge) updateSubTreeAfterNNI(A, v, rootEdge->head->rightEdge, closer, further, 0.5*dcoeff,SKEW); updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, UP); A[rootEdge->head->index][v->index] = A[v->index][rootEdge->head->index] = 0.5*A[rootEdge->head->index][v->leftEdge->head->index] + 0.5*A[rootEdge->head->index][v->rightEdge->head->index]; break; } } /*swapping across edge whose head is v*/ void bNNIupdateAverages(double **A, node *v, edge *par, edge *skew, edge *swap, edge *fixed) { A[v->index][v->index] = 0.25*(A[fixed->head->index][par->head->index] + A[fixed->head->index][swap->head->index] + A[skew->head->index][par->head->index] + A[skew->head->index][swap->head->index]); updateSubTreeAfterNNI(A, v, fixed, skew->head, swap->head, 0.25, UP); updateSubTreeAfterNNI(A, v, par, swap->head, skew->head, 0.25, DOWN); updateSubTreeAfterNNI(A, v, skew, fixed->head, par->head, 0.25, UP); updateSubTreeAfterNNI(A, v, swap, par->head, fixed->head, 0.25, SKEW); } void bNNItopSwitch(tree *T, edge *e, int direction, double **A) { edge *down, *swap, *fixed; node *u, *v; /* if (verbose) { printf("Performing branch swap across edge %s ",e->label); printf("with "); if (LEFT == direction) printf("left "); else printf("right "); printf("subtree.\n"); }*/ down = siblingEdge(e); u = e->tail; v = e->head; if (LEFT == direction) { swap = e->head->leftEdge; fixed = e->head->rightEdge; v->leftEdge = down; } else { swap = e->head->rightEdge; fixed = e->head->leftEdge; v->rightEdge = down; } swap->tail = u; down->tail = v; if(e->tail->leftEdge == e) u->rightEdge = swap; else u->leftEdge = swap; bNNIupdateAverages(A, v, e->tail->parentEdge, down, swap, fixed); } double wf5(double D_AD, double D_BC, double D_AC, double D_BD, double D_AB, double D_CD) { double weight; weight = 0.25*(D_AC + D_BD + D_AD + D_BC) + 0.5*(D_AB + D_CD); return(weight); } int bNNIEdgeTest(edge *e, tree *T, double **A, double *weight) { edge *f; double D_LR, D_LU, D_LD, D_RD, D_RU, D_DU; double w1,w2,w0; /* if (verbose) printf("Branch swap: testing edge %s.\n",e->label);*/ if ((leaf(e->tail)) || (leaf(e->head))) return(NONE); f = siblingEdge(e); D_LR = A[e->head->leftEdge->head->index][e->head->rightEdge->head->index]; D_LU = A[e->head->leftEdge->head->index][e->tail->index]; D_LD = A[e->head->leftEdge->head->index][f->head->index]; D_RU = A[e->head->rightEdge->head->index][e->tail->index]; D_RD = A[e->head->rightEdge->head->index][f->head->index]; D_DU = A[e->tail->index][f->head->index]; w0 = wf5(D_RU,D_LD,D_LU,D_RD,D_DU,D_LR); /*weight of current config*/ w1 = wf5(D_RU,D_LD,D_DU,D_LR,D_LU,D_RD); /*weight with L<->D switch*/ w2 = wf5(D_DU,D_LR,D_LU,D_RD,D_RU,D_LD); /*weight with R<->D switch*/ if (w0 <= w1) { if (w0 <= w2) /*w0 <= w1,w2*/ { *weight = 0.0; return(NONE); } else /*w2 < w0 <= w1 */ { *weight = w2 - w0; /* if (verbose) { printf("Possible swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w2); printf("New weight would be %lf.\n",T->weight + w2 - w0); }*/ return(RIGHT); } } else if (w2 <= w1) /*w2 <= w1 < w0*/ { *weight = w2 - w0; /* if (verbose) { printf("Possible swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w2); printf("New weight should be %lf.\n",T->weight + w2 - w0); }*/ return(RIGHT); } else /*w1 < w2, w0*/ { *weight = w1 - w0; /* if (verbose) { printf("Possible swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w1); printf("New weight should be %lf.\n",T->weight + w1 - w0); }*/ return(LEFT); } } /*limitedFillTableUp fills all the entries in D associated with e->head,f->head and those edges g->head above e->head, working recursively and stopping when trigger is reached*/ void limitedFillTableUp(edge *e, edge *f, double **A, edge *trigger) { edge *g,*h; g = f->tail->parentEdge; if (f != trigger) limitedFillTableUp(e,g,A,trigger); h = siblingEdge(f); A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[e->head->index][g->head->index] + A[e->head->index][h->head->index]); } ape/src/nj.c0000644000176200001440000000762414164530562012400 0ustar liggesusers/* nj.c 2011-10-20 */ /* Copyright 2006-2011 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" double sum_dist_to_i(int n, double *D, int i) /* returns the sum of all distances D_ij between i and j with j = 1...n and j != i */ { /* we use the fact that the distances are arranged sequentially in the lower triangle, e.g. with n = 6 the 15 distances are stored as (the C indices are indicated): i 1 2 3 4 5 2 0 3 1 5 j 4 2 6 9 5 3 7 10 12 6 4 8 11 13 14 so that we sum the values of the ith column--1st loop--and those of (i - 1)th row (labelled 'i')--2nd loop */ double sum = 0; int j, start, end; if (i < n) { /* the expression below CANNOT be factorized because of the integer operations (it took me a while to find out...) */ start = n * (i - 1) - i * (i - 1) / 2; end = start + n - i; for (j = start; j < end; j++) sum += D[j]; } if (i > 1) { start = i - 2; for (j = 1; j <= i - 1; j++) { sum += D[start]; start += n - j - 1; } } return(sum); } SEXP C_nj(SEXP DIST, SEXP N) { double *D, *edge_length, *S, *new_dist, A, B, smallest_S; int n, i, j, k, ij, *edge, cur_nod, *otu_label, smallest, OTU1, OTU2, Nedge; SEXP phy, E, EL; PROTECT(DIST = coerceVector(DIST, REALSXP)); PROTECT(N = coerceVector(N, INTSXP)); D = REAL(DIST); n = INTEGER(N)[0]; Nedge = 2 * n - 3; PROTECT(phy = allocVector(VECSXP, 2)); PROTECT(E = allocVector(INTSXP, 2 * Nedge)); PROTECT(EL = allocVector(REALSXP, Nedge)); edge = INTEGER(E); edge_length = REAL(EL); cur_nod = 2 * n - 2; S = (double*)R_alloc(n + 1, sizeof(double)); new_dist = (double*)R_alloc(n * (n - 1) / 2, sizeof(double)); otu_label = (int*)R_alloc(n + 1, sizeof(int)); for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */ k = 0; while (n > 3) { for (i = 1; i <= n; i++) /* S[0] is not used */ S[i] = sum_dist_to_i(n, D, i); ij = 0; smallest_S = 1e50; B = n - 2; for (i = 1; i < n; i++) { for (j = i + 1; j <= n; j++) { A = B * D[ij] - S[i] - S[j]; if (A < smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; smallest = ij; } ij++; } } edge[k + Nedge] = otu_label[OTU1]; edge[k + 1 + Nedge] = otu_label[OTU2]; edge[k] = edge[k + 1] = cur_nod; /* get the distances between all OTUs but the 2 selected ones and the latter: a) get the sum for both b) compute the distances for the new OTU */ A = D[smallest]; ij = 0; for (i = 1; i <= n; i++) { if (i == OTU1 || i == OTU2) continue; new_dist[ij] = (D[give_index(i, OTU1, n)] + /* dist(i, OTU1) */ D[give_index(i, OTU2, n)] - /* dist(i, OTU2) */ A) / 2; ij++; } /* compute the branch lengths */ B = (S[OTU1] - S[OTU2])/B; /* don't need B anymore */ edge_length[k] = (A + B)/2; edge_length[k + 1] = (A - B)/2; /* update before the next loop (we are sure that OTU1 < OTU2) */ if (OTU1 != 1) for (i = OTU1; i > 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; ij++; } } n--; for (i = 0; i < n * (n - 1) / 2; i++) D[i] = new_dist[i]; cur_nod--; k += 2; } k = 2 * INTEGER(N)[0] - 4; /* 2N - 4 */ for (i = 0; i < 3; i++) { edge[k - i] = cur_nod; edge[k - i + Nedge] = otu_label[i + 1]; } edge_length[k] = (D[0] + D[1] - D[2]) / 2; k--; /* 2N - 5 */ edge_length[k] = (D[0] + D[2] - D[1]) / 2; k--; /* 2N - 6 */ edge_length[k] = (D[2] + D[1] - D[0]) / 2; SET_VECTOR_ELT(phy, 0, E); SET_VECTOR_ELT(phy, 1, EL); UNPROTECT(5); return phy; } ape/src/bitsplits.c0000644000176200001440000001573014164530562014003 0ustar liggesusers/* bitsplits.c 2021-12-27 */ /* Copyright 2005-2021 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" /* the following array stores the 8 mask values: [0] = 0000 0001 [1] = 1000 0000 [2] = 0100 0000 [3] = 0010 0000 [4] = 0001 0000 [5] = 0000 1000 [6] = 0000 0100 [7] = 0000 0010 so that mask81[y % 8] gives the corresponding mask (note that 8 % 8 is 0) */ static const unsigned char mask81[8] = {0x01, 0x80, 0x40, 0x20, 0x10, 0x08, 0x04, 0x02}; void OneWiseBitsplits(unsigned char *mat, int nr, int nc, int rest) { /* the following array stores the 8 mask values: [0] = 0000 0000 [1] = 1000 0000 [2] = 1100 0000 [3] = 1110 0000 [4] = 1111 0000 [5] = 1111 1000 [6] = 1111 1100 [7] = 1111 1110 to set the trailing bits to zero when appropriate */ const unsigned char trailzeros[8] = {0x00, 0x80, 0xc0, 0xe0, 0xf0, 0xf8, 0xfc, 0xfe}; int i, j; for (i = 0; i < nc; i++) { j = nr * i; if (mat[j] & mask81[1]) continue; while (j < nr * (i + 1)) { mat[j] = ~mat[j]; j++; } if (rest) mat[j - 1] &= trailzeros[rest]; } } static int iii; void bar_reorder2(int node, int n, int m, int Nedge, int *e, int *neworder, int *L, int *pos) { int i = node - n - 1, j, k; for (j = pos[i] - 1; j >= 0; j--) neworder[iii--] = L[i + m * j] + 1; for (j = 0; j < pos[i]; j++) { k = e[L[i + m * j] + Nedge]; if (k > n) bar_reorder2(k, n, m, Nedge, e, neworder, L, pos); } } #define update_L(x)\ k = e_reord[i] - Ntip - 1;\ L[k + Nnode * pos[k]] = x;\ pos[k]++ SEXP bitsplits_multiPhylo(SEXP x, SEXP n, SEXP nr) { int Ntip, Nnode, Nr, Ntrees, itr, Nc, *e, *e_reord, Nedge, *L, *pos, i, j, k, ispl, *newor, d, inod, y, *rfreq, new_split; unsigned char *split, *rmat; SEXP mat, freq, ans, EDGE, final_nc; PROTECT(x = coerceVector(x, VECSXP)); PROTECT(n = coerceVector(n, INTSXP)); /* nb of tips */ PROTECT(nr = coerceVector(nr, INTSXP)); /* nb of rows in the matrix of splits */ Ntrees = LENGTH(x); Ntip = *INTEGER(n); Nr = *INTEGER(nr); Nc = (Ntip - 3) * Ntrees; /* the maximum number of splits that can be found */ PROTECT(mat = allocVector(RAWSXP, Nr * Nc)); PROTECT(freq = allocVector(INTSXP, Nc)); rmat = RAW(mat); rfreq = INTEGER(freq); memset(rmat, 0, Nr * Nc * sizeof(unsigned char)); split = (unsigned char*)R_alloc(Nr, sizeof(unsigned char)); ispl = 0; /* nb of splits already stored */ for (itr = 0; itr < Ntrees; itr++) { Nnode = *INTEGER(getListElement(VECTOR_ELT(x, itr), "Nnode")); if (Nnode == 1) continue; PROTECT(EDGE = getListElement(VECTOR_ELT(x, itr), "edge")); e = INTEGER(EDGE); Nedge = LENGTH(EDGE)/2; /* L is a 1-d array storing, for each node, the C indices of the rows of the edge matrix where the node is ancestor (i.e., present in the 1st column). It is used in the same way than a matrix (which is actually a vector) is used in R as a 2-d structure. */ L = (int*)R_alloc(Nnode * Ntip, sizeof(int)); /* safe allocation */ /* pos gives the position for each 'row' of L, that is the number of elements which have already been stored for that 'row'. */ pos = (int*)R_alloc(Nnode, sizeof(int)); memset(pos, 0, Nnode * sizeof(int)); /* we now go down along the edge matrix */ for (i = 0; i < Nedge; i++) { k = e[i] - Ntip - 1; /* k is the 'row' index in L corresponding to node e1[i] */ j = pos[k]; /* the current 'column' position corresponding to k */ pos[k]++; /* increment in case the same node is found in another row of the edge matrix */ L[k + Nnode * j] = i; } /* L is now ready: we can start the recursive calls. We start with the root 'n + 1': its index will be changed into the corresponding C index inside the recursive function. */ iii = Nedge - 1; newor = (int*)R_alloc(Nedge, sizeof(int)); bar_reorder2(Ntip + 1, Ntip, Nnode, Nedge, e, newor, L, pos); e_reord = (int*)R_alloc(2 * Nedge, sizeof(int)); for (i = 0; i < Nedge; i++) newor[i]--; /* change R indices into C indices */ for (i = 0; i < Nedge; i++) { e_reord[i] = e[newor[i]]; e_reord[i + Nedge] = e[newor[i] + Nedge]; } /* the tree is now reordered */ /* reallocate L and reinitialize pos */ L = (int*)R_alloc(Nnode * Ntip, sizeof(int)); memset(pos, 0, Nnode * sizeof(int)); for (i = 0; i < Nedge; i++) { memset(split, 0, Nr * sizeof(unsigned char)); d = e_reord[i + Nedge]; if (d <= Ntip) { /* trivial split from a terminal branch */ update_L(d); continue; } inod = d - Ntip - 1; for (j = 0; j < pos[inod]; j++) { y = L[inod + Nnode * j]; split[(y - 1) / 8] |= mask81[y % 8]; update_L(y); /* update L */ } OneWiseBitsplits(split, Nr, 1, Ntip % 8); new_split = 1; if (itr > 0) { /* if we are handling the 1st tree, no need to check cause all splits are new */ j = 0; /* column of rmat */ k = 0; /* row */ y = 0; /* number of columns of rmat to shift */ while (j < ispl) { if (split[k] != rmat[k + y]) { /* the two splits are different so move to the next col of rmat */ j++; k = 0; y += Nr; } else k++; if (k == Nr) { /* the two splits are the same, so stop here */ rfreq[j]++; new_split = 0; break; } } } if (new_split) { for (j = 0; j < Nr; j++) rmat[j + ispl * Nr] = split[j]; rfreq[ispl] = 1; ispl++; } } UNPROTECT(1); } PROTECT(ans = allocVector(VECSXP, 3)); PROTECT(final_nc = allocVector(INTSXP, 1)); INTEGER(final_nc)[0] = ispl; SET_VECTOR_ELT(ans, 0, mat); SET_VECTOR_ELT(ans, 1, freq); SET_VECTOR_ELT(ans, 2, final_nc); UNPROTECT(7); return ans; } int same_splits(unsigned char *x, unsigned char *y, int i, int j, int nr) { int end = i + nr; while (i < end) { if (x[i] != y[j]) return 0; i++; j++; } return 1; } SEXP CountBipartitionsFromSplits(SEXP split, SEXP SPLIT) { SEXP FREQ, ans; unsigned char *mat, *MAT; int i, j, nc, NC, nr, *p, *F; PROTECT(split = coerceVector(split, VECSXP)); PROTECT(SPLIT = coerceVector(SPLIT, VECSXP)); mat = RAW(getListElement(split, "matsplit")); MAT = RAW(getListElement(SPLIT, "matsplit")); /* the number of splits in the 1st object: */ nc = LENGTH(getListElement(split, "freq")); /* the split frequencies in the 2nd object: */ PROTECT(FREQ = getListElement(SPLIT, "freq")); F = INTEGER(FREQ); /* the number of splits in the 2nd object: */ NC = LENGTH(FREQ); /* the number of rows in the matrix (should be the same in both objects): */ nr = nrows(getListElement(split, "matsplit")); /* create the output */ PROTECT(ans = allocVector(INTSXP, nc)); p = INTEGER(ans); memset(p, 0, nc * sizeof(int)); for (i = 0; i < nc; i++) { j = 0; while (j < NC) { if (same_splits(mat, MAT, nr * i, nr * j, nr)) { p[i] = F[j]; break; } j++; } } UNPROTECT(4); return ans; } ape/src/bipartition.c0000644000176200001440000000474014164530562014311 0ustar liggesusers/* bipartition.c 2017-07-28 */ /* Copyright 2005-2017 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" SEXP seq_root2tip(SEXP edge, SEXP nbtip, SEXP nbnode) { int i, j, k, Nedge, *x, *done, dn, sumdone, lt, ROOT, Ntip, Nnode; SEXP ans, seqnod, tmp_vec; /* The following is needed only if we are not sure that the storage mode of `edge' is "integer". */ PROTECT(edge = coerceVector(edge, INTSXP)); PROTECT(nbtip = coerceVector(nbtip, INTSXP)); PROTECT(nbnode = coerceVector(nbnode, INTSXP)); x = INTEGER(edge); /* copy the pointer */ Ntip = *INTEGER(nbtip); Nnode = *INTEGER(nbnode); Nedge = LENGTH(edge)/2; ROOT = Ntip + 1; PROTECT(ans = allocVector(VECSXP, Ntip)); PROTECT(seqnod = allocVector(VECSXP, Nnode)); done = &dn; done = (int*)R_alloc(Nnode, sizeof(int)); for (i = 0; i < Nnode; i++) done[i] = 0; tmp_vec = allocVector(INTSXP, 1); INTEGER(tmp_vec)[0] = ROOT; /* sure ? */ SET_VECTOR_ELT(seqnod, 0, tmp_vec); sumdone = 0; while (sumdone < Nnode) { for (i = 0; i < Nnode; i++) { /* loop through all nodes */ /* if the vector is not empty and its */ /* descendants are not yet found */ if (VECTOR_ELT(seqnod, i) == R_NilValue || done[i]) continue; /* look for the descendants in 'edge': */ for (j = 0; j < Nedge; j++) { /* skip the terminal edges, we look only for nodes now */ if (x[j] - Ntip != i + 1 || x[j + Nedge] <= Ntip) continue; /* can now make the sequence from */ /* the root to the current node */ lt = LENGTH(VECTOR_ELT(seqnod, i)); tmp_vec = allocVector(INTSXP, lt + 1); for (k = 0; k < lt; k++) INTEGER(tmp_vec)[k] = INTEGER(VECTOR_ELT(seqnod, i))[k]; INTEGER(tmp_vec)[lt] = x[j + Nedge]; SET_VECTOR_ELT(seqnod, x[j + Nedge] - Ntip - 1, tmp_vec); } done[i] = 1; sumdone++; } } /* build the sequence from root to tip */ /* by simply looping through 'edge' */ for (i = 0; i < Nedge; i++) { /* skip the internal edges */ if (x[i + Nedge] > Ntip) continue; lt = LENGTH(VECTOR_ELT(seqnod, x[i] - Ntip - 1)); tmp_vec = allocVector(INTSXP, lt + 1); for (j = 0; j < lt; j++) INTEGER(tmp_vec)[j] = INTEGER(VECTOR_ELT(seqnod, x[i] - Ntip - 1))[j]; INTEGER(tmp_vec)[lt] = x[i + Nedge]; SET_VECTOR_ELT(ans, x[i + Nedge] - 1, tmp_vec); } UNPROTECT(5); return ans; } /* EOF seq_root2tip */ ape/src/triangMtd.c0000644000176200001440000002035714164530562013720 0ustar liggesusers/* triangMtd.c 2012-04-02 */ /* Copyright 2011-2012 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ /* * leafs labelled 1 to n. root labelled n+1. other nodes labelled n+1 to m */ #include int give_indexx(int i, int j, int n) { if (i == j) return 0; if (i > j) return(n*(j - 1) - j*(j - 1)/2 + i - j - 1); else return(n*(i - 1) - i*(i - 1)/2 + j - i - 1); } int pred(int k, int* ed1, int* ed2, int numEdges) /* find the predecesor of vertex k */ { int i = 0; for (i = 0; i <= numEdges; i++) if (ed2[i] == k) return ed1[i]; return -1; } int* getPathBetween(int x, int y, int n, int* ed1, int* ed2, int numEdges) //get the path between vertices x and y in an array ord. //ord[i]=j means that we go between i and j on the path between x and y { int i=0; int k=x; int ch[2*n-1];//ch[i]==1 implies {k,pred(k)} on path between x and y for(i=1;i<=2*n-2;i++) {ch[i]=0; } while(k!=n+1) { ch[k]=1; k=pred(k,ed1,ed2,numEdges); } k=y; while(k!=n+1) { ch[k]++; k=pred(k,ed1,ed2,numEdges); } int *ord=(int*)malloc(sizeof(int)*(2*n-1)); //starting from x, fill ord int p=x; while(ch[p]==1) { int aux=p; p=pred(p,ed1,ed2,numEdges); ord[aux]=p; } p=y; while(ch[p]==1) { int aux=p; p=pred(p,ed1,ed2,numEdges); ord[p]=aux;//other way } return ord; } int getLength(int x, int y, int* ed1, int* ed2, int numEdges, int* edLen) /* get length of edge {x,y}, -1 if edge does not exist */ { int i = 0; for (i = 0; i <= numEdges; i++) if ((ed1[i] == x && ed2[i] == y) || (ed1[i] == y && ed2[i] == x)) return edLen[i]; return -1; } void C_triangMtd(double* d, int* np, int* ed1,int* ed2, double* edLen) { int n=*np; int i=0; int j=0; int ij=-1; for(i=0;i %i ",p,ord[p]); p=ord[p]; prevSum=sum; for(i=0;i<=numEdges;i++) { if((ed1[i]==aux && ed2[i]==p)||(ed2[i]==aux && ed1[i]==p)) { if(ed1[i]==aux && ed2[i]==p){sw=1;} subdiv=i; sum+=edLen[i]; } } } nv++; //subdivide subdiv with a node labelled nv //length calculation //multifurcating vertices int edd=ed2[subdiv]; ed2[subdiv]=nv; edLen[subdiv]= (sw==1)?(lx-prevSum):(sum-lx);//check which 'half' of the //path the leaf belongs to //and updates accordingly //error("sum=%f, prevsum=%f\n",sum,prevSum); //error("lx-prevSum=%f, sum-lx=%f, minDist=%f",lx-prevSum,sum-lx,minDist); numEdges++; ed1[numEdges]=nv; ed2[numEdges]=edd; edLen[numEdges]= (sw==1)?(sum-lx):(lx-prevSum); numEdges++; edLen[numEdges]=minDist; ed1[numEdges]=nv; ed2[numEdges]=z; wSize++; w[z]=1; //update l[s] for all s not yet added int s; for(s=1;s<=n;s++) {if(w[s])continue; for(i=1;i<=n;i++) {if(i==z)continue; if(i!=x && i!=y)continue;//we only consider x and y as being other leaf //and take the minimum of them as being new distance double newL=0.5*(d[give_indexx(i,s,n)]+d[give_indexx(z,s,n)]-d[give_indexx(i,z,n)]);//one of leaves is //z, since //all pairs not cotaining z //will remain unchanged if(newL= 0 - 1e-10) return 1; return 0; } void choosePair(double* D,int n,double* R,int* s, int* sw, int* x, int* y, int fS) { int i=0,j=0,k=0; int sww=0; double cFS[fS]; int iFS[fS]; int jFS[fS]; for(k=0;knumb;k++); for(tr=fS-1;tr>k;tr--) {cFS[tr]=cFS[tr-1]; iFS[tr]=iFS[tr-1]; jFS[tr]=jFS[tr-1]; } if(kmax){max=nb;} cFS[i]=nb; } int dk=0; //shift the max N*xy to the front of the array for(i=0;imax){max=nb;} cFS[i]=nb; } //and again shift maximal C*xy values at the fron of the array dk=0; for(i=0;imax){max=nb;} cFS[i]=nb; } //again shift maximal m*xy values to the fron of the array dk=0; for(i=0;imax){max=nb;iPos=i;} cFS[i]=nb; } if(iFS[iPos]==0 || jFS[iPos]==0) { error("distance information insufficient to construct a tree, cannot calculate agglomeration criterion"); } *x=iFS[iPos];*y=jFS[iPos]; } double cnxy(int x, int y, int n,double* D) { int i=0; int j=0; double nMeanXY=0; for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; nMeanXY+=(n1+n2-D[give_index(x,y,n)]-D[give_index(i,j,n)]); } } return nMeanXY; } int mxy(int x,int y,int n,double* D) { int i=0; int mx[n+1]; int my[n+1]; for(i=1;i<=n;i++) { mx[i]=0;my[i]=0; } for(i=1;i<=n;i++) { if(i!=x && D[give_index(x,i,n)]==-1) { mx[i]=1; } if(i!=y && D[give_index(y,i,n)]==-1) { my[i]=1; } } int xmy=0; int ymx=0; for(i=1;i<=n;i++) { if(i!=x && mx[i]==1 && my[i]==0) { xmy++; } if(i!=y && my[i]==1 && mx[i]==0) { ymx++; } } return xmy+ymx; } double nxy(int x, int y, int n,double* D) { int sCXY=0; int i=0; int j=0; double nMeanXY=0; for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; sCXY++; nMeanXY+=H(n1+n2-D[give_index(x,y,n)]-D[give_index(i,j,n)]); } } if(sCXY==0) return 0; return nMeanXY/sCXY; } int cxy(int x, int y, int n,double* D) { int sCXY=0; int i=0; int j=0; for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; sCXY++; } } return sCXY; } void C_njs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int *fsS) { //assume missing values are denoted by -1 double *S,*R, Sdist, Ndist, *new_dist, A, B, smallest_S; int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label; int *s;//s contains |Sxy|, which is all we need for agglomeration double *newR; int *newS; int fS=*fsS; R = &Sdist; new_dist = &Ndist; otu_label = &o_l; n = *N; cur_nod = 2*n - 2; R = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); S = (double*)R_alloc(n + 1, sizeof(double)); newR = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); otu_label = (int*)R_alloc(n + 1, sizeof(int)); s = (int*)R_alloc(n*(n - 1)/2, sizeof(int)); newS = (int*)R_alloc(n*(n - 1)/2, sizeof(int)); for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */ k = 0; //compute Sxy and Rxy for(i=0;i 3) { ij = 0; for(i=1;i smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; /* smallest = ij; */ } ij++; } } } //update Rxy and Sxy, only if matrix still incomplete if(sw==1) for(i=1;i 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; n--; for (i = 0; i < n*(n - 1)/2; i++) { D[i] = new_dist[i]; if(sw==1) { R[i] = newR[i]; s[i] = newS[i]; } } cur_nod--; k = k + 2; } int dK=0;//number of known distances in final distance matrix int iUK=-1;//index of unkown distance, if we have one missing distance int iK=-1;//index of only known distance, only needed if dK==1 for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; if(D[i]!=-1){dK++;iK=i;}else{iUK=i;} } if(dK==2) {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown //and edge weights of three edges are a,b,c, then any b,c>0 that //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for //simplicity we assume a=c if d(yz)max)max=D[i]; } D[iUK]=max; } if(dK==1) {//through similar motivation as above, if we have just one known distance //we set the other two distances equal to it for(i=0;i<3;i++) {if(i==iK)continue; D[i]=D[iK]; } } if(dK==0) {//no distances are known, we just set them to 1 for(i=0;i<3;i++) {D[i]=1; } } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/rTrait.c0000644000176200001440000000174214164530562013231 0ustar liggesusers/* rTrait.c 2011-06-25 */ /* Copyright 2010-2011 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include void C_rTraitCont(int *model, int *Nedge, int *edge1, int *edge2, double *el, double *sigma, double *alpha, double *theta, double *x) { /* The tree must be in pruningwise order */ int i; double alphaT, M, S; switch(*model) { case 1 : for (i = *Nedge - 1; i >= 0; i--) { GetRNGstate(); x[edge2[i]] = x[edge1[i]] + sqrt(el[i]) * sigma[i] * norm_rand(); PutRNGstate(); } break; case 2 : for (i = *Nedge - 1; i >= 0; i--) { if (alpha[i]) { alphaT = alpha[i] * el[i]; M = exp(-alphaT); S = sigma[i] * sqrt((1 - exp(-2 * alphaT))/(2 * alpha[i])); } else { /* same than if (alpha[i] == 0) */ M = 1; S = sqrt(el[i]) * sigma[i]; } GetRNGstate(); x[edge2[i]] = x[edge1[i]] * M + theta[i] * (1 - M) + S * norm_rand(); PutRNGstate(); } break; } } ape/src/prop_part.cpp0000644000176200001440000000402214164530562014324 0ustar liggesusers/* additive.c 2017-07-26 */ /* Copyright 2017 Klaus Schliep */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include using namespace Rcpp; // [[Rcpp::export]] std::vector< std::vector > bipartition2(IntegerMatrix orig, int nTips) { IntegerVector parent = orig( _, 0); IntegerVector children = orig( _, 1); int m = max(parent), j=0; int nnode = m - nTips; // create list for results std::vector< std::vector > out(nnode); std::vector y; for(int i = 0; i nTips){ y = out[children[i] - nTips -1L]; out[j].insert( out[j].end(), y.begin(), y.end() ); } else out[j].push_back(children[i]); } for(int i=0; i > ans = bipartition2(E, nTips); std::vector no; for(unsigned int i=0; i > bp = bipartition2(tmpE, nTips); for (unsigned int i = 1; i < bp.size(); i++) { unsigned int j = 1; next_j: if (bp[i] == ans[j]) { no[j]++; continue; } j++; if (j < ans.size()) goto next_j; else { //if(KeepPartition) ans.push_back(bp[i]); no.push_back(1); } } } List output = wrap(ans); output.attr("number") = no; output.attr("class") = "prop.part"; return output; } ape/src/additive.c0000644000176200001440000000276014164530562013556 0ustar liggesusers/* additive.c 2011-10-11 */ /* Copyright 2011 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_additive(double *dd, int* np, int* mp, double *ret)//d received as dist object, -1 for missing entries { int n=*np; int m=*mp; int i=0,j=0; double max=dd[0]; double d[n][n]; for(i=1;imax) { max=dd[give_index(i,j,n)]; } } } d[n-1][n-1]=0; int entrCh=0; do{ entrCh=0; for(i=0;i(d[i][l]+d[j][k]))?(d[i][k]+d[j][l]):(d[i][l]+d[j][k])); mx-=d[k][l]; if(mx using namespace Rcpp; // This is a simple example of exporting a C++ function to R. You can // source this function into an R session using the Rcpp::sourceCpp // function (or via the Source button on the editor toolbar). Learn // more about Rcpp at: // // http://www.rcpp.org/ // http://adv-r.had.co.nz/Rcpp.html // http://gallery.rcpp.org/ // static int iii; void foo_reorderRcpp(int node, int nTips, const IntegerVector & e1, const IntegerVector & e2, IntegerVector neworder, const IntegerVector & L, const IntegerVector & xi, const IntegerVector & xj) { int i = node - nTips - 1, j, k; /* 'i' is the C index corresponding to 'node' */ for (j = 0; j < xj[i]; j++) { k = L[xi[i] + j]; neworder[iii++] = k + 1; if (e2[k] > nTips) /* is it an internal edge? */ foo_reorderRcpp(e2[k], nTips, e1, e2, neworder, L, xi, xj); } } void bar_reorderRcpp(int node, int nTips, const IntegerVector & e1, const IntegerVector & e2, IntegerVector neworder, const IntegerVector & L, const IntegerVector & xi, const IntegerVector & xj) { int i = node - nTips - 1, j, k; for (j = xj[i] -1; j >= 0; j--) neworder[iii--] = L[xi[i] + j ] + 1; for (j = 0; j < xj[i]; j++) { k = e2[L[xi[i] + j ]]; if (k > nTips) bar_reorderRcpp(k, nTips, e1, e2, neworder, L, xi, xj); } } // L is a vector of length number of edges // not max degree * number of nodes // [[Rcpp::export]] IntegerVector reorderRcpp(IntegerMatrix orig, int nTips, int root, int order) { IntegerVector e1 = orig( _, 0); IntegerVector e2 = orig( _, 1); int m = max(e1), k, j; int nnode = m - nTips; // int root = nTips + 1; int n = orig.nrow(); IntegerVector L(n); IntegerVector neworder(n); IntegerVector pos(nnode); IntegerVector xi(nnode); IntegerVector xj(nnode); for (int i = 0; i < n; i++) { xj[e1[i] - nTips - 1]++; } for (int i = 1; i < nnode; i++) { xi[i] = xi[i-1] + xj[i - 1]; } for (int i = 0; i < n; i++) { k = e1[i] - nTips - 1; j = pos[k]; /* the current 'column' position corresponding to k */ L[xi[k] + j] = i; pos[k]++; } switch(order) { case 1 : iii = 0; foo_reorderRcpp(root, nTips, e1, e2, neworder, L, xi, xj); break; case 2 : iii = n - 1; bar_reorderRcpp(root, nTips, e1, e2, neworder, L, xi, xj); break; } return neworder; } ape/src/mvr.c0000644000176200001440000001357114164530562012573 0ustar liggesusers/* mvr.c 2012-05-02 */ /* Copyright 2011-2012 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_mvr(double *D, double* v,int *N, int *edge1, int *edge2, double *edge_length) { double *S, Sdist, *new_v, Ndist, *new_dist, A, B, smallest_S; int n, i, j, k, ij, smallest, OTU1, OTU2, cur_nod, o_l, *otu_label; S = &Sdist; new_dist = &Ndist; otu_label = &o_l; n = *N; cur_nod = 2*n - 2; S = (double*)R_alloc(n + 1, sizeof(double)); new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); new_v = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); otu_label = (int*)R_alloc(n + 1, sizeof(int)); for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */ k = 0; while (n > 3) { /*for(i=1;i 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; new_v[ij]=v[give_index(i,j,n)]; ij++; } } n--; for (i = 0; i < n*(n - 1)/2; i++) {D[i] = new_dist[i]; v[i] = new_v[i]; } cur_nod--; k = k + 2; } for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/heap.c0000644000176200001440000000507214164530562012701 0ustar liggesusers/* heap.c 2007-09-05 */ /* Copyright 2007 Vincent Lefort */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" int *initPerm(int size) { int *p; int i; p = (int *) malloc(size*sizeof(int)); for(i = 0;i 0) && (v[p[here]] < v[p[up]])) while ((up > 0) && (v[p[here]] < v[p[up]])) /*we push the new value up the heap*/ { swap(p,q,up,here); here = up; up = here / 2; } else heapify(p,q,v,i,length); } void popHeap(int *p, int *q, double *v, int length, int i) { swap(p,q,i,length); /*puts new value at the last position in the heap*/ reHeapElement(p,q, v,length-1,i); /*put the swapped guy in the right place*/ } void pushHeap(int *p, int *q, double *v, int length, int i) { swap(p,q,i,length+1); /*puts new value at the last position in the heap*/ reHeapElement(p,q, v,length+1,length+1); /*put that guy in the right place*/ } int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh) { int i, heapsize; heapsize = 0; for(i = 1; i < arraySize;i++) if(v[q[i]] < thresh) pushHeap(p,q,v,heapsize++,i); return(heapsize); } ape/src/me_ols.c0000644000176200001440000005013414164530562013241 0ustar liggesusers/* me_ols.c 2012-04-30 */ /* Copyright 2007 Vincent Lefort GMEsplitEdge() modified by Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" /*from NNI.c*/ void fillTableUp(edge *e, edge *f, double **A, double **D, tree *T); /*OLSint and OLSext use the average distance array to calculate weights instead of using the edge average weight fields*/ void OLSext(edge *e, double **A) { edge *f, *g; if(leaf(e->head)) { f = siblingEdge(e); e->distance = 0.5*(A[e->head->index][e->tail->index] + A[e->head->index][f->head->index] - A[f->head->index][e->tail->index]); } else { f = e->head->leftEdge; g = e->head->rightEdge; e->distance = 0.5*(A[e->head->index][f->head->index] + A[e->head->index][g->head->index] - A[f->head->index][g->head->index]); } } double wf(double lambda, double D_LR, double D_LU, double D_LD, double D_RU, double D_RD, double D_DU) { double weight; weight = 0.5*(lambda*(D_LU + D_RD) + (1 -lambda)*(D_LD + D_RU) - (D_LR + D_DU)); return(weight); } void OLSint(edge *e, double **A) { double lambda; edge *left, *right, *sib; left = e->head->leftEdge; right = e->head->rightEdge; sib = siblingEdge(e); lambda = ((double) sib->bottomsize*left->bottomsize + right->bottomsize*e->tail->parentEdge->topsize) / (e->bottomsize*e->topsize); e->distance = wf(lambda,A[left->head->index][right->head->index], A[left->head->index][e->tail->index], A[left->head->index][sib->head->index], A[right->head->index][e->tail->index], A[right->head->index][sib->head->index], A[sib->head->index][e->tail->index]); } void assignOLSWeights(tree *T, double **A) { edge *e; e = depthFirstTraverse(T,NULL); while (NULL != e) { if ((leaf(e->head)) || (leaf(e->tail))) OLSext(e,A); else OLSint(e,A); e = depthFirstTraverse(T,e); } } /*makes table of average distances from scratch*/ void makeOLSAveragesTable(tree *T, double **D, double **A) { edge *e, *f, *g, *h; edge *exclude; e = f = NULL; e = depthFirstTraverse(T,e); while (NULL != e) { f = e; exclude = e->tail->parentEdge; /*we want to calculate A[e->head][f->head] for all edges except those edges which are ancestral to e. For those edges, we will calculate A[e->head][f->head] to have a different meaning, later*/ if(leaf(e->head)) while (NULL != f) { if (exclude != f) { if (leaf(f->head)) A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->head->index2][f->head->index2]; else { g = f->head->leftEdge; h = f->head->rightEdge; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->bottomsize*A[e->head->index][g->head->index] + h->bottomsize*A[e->head->index][h->head->index])/f->bottomsize; } } else /*exclude == f*/ exclude = exclude->tail->parentEdge; f = depthFirstTraverse(T,f); } else /*e->head is not a leaf, so we go recursively to values calculated for the nodes below e*/ while(NULL !=f ) { if (exclude != f) { g = e->head->leftEdge; h = e->head->rightEdge; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->bottomsize*A[f->head->index][g->head->index] + h->bottomsize*A[f->head->index][h->head->index])/e->bottomsize; } else exclude = exclude->tail->parentEdge; f = depthFirstTraverse(T,f); } /*now we move to fill up the rest of the table: we want A[e->head->index][f->head->index] for those cases where e is an ancestor of f, or vice versa. We'll do this by choosing e via a depth first-search, and the recursing for f up the path to the root*/ f = e->tail->parentEdge; if (NULL != f) fillTableUp(e,f,A,D,T); e = depthFirstTraverse(T,e); } /*we are indexing this table by vertex indices, but really the underlying object is the edge set. Thus, the array is one element too big in each direction, but we'll ignore the entries involving the root, and instead refer to each edge by the head of that edge. The head of the root points to the edge ancestral to the rest of the tree, so we'll keep track of up distances by pointing to that head*/ /*10/13/2001: collapsed three depth-first searces into 1*/ } void GMEcalcDownAverage(node *v, edge *e, double **D, double **A) { edge *left, *right; if (leaf(e->head)) A[e->head->index][v->index] = D[v->index2][e->head->index2]; else { left = e->head->leftEdge; right = e->head->rightEdge; A[e->head->index][v->index] = ( left->bottomsize * A[left->head->index][v->index] + right->bottomsize * A[right->head->index][v->index]) / e->bottomsize; } } void GMEcalcUpAverage(node *v, edge *e, double **D, double **A) { edge *up, *down; if (NULL == e->tail->parentEdge) A[v->index][e->head->index] = D[v->index2][e->tail->index2]; else { up = e->tail->parentEdge; down = siblingEdge(e); A[v->index][e->head->index] = (up->topsize * A[v->index][up->head->index] + down->bottomsize * A[down->head->index][v->index]) / e->topsize; } } /*this function calculates average distance D_Xv for each X which is a set of leaves of an induced subtree of T*/ void GMEcalcNewvAverages(tree *T, node *v, double **D, double **A) { /*loop over edges*/ /*depth-first search*/ edge *e; e = NULL; e = depthFirstTraverse(T,e); /*the downward averages need to be calculated from bottom to top */ while(NULL != e) { GMEcalcDownAverage(v,e,D,A); e = depthFirstTraverse(T,e); } e = topFirstTraverse(T,e); /*the upward averages need to be calculated from top to bottom */ while(NULL != e) { GMEcalcUpAverage(v,e,D,A); e = topFirstTraverse(T,e); } } double wf4(double lambda, double lambda2, double D_AB, double D_AC, double D_BC, double D_Av, double D_Bv, double D_Cv) { return(((1 - lambda) * (D_AC + D_Bv) + (lambda2 - 1)*(D_AB + D_Cv) + (lambda - lambda2)*(D_BC + D_Av))); } /*testEdge cacluates what the OLS weight would be if v were inserted into T along e. Compare against known values for inserting along f = e->parentEdge */ /*edges are tested by a top-first, left-first scheme. we presume all distances are fixed to the correct weight for e->parentEdge, if e is a left-oriented edge*/ void testEdge(edge *e, node *v, double **A) { double lambda, lambda2; edge *par, *sib; sib = siblingEdge(e); par = e->tail->parentEdge; /*C is set above e->tail, B is set below e, and A is set below sib*/ /*following the nomenclature of Desper & Gascuel*/ lambda = (((double) (sib->bottomsize + e->bottomsize*par->topsize)) / ((1 + par->topsize)*(par->bottomsize))); lambda2 = (((double) (sib->bottomsize + e->bottomsize*par->topsize)) / ((1 + e->bottomsize)*(e->topsize))); e->totalweight = par->totalweight + wf4(lambda,lambda2,A[e->head->index][sib->head->index], A[sib->head->index][e->tail->index], A[e->head->index][e->tail->index], A[sib->head->index][v->index],A[e->head->index][v->index], A[v->index][e->tail->index]); } void printDoubleTable(double **A, int d) { int i,j; for(i=0;ilabel);*/ /*initialize variables as necessary*/ /*CASE 1: T is empty, v is the first node*/ if (NULL == T) /*create a tree with v as only vertex, no edges*/ { T_e = newTree(); T_e->root = v; /*note that we are rooting T arbitrarily at a leaf. T->root is not the phylogenetic root*/ v->index = 0; T_e->size = 1; return(T_e); } /*CASE 2: T is a single-vertex tree*/ if (1 == T->size) { v->index = 1; e = makeEdge("",T->root,v,0.0); //sprintf(e->label,"E1"); snprintf(e->label,EDGE_LABEL_LENGTH,"E1"); e->topsize = 1; e->bottomsize = 1; A[v->index][v->index] = D[v->index2][T->root->index2]; T->root->leftEdge = v->parentEdge = e; T->size = 2; return(T); } /*CASE 3: T has at least two nodes and an edge. Insert new node by breaking one of the edges*/ v->index = T->size; /*if (!(T->size % 100)) printf("T->size is %d\n",T->size);*/ GMEcalcNewvAverages(T,v,D,A); /*calcNewvAverges will assign values to all the edge averages of T which include the node v. Will do so using pre-existing averages in T and information from A,D*/ e_min = T->root->leftEdge; e = e_min->head->leftEdge; while (NULL != e) { testEdge(e,v,A); /*testEdge tests weight of tree if loop variable e is the edge split, places this weight in e->totalweight field */ if (e->totalweight < w_min) { e_min = e; w_min = e->totalweight; } e = topFirstTraverse(T,e); } /*e_min now points at the edge we want to split*/ GMEsplitEdge(T,v,e_min,A); return(T); } void updateSubTreeAverages(double **A, edge *e, node *v, int direction); /*the ME version of updateAveragesMatrix does not update the entire matrix A, but updates A[v->index][w->index] whenever this represents an average of 1-distant or 2-distant subtrees*/ void GMEupdateAveragesMatrix(double **A, edge *e, node *v, node *newNode) { edge *sib, *par, *left, *right; sib = siblingEdge(e); left = e->head->leftEdge; right = e->head->rightEdge; par = e->tail->parentEdge; /*we need to update the matrix A so all 1-distant, 2-distant, and 3-distant averages are correct*/ /*first, initialize the newNode entries*/ /*1-distant*/ A[newNode->index][newNode->index] = (e->bottomsize*A[e->head->index][e->head->index] + A[v->index][e->head->index]) / (e->bottomsize + 1); /*1-distant for v*/ A[v->index][v->index] = (e->bottomsize*A[e->head->index][v->index] + e->topsize*A[v->index][e->head->index]) / (e->bottomsize + e->topsize); /*2-distant for v,newNode*/ A[v->index][newNode->index] = A[newNode->index][v->index] = A[v->index][e->head->index]; /*second 2-distant for newNode*/ A[newNode->index][e->tail->index] = A[e->tail->index][newNode->index] = (e->bottomsize*A[e->head->index][e->tail->index] + A[v->index][e->tail->index])/(e->bottomsize + 1); /*third 2-distant for newNode*/ A[newNode->index][e->head->index] = A[e->head->index][newNode->index] = A[e->head->index][e->head->index]; if (NULL != sib) { /*fourth and last 2-distant for newNode*/ A[newNode->index][sib->head->index] = A[sib->head->index][newNode->index] = (e->bottomsize*A[sib->head->index][e->head->index] + A[sib->head->index][v->index]) / (e->bottomsize + 1); updateSubTreeAverages(A,sib,v,SKEW); /*updates sib and below*/ } if (NULL != par) { if (e->tail->leftEdge == e) updateSubTreeAverages(A,par,v,LEFT); /*updates par and above*/ else updateSubTreeAverages(A,par,v,RIGHT); } if (NULL != left) updateSubTreeAverages(A,left,v,UP); /*updates left and below*/ if (NULL != right) updateSubTreeAverages(A,right,v,UP); /*updates right and below*/ /*1-dist for e->head*/ A[e->head->index][e->head->index] = (e->topsize*A[e->head->index][e->head->index] + A[e->head->index][v->index]) / (e->topsize+1); /*2-dist for e->head (v,newNode,left,right) taken care of elsewhere*/ /*3-dist with e->head either taken care of elsewhere (below) or unchanged (sib,e->tail)*/ /*symmetrize the matrix (at least for distant-2 subtrees) */ A[v->index][e->head->index] = A[e->head->index][v->index]; /*and distant-3 subtrees*/ A[e->tail->index][v->index] = A[v->index][e->tail->index]; if (NULL != left) A[v->index][left->head->index] = A[left->head->index][v->index]; if (NULL != right) A[v->index][right->head->index] = A[right->head->index][v->index]; if (NULL != sib) A[v->index][sib->head->index] = A[sib->head->index][v->index]; } void GMEsplitEdge(tree *T, node *v, edge *e, double **A) { int nodelabel = 0;//char nodelabel[NODE_LABEL_LENGTH]; char edgelabel[EDGE_LABEL_LENGTH]; edge *newPendantEdge; edge *newInternalEdge; node *newNode; //snprintf(nodelabel,1,""); newNode = makeNewNode(nodelabel,T->size + 1); //sprintf(edgelabel,"E%d",T->size); snprintf(edgelabel,EDGE_LABEL_LENGTH,"E%d",T->size); newPendantEdge = makeEdge(edgelabel,newNode,v,0.0); //sprintf(edgelabel,"E%d",T->size+1); snprintf(edgelabel,EDGE_LABEL_LENGTH,"E%d",T->size+1); newInternalEdge = makeEdge(edgelabel,newNode,e->head,0.0); /* if (verbose) printf("Inserting node %s on edge %s between nodes %s and %s.\n", v->label,e->label,e->tail->label,e->head->label);*/ /*update the matrix of average distances*/ /*also updates the bottomsize, topsize fields*/ GMEupdateAveragesMatrix(A,e,v,newNode); newNode->parentEdge = e; e->head->parentEdge = newInternalEdge; v->parentEdge = newPendantEdge; e->head = newNode; T->size = T->size + 2; if (e->tail->leftEdge == e) { newNode->leftEdge = newInternalEdge; newNode->rightEdge = newPendantEdge; } else { newNode->leftEdge = newInternalEdge; newNode->rightEdge = newPendantEdge; } /*assign proper topsize, bottomsize values to the two new Edges*/ newPendantEdge->bottomsize = 1; newPendantEdge->topsize = e->bottomsize + e->topsize; newInternalEdge->bottomsize = e->bottomsize; newInternalEdge->topsize = e->topsize; /*off by one, but we adjust that below*/ /*and increment these fields for all other edges*/ updateSizes(newInternalEdge,UP); updateSizes(e,DOWN); } void updateSubTreeAverages(double **A, edge *e, node *v, int direction) /*the monster function of this program*/ { edge *sib, *left, *right, *par; left = e->head->leftEdge; right = e->head->rightEdge; sib = siblingEdge(e); par = e->tail->parentEdge; switch(direction) { /*want to preserve correctness of all 1-distant, 2-distant, and 3-distant averages*/ /*1-distant updated at edge splitting the two trees*/ /*2-distant updated: (left->head,right->head) and (head,tail) updated at a given edge. Note, NOT updating (head,sib->head)! (That would lead to multiple updating).*/ /*3-distant updated: at edge in center of quartet*/ case UP: /*point of insertion is above e*/ /*1-distant average of nodes below e to nodes above e*/ A[e->head->index][e->head->index] = (e->topsize*A[e->head->index][e->head->index] + A[e->head->index][v->index])/(e->topsize + 1); /*2-distant average of nodes below e to nodes above parent of e*/ A[e->head->index][par->head->index] = A[par->head->index][e->head->index] = (par->topsize*A[par->head->index][e->head->index] + A[e->head->index][v->index]) / (par->topsize + 1); /*must do both 3-distant averages involving par*/ if (NULL != left) { updateSubTreeAverages(A, left, v, UP); /*and recursive call*/ /*3-distant average*/ A[par->head->index][left->head->index] = A[left->head->index][par->head->index] = (par->topsize*A[par->head->index][left->head->index] + A[left->head->index][v->index]) / (par->topsize + 1); } if (NULL != right) { updateSubTreeAverages(A, right, v, UP); A[par->head->index][right->head->index] = A[right->head->index][par->head->index] = (par->topsize*A[par->head->index][right->head->index] + A[right->head->index][v->index]) / (par->topsize + 1); } break; case SKEW: /*point of insertion is skew to e*/ /*1-distant average of nodes below e to nodes above e*/ A[e->head->index][e->head->index] = (e->topsize*A[e->head->index][e->head->index] + A[e->head->index][v->index])/(e->topsize + 1); /*no 2-distant averages to update in this case*/ /*updating 3-distant averages involving sib*/ if (NULL != left) { updateSubTreeAverages(A, left, v, UP); A[sib->head->index][left->head->index] = A[left->head->index][sib->head->index] = (sib->bottomsize*A[sib->head->index][left->head->index] + A[left->head->index][v->index]) / (sib->bottomsize + 1); } if (NULL != right) { updateSubTreeAverages(A, right, v, UP); A[sib->head->index][right->head->index] = A[right->head->index][sib->head->index] = (sib->bottomsize*A[par->head->index][right->head->index] + A[right->head->index][v->index]) / (sib->bottomsize + 1); } break; case LEFT: /*point of insertion is below the edge left*/ /*1-distant average*/ A[e->head->index][e->head->index] = (e->bottomsize*A[e->head->index][e->head->index] + A[v->index][e->head->index])/(e->bottomsize + 1); /*2-distant averages*/ A[e->head->index][e->tail->index] = A[e->tail->index][e->head->index] = (e->bottomsize*A[e->head->index][e->tail->index] + A[v->index][e->tail->index])/(e->bottomsize + 1); A[left->head->index][right->head->index] = A[right->head->index][left->head->index] = (left->bottomsize*A[right->head->index][left->head->index] + A[right->head->index][v->index]) / (left->bottomsize+1); /*3-distant avereages involving left*/ if (NULL != sib) { updateSubTreeAverages(A, sib, v, SKEW); A[left->head->index][sib->head->index] = A[sib->head->index][left->head->index] = (left->bottomsize*A[left->head->index][sib->head->index] + A[sib->head->index][v->index]) / (left->bottomsize + 1); } if (NULL != par) { if (e->tail->leftEdge == e) updateSubTreeAverages(A, par, v, LEFT); else updateSubTreeAverages(A, par, v, RIGHT); A[left->head->index][par->head->index] = A[par->head->index][left->head->index] = (left->bottomsize*A[left->head->index][par->head->index] + A[v->index][par->head->index]) / (left->bottomsize + 1); } break; case RIGHT: /*point of insertion is below the edge right*/ /*1-distant average*/ A[e->head->index][e->head->index] = (e->bottomsize*A[e->head->index][e->head->index] + A[v->index][e->head->index])/(e->bottomsize + 1); /*2-distant averages*/ A[e->head->index][e->tail->index] = A[e->tail->index][e->head->index] = (e->bottomsize*A[e->head->index][e->tail->index] + A[v->index][e->tail->index])/(e->bottomsize + 1); A[left->head->index][right->head->index] = A[right->head->index][left->head->index] = (right->bottomsize*A[right->head->index][left->head->index] + A[left->head->index][v->index]) / (right->bottomsize+1); /*3-distant avereages involving right*/ if (NULL != sib) { updateSubTreeAverages(A, sib, v, SKEW); A[right->head->index][sib->head->index] = A[sib->head->index][right->head->index] = (right->bottomsize*A[right->head->index][sib->head->index] + A[sib->head->index][v->index]) / (right->bottomsize + 1); } if (NULL != par) { if (e->tail->leftEdge == e) updateSubTreeAverages(A, par, v, LEFT); else updateSubTreeAverages(A, par, v, RIGHT); A[right->head->index][par->head->index] = A[par->head->index][right->head->index] = (right->bottomsize*A[right->head->index][par->head->index] + A[v->index][par->head->index]) / (right->bottomsize + 1); } break; } } void assignBottomsize(edge *e) { if (leaf(e->head)) e->bottomsize = 1; else { assignBottomsize(e->head->leftEdge); assignBottomsize(e->head->rightEdge); e->bottomsize = e->head->leftEdge->bottomsize + e->head->rightEdge->bottomsize; } } void assignTopsize(edge *e, int numLeaves) { if (NULL != e) { e->topsize = numLeaves - e->bottomsize; assignTopsize(e->head->leftEdge,numLeaves); assignTopsize(e->head->rightEdge,numLeaves); } } void assignAllSizeFields(tree *T) { assignBottomsize(T->root->leftEdge); assignTopsize(T->root->leftEdge,T->size/2 + 1); } ape/src/SPR.c0000644000176200001440000003443014164530562012430 0ustar liggesusers/* SPR.c 2013-09-26 */ /* Copyright 2009 Richard Desper */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" /*functions from bNNI.c*/ void makeBMEAveragesTable(tree *T, double **D, double **A); void assignBMEWeights(tree *T, double **A); /*from me.c*/ edge *siblingEdge(edge *e); void weighTree(tree *T); void freeMatrix(double **D, int size); edge *depthFirstTraverse(tree *T, edge *e); double **initDoubleMatrix(int d); /*from below*/ node *indexedNode(tree *T, int i); edge *indexedEdge(tree *T, int i); void assignSPRWeights(node *v, double **A, double ***swapWeights); void SPRTopShift(tree *T, node *vmove, edge *esplit, int UpOrDown); void assignDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights); void assignDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights); void assignDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights); void assignUpWeights(edge *etest, node *vtest, node *va, edge *back, node *cprve, double oldD_AB, double coeff, double **A, double ***swapWeights); void zero3DMatrix(double ***X, int h, int l, int w) { int i,j,k; for(i=0;iweight);*/ for(i=0;i<2;i++) swapWeights[i] = initDoubleMatrix(T->size); do { swapValue=0.0; zero3DMatrix(swapWeights,2,T->size,T->size); i = j = k = 0; for(e=depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e)) assignSPRWeights(e->head,A,swapWeights); findTableMin(&i,&j,&k,T->size,swapWeights,&swapValue); swapValue = swapWeights[i][j][k]; if (swapValue < -EPSILON) { // if (verbose) // printf("New tree weight should be %lf.\n",T->weight + 0.25*swapValue); v = indexedNode(T,j); f = indexedEdge(T,k); // if (verbose) // printf("Swapping tree below %s to split edge %s with head %s and tail %s\n", // v->parentEdge->label,f->label,f->head->label,f->tail->label); SPRTopShift(T,v,f,2-i); makeBMEAveragesTable(T,D,A); assignBMEWeights(T,A); weighTree(T); (*count)++; /*sprintf(filename,"tree%d.new",*count);*/ // if (verbose) // printf("After %d SPRs, tree weight is %lf.\n\n",*count,T->weight); /*treefile = fopen(filename,"w"); NewickPrintTree(T,treefile); fclose(treefile);*/ } } while (swapValue < -EPSILON); for(i=0;i<2;i++) freeMatrix(swapWeights[i],T->size); free(swapWeights); /*if (verbose) readOffTree(T);*/ } /*assigns values to array swapWeights*/ /*swapWeights[0][j][k] will be the value of removing the tree below the edge whose head node has index j and reattaching it to split the edge whose head has the index k*/ /*swapWeights[1][j][k] will be the value of removing the tree above the edge whose head node has index j and reattaching it to split the edge whose head has the index k*/ void assignSPRWeights(node *vtest, double **A, double ***swapWeights) { edge *etest, *left, *right, *sib, *par; etest = vtest->parentEdge; left = vtest->leftEdge; right = vtest->rightEdge; par = etest->tail->parentEdge; sib = siblingEdge(etest); if (NULL != par) assignDownWeightsUp(par,vtest,sib->head,NULL,NULL,0.0,1.0,A,swapWeights); if (NULL != sib) assignDownWeightsSkew(sib,vtest,sib->tail,NULL,NULL,0.0,1.0,A,swapWeights); /*assigns values for moving subtree rooted at vtest, starting with edge parental to tail of edge parental to vtest*/ if (NULL != left) { assignUpWeights(left,vtest,right->head,NULL,NULL,0.0,1.0,A,swapWeights); assignUpWeights(right,vtest,left->head,NULL,NULL,0.0,1.0,A,swapWeights); } } /*recall NNI formula: change in tree length from AB|CD split to AC|BD split is proportional to D_AC + D_BD - D_AB - D_CD*/ /*in our case B is the tree being moved (below vtest), A is the tree backwards below back, but with the vtest subtree removed, C is the sibling tree of back and D is the tree above etest*/ /*use va to denote the root of the sibling tree to B in the original tree*/ /*please excuse the multiple uses of the same letters: A,D, etc.*/ void assignDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights) { edge *par, *sib, *skew; double D_AC, D_BD, D_AB, D_CD; par = etest->tail->parentEdge; skew = siblingEdge(etest); if (NULL == back) /*first recursive call*/ { if (NULL == par) return; else /*start the process of assigning weights recursively*/ { assignDownWeightsUp(par,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights); assignDownWeightsSkew(skew,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights); } } else /*second or later recursive call*/ { sib = siblingEdge(back); D_BD = A[vtest->index][etest->head->index]; /*straightforward*/ D_CD = A[sib->head->index][etest->head->index]; /*this one too*/ D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index] - A[sib->head->index][vtest->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); if (NULL != par) { assignDownWeightsUp(par,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights); assignDownWeightsSkew(skew,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights); } } } void assignDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights) { /*same general idea as assignDownWeights, except needing to keep track of things a bit differently*/ edge *par, *left, *right; /*par here = sib before left, right here = par, skew before*/ double D_AB, D_CD, D_AC, D_BD; /*B is subtree being moved - below vtest A is subtree remaining fixed - below va, unioned with all trees already passed by B*/ /*C is subtree being passed by B, in this case above par D is subtree below etest, fixed on other side*/ par = etest->tail->parentEdge; left = etest->head->leftEdge; right = etest->head->rightEdge; if (NULL == back) { if (NULL == left) return; else { assignDownWeightsDown(left,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights); assignDownWeightsDown(right,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights); } } else { D_BD = A[vtest->index][etest->head->index]; D_CD = A[par->head->index][etest->head->index]; D_AC = A[back->head->index][par->head->index] + coeff*(A[va->index][par->head->index] - A[vtest->index][par->head->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); if (NULL != left) { assignDownWeightsDown(left,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights); assignDownWeightsDown(right,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights); } } } void assignDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights) { /*again the same general idea*/ edge *sib, *left, *right; /*sib here = par in assignDownWeightsSkew rest is the same as assignDownWeightsSkew*/ double D_AB, D_CD, D_AC, D_BD; /*B is below vtest, A is below va unioned with all trees already passed by B*/ /*C is subtree being passed - below sib*/ /*D is tree below etest*/ sib = siblingEdge(etest); left = etest->head->leftEdge; right = etest->head->rightEdge; D_BD = A[vtest->index][etest->head->index]; D_CD = A[sib->head->index][etest->head->index]; D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index] - A[sib->head->index][vtest->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + ( D_AC + D_BD - D_AB - D_CD); if (NULL != left) { assignDownWeightsDown(left,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights); assignDownWeightsDown(right,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights); } } void assignUpWeights(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights) { /*SPR performed on tree above vtest...*/ /*same idea as above, with appropriate selections of edges and nodes*/ edge *sib, *left, *right; /*B is above vtest, A is other tree below vtest unioned with trees in path to vtest*/ /*sib is tree C being passed by B*/ /*D is tree below etest*/ double D_AB, D_CD, D_AC, D_BD; // double thisWeight; deleted by EP, 2013-09-16, also below sib = siblingEdge(etest); left = etest->head->leftEdge; right = etest->head->rightEdge; if (NULL == back) /*first recursive call*/ { if (NULL == left) return; else /*start the process of assigning weights recursively*/ { assignUpWeights(left,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights); assignUpWeights(right,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights); } } else /*second or later recursive call*/ { D_BD = A[vtest->index][etest->head->index]; D_CD = A[sib->head->index][etest->head->index]; D_AC = A[back->head->index][sib->head->index] + coeff*(A[va->index][sib->head->index] - A[vtest->index][sib->head->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); // thisWeight = deleted by EP, 2013-09-16 swapWeights[1][vtest->index][etest->head->index] = swapWeights[1][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); if (NULL != left) { assignUpWeights(left,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights); assignUpWeights(right,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights); } } } void pruneSubtree(edge *p, edge *u, edge *d) /*starting with edge u above edges p, d*/ /*removes p, d from tree, u connects to d->head to compensate*/ { p->tail->parentEdge = NULL;/*remove p subtree*/ u->head = d->head; d->head->parentEdge = u; /*u connected to d->head*/ d->head = NULL; /*d removed from tree*/ } void SPRsplitEdge(edge *e, edge *p, edge *d) /*splits edge e to make it parental to p,d. d is parental to what previously was below e*/ { d->head = e->head; e->head = p->tail; p->tail->parentEdge = e; d->head->parentEdge = d; } /*topological shift function*/ /*removes subtree rooted at v and re-inserts to spilt e*/ void SPRDownShift(tree *T, node *v, edge *e) { edge *vup, *vdown, *vpar; vpar = v->parentEdge; vdown = siblingEdge(vpar); vup = vpar->tail->parentEdge; /*topological shift*/ pruneSubtree(vpar,vup,vdown); /*removes v subtree and vdown, extends vup*/ SPRsplitEdge(e,vpar,vdown); /*splits e to make e sibling edge to vpar, both below vup*/ } void SPRUpShift(tree *T, node *vmove, edge *esplit) /*an inelegant iterative version*/ { edge *f; edge **EPath; edge **sib; node **v; int i; int pathLength; for(f=esplit->tail->parentEdge,pathLength=1;f->tail != vmove;f=f->tail->parentEdge) pathLength++; /*count number of edges to vmove*/ /*note that pathLength > 0 will hold*/ EPath = (edge **)malloc(pathLength*sizeof(edge *)); v = (node **)malloc(pathLength*sizeof(edge *)); sib = (edge **)malloc((pathLength+1)*sizeof(edge *)); /*there are pathLength + 1 side trees, one at the head and tail of each edge in the path*/ sib[pathLength] = siblingEdge(esplit); i = pathLength; f = esplit->tail->parentEdge; while (i > 0) { i--; EPath[i] = f; sib[i] = siblingEdge(f); v[i] = f->head; f = f->tail->parentEdge; } /*indexed so head of Epath is v[i], tail is v[i-1] and sibling edge is sib[i]*/ /*need to assign head, tail of each edge in path as well as have proper values for the left and right fields*/ if (esplit == esplit->tail->leftEdge) { vmove->leftEdge = esplit; vmove->rightEdge = EPath[pathLength-1]; } else { vmove->rightEdge = esplit; vmove->leftEdge = EPath[pathLength-1]; } esplit->tail = vmove; /*espilt->head remains unchanged*/ /*vmove has the proper fields for left, right, and parentEdge*/ for(i=0;i<(pathLength-1);i++) EPath[i]->tail = v[i+1]; /*this bit flips the orientation along the path the tail of Epath[i] is now v[i+1] instead of v[i-1]*/ EPath[pathLength-1]->tail = vmove; for(i=1;ileftEdge) v[i]->rightEdge = EPath[i-1]; else v[i]->leftEdge = EPath[i-1]; } if (sib[1] == v[0]->leftEdge) v[0]->rightEdge = sib[0]; else v[0]->leftEdge = sib[0]; sib[0]->tail = v[0]; free(EPath); free(v); free(sib); } void SPRTopShift(tree *T, node *vmove, edge *esplit, int UpOrDown) { if (DOWN == UpOrDown) SPRDownShift(T,vmove,esplit); else SPRUpShift(T,vmove,esplit); } node *indexedNode(tree *T, int i) { edge *e; for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e)) if (i == e->head->index) return(e->head); if (i == T->root->index) return(T->root); return(NULL); } edge *indexedEdge(tree *T, int i) { edge *e; for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e)) if (i == e->head->index) return(e); return(NULL); } ape/src/ape.h0000644000176200001440000000155614164530562012541 0ustar liggesusers/* ape.h 2014-01-02 */ /* Copyright 2011-2014 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include #define DINDEX(i, j) n*(i - 1) - i*(i - 1)/2 + j - i - 1 /* in ape.c */ int give_index(int i, int j, int n); SEXP getListElement(SEXP list, char *str); /* in njs.c */ void choosePair(double* D, int n, double* R, int* s, int* sw, int* x, int* y, int fS); double cnxy(int x, int y, int n, double* D); int mxy(int x,int y, int n, double* D); double nxy(int x, int y, int n, double* D); int cxy(int x, int y, int n, double* D); /* in triangMtd.c */ void C_triangMtd(double* d, int* np, int* ed1, int* ed2, double* edLen); int * getPathBetween(int x, int y, int n, int* ed1, int* ed2, int numEdges); int give_indexx(int i, int j, int n); /* a variant of the above */ ape/src/Makevars0000644000176200001440000000006014164530562013304 0ustar liggesusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) ape/src/ape.c0000644000176200001440000001463714164530562012540 0ustar liggesusers/* ape.c 2021-04-08 */ /* Copyright 2011-2021 Emmanuel Paradis, and 2007 R Development Core Team */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include "ape.h" int give_index(int i, int j, int n) { if (i > j) return(DINDEX(j, i)); else return(DINDEX(i, j)); } /* From R-ext manual (not the same than in library/stats/src/nls.c) */ SEXP getListElement(SEXP list, char *str) { SEXP res = R_NilValue, names = getAttrib(list, R_NamesSymbol); for (int i = 0; i < length(list); i++) { if (! strcmp(CHAR(STRING_ELT(names, i)), str)) { res = VECTOR_ELT(list, i); break; } } return res; } /* declare functions here to register them below */ void C_additive(double *dd, int* np, int* mp, double *ret); void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el); void C_bionjs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int* fsS); void delta_plot(double *D, int *size, int *nbins, int *counts, double *deltabar); void dist_nodes(int *n, int *m, int *e1, int *e2, double *el, int *N, double *D); void C_ewLasso(double *D, int *N, int *e1, int *e2); void mat_expo(double *P, int *nr); void me_b(double *X, int *N, int *labels, int *nni, int *spr, int *tbr, int *edge1, int *edge2, double *el); void me_o(double *X, int *N, int *labels, int *nni, int *edge1, int *edge2, double *el); void C_mvr(double *D, double* v,int *N, int *edge1, int *edge2, double *edge_length); void C_mvrs(double *D, double* v, int *N, int *edge1, int *edge2, double *edge_length, int* fsS); void neworder_pruningwise(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, int *neworder); SEXP C_nj(SEXP DIST, SEXP N); void C_njs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int *fsS); void node_depth(int *ntip, int *e1, int *e2, int *nedge, double *xx, int *method); void node_depth_edgelength(int *edge1, int *edge2, int *nedge, double *edge_length, double *xx); void node_height(int *edge1, int *edge2, int *nedge, double *yy); void node_height_clado(int *ntip, int *edge1, int *edge2, int *nedge, double *xx, double *yy); void C_pic(int *ntip, int *edge1, int *edge2, double *edge_len, double *phe, double *contr, double *var_contr, int *var, int *scaled); void C_rTraitCont(int *model, int *Nedge, int *edge1, int *edge2, double *el, double *sigma, double *alpha, double *theta, double *x); void C_treePop(int* splits, double* w,int* ncolp,int* np, int* ed1, int* ed2, double* edLen); void C_triangMtd(double* d, int* np, int* ed1,int* ed2, double* edLen); void C_triangMtds(double* d, int* np, int* ed1,int* ed2, double* edLen); void C_ultrametric(double *dd, int* np, int* mp, double *ret); void DNAbin2indelblock(unsigned char *x, int *n, int *s, int *y); void trans_DNA2AA(unsigned char *x, int *s, unsigned char *res, int *code); SEXP dist_dna(SEXP DNASEQ, SEXP MODEL, SEXP BASEFREQ, SEXP PAIRDEL, SEXP VARIANCE, SEXP GAMMA, SEXP ALPHA); SEXP GlobalDeletionDNA(SEXP DNASEQ); SEXP C_where(SEXP DNASEQ, SEXP PAT); SEXP rawStreamToDNAorAAbin(SEXP x, SEXP DNA); SEXP seq_root2tip(SEXP edge, SEXP nbtip, SEXP nbnode); SEXP treeBuildWithTokens(SEXP nwk); SEXP treeBuild(SEXP nwk); SEXP cladoBuildWithTokens(SEXP nwk); SEXP cladoBuild(SEXP nwk); SEXP bitsplits_multiPhylo(SEXP x, SEXP n, SEXP nr); SEXP CountBipartitionsFromSplits(SEXP split, SEXP SPLIT); SEXP _ape_prop_part2(SEXP trees, SEXP nTips); SEXP _ape_bipartition2(SEXP orig, SEXP nTips); SEXP _ape_reorderRcpp(SEXP orig, SEXP nTips, SEXP root, SEXP order); SEXP writeDNAbinToFASTA(SEXP x, SEXP FILENAME, SEXP n, SEXP s, SEXP labels); SEXP writeAAbinToFASTA(SEXP x, SEXP FILENAME, SEXP n, SEXP s, SEXP labels); SEXP charVectorToDNAbinVector(SEXP x); SEXP leading_trailing_gaps_to_N(SEXP DNASEQ); SEXP SegSites(SEXP DNASEQ, SEXP STRICT); SEXP BaseProportion(SEXP x); static R_CMethodDef C_entries[] = { {"C_additive", (DL_FUNC) &C_additive, 4}, {"C_bionj", (DL_FUNC) &C_bionj, 5}, {"C_bionjs", (DL_FUNC) &C_bionjs, 6}, {"delta_plot", (DL_FUNC) &delta_plot, 5}, {"dist_nodes", (DL_FUNC) &dist_nodes, 7}, {"C_ewLasso", (DL_FUNC) &C_ewLasso, 4}, {"mat_expo", (DL_FUNC) &mat_expo, 2}, {"me_b", (DL_FUNC) &me_b, 9}, {"me_o", (DL_FUNC) &me_o, 7}, {"C_mvr", (DL_FUNC) &C_mvr, 6}, {"C_mvrs", (DL_FUNC) &C_mvrs, 7}, {"neworder_pruningwise", (DL_FUNC) &neworder_pruningwise, 6}, {"C_njs", (DL_FUNC) &C_njs, 6}, {"node_depth", (DL_FUNC) &node_depth, 6}, {"node_depth_edgelength", (DL_FUNC) &node_depth_edgelength, 5}, {"node_height", (DL_FUNC) &node_height, 4}, {"node_height_clado", (DL_FUNC) &node_height_clado, 6}, {"C_pic", (DL_FUNC) &C_pic, 9}, {"C_rTraitCont", (DL_FUNC) &C_rTraitCont, 9}, {"C_treePop", (DL_FUNC) &C_treePop, 7}, {"C_triangMtd", (DL_FUNC) &C_triangMtd, 5}, {"C_triangMtds", (DL_FUNC) &C_triangMtds, 5}, {"C_ultrametric", (DL_FUNC) &C_ultrametric, 4}, {"DNAbin2indelblock", (DL_FUNC) &DNAbin2indelblock, 4}, {"trans_DNA2AA", (DL_FUNC) &trans_DNA2AA, 4}, {NULL, NULL, 0} }; static R_CallMethodDef Call_entries[] = { {"dist_dna", (DL_FUNC) &dist_dna, 7}, {"GlobalDeletionDNA", (DL_FUNC) &GlobalDeletionDNA, 1}, {"rawStreamToDNAorAAbin", (DL_FUNC) &rawStreamToDNAorAAbin, 2}, {"seq_root2tip", (DL_FUNC) &seq_root2tip, 3}, {"treeBuildWithTokens", (DL_FUNC) &treeBuildWithTokens, 1}, {"treeBuild", (DL_FUNC) &treeBuild, 1}, {"cladoBuildWithTokens", (DL_FUNC) &cladoBuildWithTokens, 1}, {"cladoBuild", (DL_FUNC) &cladoBuild, 1}, {"bitsplits_multiPhylo", (DL_FUNC) &bitsplits_multiPhylo, 3}, {"CountBipartitionsFromSplits", (DL_FUNC) &CountBipartitionsFromSplits, 2}, {"BaseProportion", (DL_FUNC) &BaseProportion, 1}, {"SegSites", (DL_FUNC) &SegSites, 2}, {"C_where", (DL_FUNC) &C_where, 2}, {"_ape_bipartition2", (DL_FUNC) &_ape_bipartition2, 2}, {"_ape_prop_part2", (DL_FUNC) &_ape_prop_part2, 2}, {"_ape_reorderRcpp", (DL_FUNC) &_ape_reorderRcpp, 4}, {"writeDNAbinToFASTA", (DL_FUNC) &writeDNAbinToFASTA, 5}, {"writeAAbinToFASTA", (DL_FUNC) &writeAAbinToFASTA, 5}, {"charVectorToDNAbinVector", (DL_FUNC) &charVectorToDNAbinVector, 1}, {"leading_trailing_gaps_to_N", (DL_FUNC) &leading_trailing_gaps_to_N, 1}, {"C_nj", (DL_FUNC) &C_nj, 2}, {NULL, NULL, 0} }; void R_init_ape(DllInfo *info) { R_registerRoutines(info, C_entries, Call_entries, NULL, NULL); R_useDynamicSymbols(info, FALSE); } ape/src/pic.c0000644000176200001440000000204414164530562012533 0ustar liggesusers/* pic.c 2017-04-25 */ /* Copyright 2006-2017 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include void C_pic(int *ntip, int *edge1, int *edge2, double *edge_len, double *phe, double *contr, double *var_contr, int *var, int *scaled) { /* The tree must be in pruningwise order */ int anc, d1, d2, ic, i, j, k; double sumbl; for (i = 0; i < *ntip * 2 - 3; i += 2) { j = i + 1; anc = edge1[i]; d1 = edge2[i] - 1; d2 = edge2[j] - 1; sumbl = edge_len[i] + edge_len[j]; ic = anc - *ntip - 1; contr[ic] = phe[d1] - phe[d2]; if (*scaled) contr[ic] = contr[ic]/sqrt(sumbl); if (*var) var_contr[ic] = sumbl; phe[anc - 1] = (phe[d1]*edge_len[j] + phe[d2]*edge_len[i])/sumbl; /* find the edge where `anc' is a descendant (except if at the root): it is obviously below the j'th edge */ if (j != *ntip * 2 - 3) { k = j + 1; while (edge2[k] != anc) k++; edge_len[k] = edge_len[k] + edge_len[i]*edge_len[j]/sumbl; } } } ape/src/bionjs.c0000644000176200001440000003060614164530562013251 0ustar liggesusers/* bionjs.c 2014-03-21 */ /* Copyright 2011-2014 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_bionjs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int* fsS) { //assume missing values are denoted by -1 double *S,*R , *v,*new_v, Sdist, Ndist, *new_dist, A, B, smallest_S; int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label; int *s;//s contains |Sxy|, which is all we need for agglomeration double *newR; int *newS; int fS=*fsS; R = &Sdist; new_dist = &Ndist; otu_label = &o_l; n = *N; cur_nod = 2*n - 2; R = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); v = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); new_v = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); S = (double*)R_alloc(n + 1, sizeof(double)); newR = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); otu_label = (int*)R_alloc(n + 1, sizeof(int)); s = (int*)R_alloc(n*(n - 1)/2, sizeof(int)); newS = (int*)R_alloc(n*(n - 1)/2, sizeof(int)); for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */ k = 0; //populate the v matrix for(i=1;i 3) { ij = 0; for(i=1;i smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; /* smallest = ij; */ } ij++; } } } //update R and S, only if matrix still incomplete if(sw==1) for(i=1;i1.0)lamb=1.0; }else{ if(v[give_index(OTU2,OTU1,n)]!=0.0) lamb=0.5+(1.0/(2*(n-2)*v[give_index(OTU1,OTU2,n)]))*lambSum; else lamb=0.5; if(lamb<0.0)lamb=0.0; if(lamb>1.0)lamb=1.0; } //although s was updated above, s[otu1,otu2] has remained unchanged //so it is safe to use it here //if complete distanes, use N-2, else use S int down=B; if(sw==1){down=s[give_index(OTU1,OTU2,n)]-2;} if(down<=0) {error("distance information insufficient to construct a tree, leaves %i and %i isolated from tree",OTU1,OTU2); } sum*=(1.0/(2*(down))); double dxy=D[give_index(OTU1,OTU2,n)]/2; edge_length[k] = dxy+sum;//OTU1 edge_length[k + 1] = dxy-sum;//OTU2 //no need to change distance matrix update for complete distance //case, as pairs will automatically fall in the right cathegory //OTU1=x, OTU2=y from formulas A = D[give_index(OTU1,OTU2,n)]; ij = 0; for (i = 1; i <= n; i++) { if (i == OTU1 || i == OTU2) continue; if(D[give_index(OTU1,i,n)]!=-1 && D[give_index(OTU2,i,n)]!=-1) { new_dist[ij]= lamb*(D[give_index(OTU1,i,n)]-edge_length[k])+(1-lamb)*(D[give_index(OTU2,i,n)]-edge_length[k+1]); new_v[ij]=lamb*v[give_index(OTU1,i,n)]+(1-lamb)*v[give_index(OTU2,i,n)]-lamb*(1-lamb)*v[give_index(OTU1,OTU2,n)]; }else{ if(D[give_index(OTU1,i,n)]!=-1) { new_dist[ij]=D[give_index(OTU1,i,n)]-edge_length[k]; new_v[ij]=v[give_index(OTU1,i,n)]; }else{ if(D[give_index(OTU2,i,n)]!=-1) { new_dist[ij]=D[give_index(OTU2,i,n)]-edge_length[k+1]; new_v[ij]=v[give_index(OTU2,i,n)]; }else{new_dist[ij]=-1;new_v[ij]=-1;} } } ij++; } for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; new_v[ij]=v[give_index(i,j,n)]; ij++; } } //compute Rui, only if distance matrix is still incomplete ij=0; if(sw==1) for(i=2;i 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; n--; for (i = 0; i < n*(n - 1)/2; i++) { D[i] = new_dist[i]; v[i] = new_v[i]; if(sw==1) { R[i] = newR[i]; s[i] = newS[i]; } } cur_nod--; k = k + 2; } int dK=0;//number of known distances in final distance matrix int iUK=-1;//index of unkown distance, if we have one missing distance int iK=-1;//index of only known distance, only needed if dK==1 for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; if(D[i]!=-1){dK++;iK=i;}else{iUK=i;} } if(dK==2) {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown //and edge weights of three edges are a,b,c, then any b,c>0 that //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for //simplicity we assume a=c if d(yz)max)max=D[i]; } D[iUK]=max; } if(dK==1) {//through similar motivation as above, if we have just one known distance //we set the other two distances equal to it for(i=0;i<3;i++) {if(i==iK)continue; D[i]=D[iK]; } } if(dK==0) {//no distances are known, we just set them to 1 for(i=0;i<3;i++) {D[i]=1; } } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/ultrametric.c0000644000176200001440000000245414164530562014320 0ustar liggesusers/* ultrametric.c 2011-10-11 */ /* Copyright 2011 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_ultrametric(double *dd, int* np, int* mp, double *ret)//d received as dist object, -1 for missing entries { int n=*np; int m=*mp; int i=0,j=0; double max=dd[0]; double d[n][n]; for(i=1;imax) { max=dd[give_index(i,j,n)]; } } } d[n-1][n-1]=0; int entrCh=0; do{ entrCh=0; for(i=0;i d[j][k] ? d[i][k] : d[j][k]; if(mxk) { ed1[i]+=(n-k); } if(ed2[i]>k) { ed2[i]+=(n-k); } } for(i=0;i<2*k-3;i++) { if(ed2[i]<=k) { ed2[i]=o[ed2[i]]; } } for(i=1;i<=n;i++) { if(s[i]==0)continue;//take only leaves not in Y m[i]=0; for(j=1;j<=n;j++) { if(s[j]==1)continue;//take only leaves already in Y if(d[give_index(i,j,n)]==-1)continue;//igonore if distance unknown m[i]++; } } int numEdges=2*k-4;//0-based, so subtract 1 int nv=(k-2)+n; while(k i not added to tree int max=-1; int maxPos=-1; for(i=1;i<=n;i++) { if(s[i]==0)continue; if(m[i]>max) { max=m[i]; maxPos=i; } } s[maxPos]=0;//mark maxPos as added //calculate new m values for leaves not added, i.e we just increment any //already present value by 1 if we know the distance between i and maxPos for(i=1;i<=n;i++) { if(s[i]==0)continue; if(d[give_index(i,maxPos,n)]==-1)continue; m[i]++; } //find path to attach maxPos to, grow tree double minDist=1e50; int z=maxPos; int x=-1,y=-1; for(i=1;i %i ",p,ord[p]); p=ord[p]; prevSum=sum; for(i=0;i<=numEdges;i++) { if((ed1[i]==aux && ed2[i]==p)||(ed2[i]==aux && ed1[i]==p)) { if(ed1[i]==aux && ed2[i]==p){sw=1;} subdiv=i; sum+=edLen[i]; } } //if(cc>1000)error("failed to follow path between x=%i y=%i\n",x,y); } nv++; //subdivide subdiv with a node labelled nv //length calculation int edd=ed2[subdiv]; ed2[subdiv]=nv; edLen[subdiv]= (sw==1)?(lx-prevSum):(sum-lx);//check which 'half' of the //path the leaf belongs to //and updates accordingly //error("sum=%f, prevsum=%f\n",sum,prevSum); //error("lx-prevSum=%f, sum-lx=%f, minDist=%f",lx-prevSum,sum-lx,minDist); numEdges++; ed1[numEdges]=nv; ed2[numEdges]=edd; edLen[numEdges]= (sw==1)?(sum-lx):(lx-prevSum); numEdges++; edLen[numEdges]=minDist; ed1[numEdges]=nv; ed2[numEdges]=z; k++; } } ape/src/ewLasso.c0000644000176200001440000001215614164530562013402 0ustar liggesusers/* ewLasso.c 2013-03-30 */ /* Copyright 2013 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" int isTripletCover(int nmb, int n, int** s, int stat, int sSoFar[n], int* a)//number of sides, number of leaves, sides, side under consideration, set so far, lasso { int ret=0; if(stat==nmb)return 1; int i=0; for(i=1;i<=n;i++) { if(!s[stat][i])continue;//not in set int sw=1, j; for(j=1;j<=n;j++)//check if all distances to previous candidates are present { if(!sSoFar[j])continue;//not in set so far if(!a[i*(n+1)+j]){//if not, then i is not a good candidate for this side //Rprintf("failed to find distance between %i and %i, a[%i][%i]=%i \n",i,j,i,j,a[i*(n+1)+j]); sw=0; } } if(!sw)continue;//not all required distances are present sSoFar[i]=1;//try choosing i as representative for the side ret+=isTripletCover(nmb,n,s,stat+1,sSoFar,a)>0?1:0;//see if, with i chosen, we can find leaves in other sides to satisfy the triplet cover condition sSoFar[i]=0; } return ret; } void C_ewLasso(double *D, int *N, int *e1, int *e2) { int n, i, j, k; n=*N; int tCov=1; int* a = (int*)R_alloc((n+1)*(n+1), sizeof(int));//adjacency matrix of G_{\cL} graph for(i=1;i<=n;i++) { for(j=1;j<=n;j++) { if(D[give_index(i,j,n)]==-1)//if missing value then no edge between pair of taxa (i,j) in G { a[i*(n+1)+j]=a[j*(n+1)+i]=0; } else { a[i*(n+1)+j]=a[j*(n+1)+i]=1;// otherwise edge between pair of taxa (i,j) in G } } } //check for connectedness of G int *q = (int*)R_alloc(2*n-1, sizeof(int));//BFS queue int *v = (int*)R_alloc(2*n-1, sizeof(int));//visited? int p=0,u=1;//p-head of queue, u- position after last loaded element for(i=1;i<=n;i++)v[i]=-1; int stNBipartite=1, con=1, comp=1; int ini=1; /*for(i=1;i<=n;i++) { for(j=1;j<=n;j++) { Rprintf("a[%i][%i]=%i ",i,j,a[i*(n+1)+j]); } Rprintf("\n"); }*/ while(comp) { q[p]=ini; v[ini]=1; comp=0; int stNBipartiteLoc=0;//check if current connected component is bipartite while(p not bipartite { stNBipartiteLoc=1; } if(v[i]!=-1)continue; //Rprintf("vertex %i \n",i); q[u++]=i; v[i]=1-v[head]; } p++; } stNBipartite*=stNBipartiteLoc;//anding strngly-non-bipartite over all connected components //check if all vertices have been visited for(int i=1;i<=n;i++) { if(v[i]==-1) { comp=1; p=0; u=1; ini=i; con=0; break; } } } Rprintf("connected: %i\n",con); Rprintf("strongly non-bipartite: %i\n",stNBipartite); //finally check if \cL is triplet cover of T //adjencency matrix of tree, 1 to n are leaves int *at= (int*)R_alloc((2*n-1)*(2*n-1), sizeof(int)); for(i=1;i<=2*n-2;i++) { for(j=1;j<=2*n-2;j++)at[i*(2*n-1)+j]=0; } for(i=0;i<2*n-3;i++) { //Rprintf("e1[%i]=%i e2[%i]=%i \n",i,e1[i],i,e2[i]); at[e1[i]*(2*n-1)+e2[i]]=at[e2[i]*(2*n-1)+e1[i]]=1; } /*for(i=1;i<2*n-1;i++) { for(j=1;j<2*n-1;j++) { Rprintf("at[%i][%i]=%i ",i,j,at[i*(2*n-1)+j]); } Rprintf("\n"); }*/ for(i=n+1;i<=2*n-2;i++)//for each interior vertex { for(j=1;j<2*n-1;j++)//reset queue and visited veectors { v[j]=-1; q[j]=0; } v[i]=1;//'disconnect' graph at i int *l=(int*)R_alloc(2*n-2, sizeof(int));//vertices adjacent to i int nmb=0;//number of found adjacent vertices of i for(j=1;j<=2*n-2;j++)//find adjacent vertices { if(at[i*(2*n-1)+j]==1) { l[nmb++]=j; } } int** s=(int**)R_alloc(nmb,sizeof(int*));//set of leaves in each side, stored as presence/absence for(j=0;j0?1:0; } Rprintf("is triplet cover? %i \n",tCov); } ape/src/tree_build.c0000644000176200001440000003222114164530562014076 0ustar liggesusers/* tree_build.c 2020-02-12 */ /* Copyright 2008-2020 Emmanuel Paradis, 2017 Klaus Schliep */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include static int str2int(char *x, int n) { int i, k = 1, ans = 0; for (i = n - 1; i >= 0; i--, k *= 10) ans += ((int)x[i] - 48) * k; return ans; } void extract_portion_Newick(const char *x, int a, int b, char *y) { int i, j; for (i = a, j = 0; i <= b; i++, j++) y[j] = x[i]; y[j] = '\0'; } void decode_terminal_edge_token(const char *x, int a, int b, int *node, double *w) { int co = a; char *endstr, str[100]; while (x[co] != ':' && co <= b) co++; extract_portion_Newick(x, a, co - 1, str); *node = str2int(str, co - a); if (co < b) { extract_portion_Newick(x, co + 1, b, str); *w = R_strtod(str, &endstr); } else *w = NAN; } void decode_internal_edge(const char *x, int a, int b, char *lab, double *w) { int co = a; char *endstr, str[100]; while (x[co] != ':' && co <= b) co++; if (a == co) lab[0] = '\0'; /* if no node label */ else extract_portion_Newick(x, a, co - 1, lab); if (co < b) { extract_portion_Newick(x, co + 1, b, str); *w = R_strtod(str, &endstr); } else *w = NAN; } void decode_terminal_edge_token_clado(const char *x, int a, int b, int *node) { char str[100]; // *endstr, extract_portion_Newick(x, a, b, str); *node = str2int(str, b + 1 - a); } void decode_internal_edge_clado(const char *x, int a, int b, char *lab) { // char *endstr, str[100]; if (a > b) lab[0] = '\0'; /* if no node label */ else extract_portion_Newick(x, a, b, lab); } void decode_terminal_edge(const char *x, int a, int b, char *tip, double *w) { int co = a; char *endstr, str[100]; while (x[co] != ':' && co <= b) co++; extract_portion_Newick(x, a, co - 1, tip); if (co < b) { extract_portion_Newick(x, co + 1, b, str); *w = R_strtod(str, &endstr); } else *w = NAN; } void decode_terminal_edge_clado(const char *x, int a, int b, char *tip) { extract_portion_Newick(x, a, b, tip); } #define ADD_INTERNAL_EDGE \ e[j] = curnode; \ e[j + nedge] = curnode = ++node; \ stack_internal[k++] = j; \ j++ #define ADD_TERMINAL_EDGE \ e[j] = curnode; \ decode_terminal_edge_token(x, pr + 1, ps - 1, &tmpi, &tmpd); \ e[j + nedge] = tmpi; \ el[j] = tmpd; \ j++ #define GO_DOWN \ decode_internal_edge(x, ps + 1, pt - 1, lab, &tmpd); \ SET_STRING_ELT(node_label, curnode - 1 - ntip, mkChar(lab)); \ l = stack_internal[--k]; \ el[l] = tmpd; \ curnode = e[l] #define ADD_TERMINAL_EDGE_CLADO \ e[j] = curnode; \ decode_terminal_edge_token_clado(x, pr + 1, ps - 1, &tmpi); \ e[j + nedge] = tmpi; \ j++ #define GO_DOWN_CLADO \ decode_internal_edge_clado(x, ps + 1, pt - 1, lab); \ SET_STRING_ELT(node_label, curnode - 1 - ntip, mkChar(lab)); \ l = stack_internal[--k]; \ curnode = e[l] #define ADD_TERMINAL_EDGE_TIPLABEL \ e[j] = curnode; \ decode_terminal_edge(x, pr + 1, ps - 1, tip, &tmpd); \ SET_STRING_ELT(tip_label, curtip-1, mkChar(tip)); \ e[j + nedge] = curtip; \ el[j] = tmpd; \ curtip++; \ j++ #define ADD_TERMINAL_EDGE_TIPLABEL_CLADO \ e[j] = curnode; \ decode_terminal_edge_clado(x, pr + 1, ps - 1, tip); \ SET_STRING_ELT(tip_label, curtip-1, mkChar(tip)); \ e[j + nedge] = curtip; \ curtip++; \ j++ #define INITIALIZE_SKELETON \ PROTECT(nwk = coerceVector(nwk, STRSXP)); \ x = CHAR(STRING_ELT(nwk, 0)); \ n = strlen(x); \ skeleton = (int *)R_alloc(n, sizeof(int *)); \ for (i = 0; i < n; i++) { \ if (x[i] == '(') { \ skeleton[nsk] = i; \ nsk++; \ nleft++; \ continue; \ } \ if (x[i] == ',') { \ skeleton[nsk] = i; \ nsk++; \ ntip++; \ continue; \ } \ if (x[i] == ')') { \ skeleton[nsk] = i; \ nsk++; \ nright++; \ nnode++; \ } \ } \ if (nleft != nright) error("numbers of left and right parentheses in Newick string not equal\n"); \ nedge = ntip + nnode - 1 /* NOTE: the four functions below use the same algorithm to build a "phylo" object from a Newick string (with/without edge lengths and/or with/without tokens). Only the first one is commented. */ SEXP treeBuildWithTokens(SEXP nwk) { const char *x; int n, i, ntip = 1, nleft = 0, nright = 0, nnode = 0, nedge, *e, curnode, node, j, *skeleton, nsk = 0, ps, pr, pt, tmpi, l, k, stack_internal[10000]; double *el, tmpd; char lab[512]; SEXP edge, edge_length, Nnode, node_label, phy; /* first pass on the Newick string to localize parentheses and commas */ INITIALIZE_SKELETON; PROTECT(Nnode = allocVector(INTSXP, 1)); PROTECT(edge = allocVector(INTSXP, nedge*2)); PROTECT(edge_length = allocVector(REALSXP, nedge)); PROTECT(node_label = allocVector(STRSXP, nnode)); INTEGER(Nnode)[0] = nnode; e = INTEGER(edge); el = REAL(edge_length); curnode = node = ntip + 1; k = j = 0; /* j: index of the current position in the edge matrix */ /* k: index of the current position in stack_internal */ /* stack_internal is a simple array storing the indices of the successive internal edges from the root; it's a stack so it is incremented every time an internal edge is added, and decremented every GO_DOWN step. This makes easy to find the index of the subtending edge. */ /* second pass on the Newick string to build the "phylo" object elements */ for (i = 1; i < nsk - 1; i++) { ps = skeleton[i]; if (x[ps] == '(') { ADD_INTERNAL_EDGE; continue; } pr = skeleton[i - 1]; if (x[ps] == ',') { if (x[pr] != ')') { /* !!! accolades indispensables !!! */ ADD_TERMINAL_EDGE; } continue; } if (x[ps] == ')') { pt = skeleton[i + 1]; // <- utile ??? if (x[pr] == ',') { ADD_TERMINAL_EDGE; GO_DOWN; continue; } /* added by Klaus to allow singleton nodes (2017-05-28): */ if (x[pr] == '(') { ADD_TERMINAL_EDGE; GO_DOWN; continue; } /* end */ if (x[pr] == ')') { GO_DOWN; } } } pr = skeleton[nsk - 2]; ps = skeleton[nsk - 1]; /* is the last edge terminal? */ if (x[pr] == ',' && x[ps] == ')') { ADD_TERMINAL_EDGE; } /* is there a root edge and/or root label? */ if (ps < n - 2) { i = ps + 1; while (i < n - 2 && x[i] != ':') i++; if (i < n - 2) { PROTECT(phy = allocVector(VECSXP, 5)); SEXP root_edge; decode_internal_edge(x, ps + 1, n - 2, lab, &tmpd); PROTECT(root_edge = allocVector(REALSXP, 1)); REAL(root_edge)[0] = tmpd; SET_VECTOR_ELT(phy, 4, root_edge); UNPROTECT(1); SET_STRING_ELT(node_label, 0, mkChar(lab)); } else { extract_portion_Newick(x, ps + 1, n - 2, lab); SET_STRING_ELT(node_label, 0, mkChar(lab)); PROTECT(phy = allocVector(VECSXP, 4)); } } else PROTECT(phy = allocVector(VECSXP, 4)); SET_VECTOR_ELT(phy, 0, edge); SET_VECTOR_ELT(phy, 1, edge_length); SET_VECTOR_ELT(phy, 2, Nnode); SET_VECTOR_ELT(phy, 3, node_label); UNPROTECT(6); return phy; } SEXP cladoBuildWithTokens(SEXP nwk) { const char *x; int n, i, ntip = 1, nleft = 0, nright = 0, nnode = 0, nedge, *e, curnode, node, j, *skeleton, nsk = 0, ps, pr, pt, tmpi, l, k, stack_internal[10000]; char lab[512]; SEXP edge, Nnode, node_label, phy; INITIALIZE_SKELETON; PROTECT(Nnode = allocVector(INTSXP, 1)); PROTECT(edge = allocVector(INTSXP, nedge*2)); PROTECT(node_label = allocVector(STRSXP, nnode)); INTEGER(Nnode)[0] = nnode; e = INTEGER(edge); curnode = node = ntip + 1; k = j = 0; for (i = 1; i < nsk - 1; i++) { ps = skeleton[i]; if (x[ps] == '(') { ADD_INTERNAL_EDGE; continue; } pr = skeleton[i - 1]; if (x[ps] == ',') { if (x[pr] != ')') { ADD_TERMINAL_EDGE_CLADO; } continue; } if (x[ps] == ')') { pt = skeleton[i + 1]; if (x[pr] == ',') { ADD_TERMINAL_EDGE_CLADO; GO_DOWN_CLADO; continue; } if (x[pr] == '(') { ADD_TERMINAL_EDGE_CLADO; GO_DOWN_CLADO; continue; } if (x[pr] == ')') { GO_DOWN_CLADO; } } } pr = skeleton[nsk - 2]; ps = skeleton[nsk - 1]; if (x[pr] == ',' && x[ps] == ')') { ADD_TERMINAL_EDGE_CLADO; } if (ps < n - 2) { extract_portion_Newick(x, ps + 1, n - 2, lab); SET_STRING_ELT(node_label, 0, mkChar(lab)); PROTECT(phy = allocVector(VECSXP, 3)); } else PROTECT(phy = allocVector(VECSXP, 3)); SET_VECTOR_ELT(phy, 0, edge); SET_VECTOR_ELT(phy, 1, Nnode); SET_VECTOR_ELT(phy, 2, node_label); UNPROTECT(5); return phy; } SEXP treeBuild(SEXP nwk) { const char *x; int n, i, ntip = 1, nleft = 0, nright = 0, nnode = 0, nedge, *e, curnode, node, j, *skeleton, nsk = 0, ps, pr, pt, l, k, stack_internal[10000], curtip = 1; double *el, tmpd; char lab[512], tip[512]; SEXP edge, edge_length, Nnode, node_label, tip_label, phy; INITIALIZE_SKELETON; PROTECT(Nnode = allocVector(INTSXP, 1)); PROTECT(edge = allocVector(INTSXP, nedge*2)); PROTECT(edge_length = allocVector(REALSXP, nedge)); PROTECT(node_label = allocVector(STRSXP, nnode)); PROTECT(tip_label = allocVector(STRSXP, ntip)); INTEGER(Nnode)[0] = nnode; e = INTEGER(edge); el = REAL(edge_length); curnode = node = ntip + 1; k = j = 0; for (i = 1; i < nsk - 1; i++) { ps = skeleton[i]; if (x[ps] == '(') { ADD_INTERNAL_EDGE; continue; } pr = skeleton[i - 1]; if (x[ps] == ',') { if (x[pr] != ')') { ADD_TERMINAL_EDGE_TIPLABEL; } continue; } if (x[ps] == ')') { pt = skeleton[i + 1]; if (x[pr] == ',') { ADD_TERMINAL_EDGE_TIPLABEL; GO_DOWN; continue; } if (x[pr] == '(') { ADD_TERMINAL_EDGE_TIPLABEL; GO_DOWN; continue; } if (x[pr] == ')') { GO_DOWN; } } } pr = skeleton[nsk - 2]; ps = skeleton[nsk - 1]; if (x[pr] == ',' && x[ps] == ')') { ADD_TERMINAL_EDGE_TIPLABEL; } if (ps < n - 2) { i = ps + 1; while (i < n - 2 && x[i] != ':') i++; if (i < n - 2) { PROTECT(phy = allocVector(VECSXP, 6)); SEXP root_edge; decode_internal_edge(x, ps + 1, n - 2, lab, &tmpd); PROTECT(root_edge = allocVector(REALSXP, 1)); REAL(root_edge)[0] = tmpd; SET_VECTOR_ELT(phy, 5, root_edge); UNPROTECT(1); SET_STRING_ELT(node_label, 0, mkChar(lab)); } else { extract_portion_Newick(x, ps + 1, n - 2, lab); SET_STRING_ELT(node_label, 0, mkChar(lab)); PROTECT(phy = allocVector(VECSXP, 5)); } } else PROTECT(phy = allocVector(VECSXP, 5)); SET_VECTOR_ELT(phy, 0, edge); SET_VECTOR_ELT(phy, 1, edge_length); SET_VECTOR_ELT(phy, 2, Nnode); SET_VECTOR_ELT(phy, 3, node_label); SET_VECTOR_ELT(phy, 4, tip_label); UNPROTECT(7); return phy; } SEXP cladoBuild(SEXP nwk) { const char *x; int n, i, ntip = 1, nleft = 0, nright = 0, nnode = 0, nedge, *e, curnode, node, j, *skeleton, nsk = 0, ps, pr, pt, l, k, stack_internal[10000], curtip = 1; char lab[512], tip[512]; SEXP edge, Nnode, node_label, tip_label, phy; INITIALIZE_SKELETON; PROTECT(Nnode = allocVector(INTSXP, 1)); PROTECT(edge = allocVector(INTSXP, nedge*2)); PROTECT(node_label = allocVector(STRSXP, nnode)); PROTECT(tip_label = allocVector(STRSXP, ntip)); INTEGER(Nnode)[0] = nnode; e = INTEGER(edge); curnode = node = ntip + 1; k = j = 0; for (i = 1; i < nsk - 1; i++) { ps = skeleton[i]; if (x[ps] == '(') { ADD_INTERNAL_EDGE; continue; } pr = skeleton[i - 1]; if (x[ps] == ',') { if (x[pr] != ')') { ADD_TERMINAL_EDGE_TIPLABEL_CLADO; } continue; } if (x[ps] == ')') { pt = skeleton[i + 1]; if (x[pr] == ',') { ADD_TERMINAL_EDGE_TIPLABEL_CLADO; GO_DOWN_CLADO; continue; } if (x[pr] == '(') { ADD_TERMINAL_EDGE_TIPLABEL_CLADO; GO_DOWN_CLADO; continue; } if (x[pr] == ')') { GO_DOWN_CLADO; } } } pr = skeleton[nsk - 2]; ps = skeleton[nsk - 1]; if (x[pr] == ',' && x[ps] == ')') { ADD_TERMINAL_EDGE_TIPLABEL_CLADO; } if (ps < n - 2) { extract_portion_Newick(x, ps + 1, n - 2, lab); SET_STRING_ELT(node_label, 0, mkChar(lab)); PROTECT(phy = allocVector(VECSXP, 4)); } else PROTECT(phy = allocVector(VECSXP, 4)); SET_VECTOR_ELT(phy, 0, edge); SET_VECTOR_ELT(phy, 1, Nnode); SET_VECTOR_ELT(phy, 2, node_label); SET_VECTOR_ELT(phy, 3, tip_label); UNPROTECT(6); return phy; } #undef ADD_INTERNAL_EDGE #undef ADD_TERMINAL_EDGE #undef ADD_TERMINAL_EDGE_CLADO #undef ADD_TERMINAL_EDGE_TIPLABEL #undef ADD_TERMINAL_EDGE_TIPLABEL_CLADO #undef GO_DOWN #undef GO_DOWN_CLADO ape/src/treePop.c0000644000176200001440000000716414164530562013406 0ustar liggesusers/* treePop.c 2013-09-19 */ /* Copyright 2011-2013 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include #include int lsb(uint8_t * a) { int i = 0; while (a[i] == 0) i++; /* count number of elements = 0 */ int b = 7; while ((a[i] & (1 << b)) == 0) b--; return i*8 + (8 - b); } short count_bits(uint8_t n) { short c; /* c accumulates the total bits set in v */ for (c = 0; n; c++) n &= n - 1; /* clear the least significant bit set */ return c; } uint8_t* setdiff(uint8_t* x, uint8_t *y, int nrow) //x-y { int i = 0; uint8_t* ret = (uint8_t*)R_alloc(nrow, sizeof(uint8_t)); for (i = 0; i < nrow; i++) { uint8_t tmp = (~y[i]); ret[i] = (x[i] & tmp); } return ret; } void C_treePop(int* splits, double* w,int* ncolp,int* np, int* ed1, int* ed2, double* edLen) { int n=*np; int ncol=*ncolp; int nrow=ceil(n/(double)8); uint8_t split[nrow][ncol]; int i=0,j=0; for(i=0;in/2) { for(j=0;j=2)//if not trivial split {nNodes++; gn=nNodes; } else { gn=lsb(sp); } ed2[numEdges]=gn; edLen[numEdges]=w[ind[i]]; numEdges++; uint8_t* sdd=setdiff(vl,sp,nrow); for(ii=0;ii 3) { ij = 0; for(i=1;i smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; /* smallest = ij; */ } ij++; } } } if(s[give_index(OTU1,OTU2,n)]<=2) {error("distance information insufficient to construct a tree, leaves %i and %i isolated from tree",OTU1,OTU2); } //update R and S, only if matrix still incomplete if(sw==1) for(i=1;i 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; n--; for (i = 0; i < n*(n - 1)/2; i++) { D[i] = new_dist[i]; v[i] = new_v[i]; if(sw==1) { R[i] = newR[i]; s[i] = newS[i]; } } cur_nod--; k = k + 2; } int dK=0;//number of known distances in final distance matrix int iUK=-1;//index of unkown distance, if we have one missing distance int iK=-1;//index of only known distance, only needed if dK==1 for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; if(D[i]!=-1){dK++;iK=i;}else{iUK=i;} } if(dK==2) {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown //and edge weights of three edges are a,b,c, then any b,c>0 that //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for //simplicity we assume a=c if d(yz)max)max=D[i]; } D[iUK]=max; } if(dK==1) {//through similar motivation as above, if we have just one known distance //we set the other two distances equal to it for(i=0;i<3;i++) {if(i==iK)continue; D[i]=D[iK]; } } if(dK==0) {//no distances are known, we just set them to 1 for(i=0;i<3;i++) {D[i]=1; } } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/dist_dna.c0000644000176200001440000015444714164530562013564 0ustar liggesusers/* dist_dna.c 2020-08-18 */ /* Copyright 2005-2020 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include "ape.h" /* from R: print(log(4), d = 22) */ #define LN4 1.386294361119890572454 /* returns 8 if the base is known surely, 0 otherwise */ #define KnownBase(a) (a & 8) /* returns 1 if the base is adenine surely, 0 otherwise */ #define IsAdenine(a) (a == 136) /* returns 1 if the base is guanine surely, 0 otherwise */ #define IsGuanine(a) (a == 72) /* returns 1 if the base is cytosine surely, 0 otherwise */ #define IsCytosine(a) (a == 40) /* returns 1 if the base is thymine surely, 0 otherwise */ #define IsThymine(a) (a == 24) /* returns 1 if the base is a purine surely, 0 otherwise */ #define IsPurine(a) (a > 63) /* returns 1 if the base is a pyrimidine surely, 0 otherwise */ #define IsPyrimidine(a) (a < 64) /* returns 1 if both bases are different surely, 0 otherwise */ #define DifferentBase(a, b) ((a & b) < 16) /* returns 1 if both bases are the same surely, 0 otherwise */ #define SameBase(a, b) (KnownBase(a) && a == b) /* computes directly the determinant of a 4x4 matrix */ double detFourByFour(double *x) { double det, a33a44, a34a43, a34a42, a32a44, a32a43, a33a42, a34a41, a31a44, a31a43, a33a41, a31a42, a32a41; a33a44 = x[10]*x[15]; a34a43 = x[14]*x[11]; a34a42 = x[14]*x[7]; a32a44 = x[6]*x[15]; a32a43 = x[6]*x[11]; a33a42 = x[10]*x[7]; a34a41 = x[14]*x[3]; a31a44 = x[2]*x[15]; a31a43 = x[2]*x[11]; a33a41 = x[10]*x[3]; a31a42 = x[2]*x[7]; a32a41 = x[6]*x[3]; det = x[0]*x[5]*(a33a44 - a34a43) + x[0]*x[9]*(a34a42 - a32a44) + x[0]*x[13]*(a32a43 - a33a42) + x[4]*x[9]*(a31a44 - a34a41) + x[4]*x[13]*(a33a41 - a31a43) + x[4]*x[1]*(a34a43 - a33a44) + x[8]*x[13]*(a31a42 - a32a41) + x[8]*x[1]*(a32a44 - a34a42) + x[8]*x[5]*(a34a41 - a31a44) + x[12]*x[1]*(a33a42 - a32a43) + x[12]*x[5]*(a31a43 - a33a41) + x[12]*x[9]*(a32a41 - a31a42); return det; } #define CHECK_PAIRWISE_DELETION\ if (KnownBase(x[s1]) && KnownBase(x[s2])) L++;\ else continue; #define COUNT_TS_TV\ if (SameBase(x[s1], x[s2])) continue;\ Nd++;\ if (IsPurine(x[s1]) && IsPurine(x[s2])) {\ Ns++;\ continue;\ }\ if (IsPyrimidine(x[s1]) && IsPyrimidine(x[s2])) Ns++; void distDNA_indel(unsigned char *x, int n, int s, double *d) { int i1, i2, s1, s2, target, N; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { N = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n * (s - 1); s1 += n, s2 += n) if ((x[s1] ^ x[s2]) & 4) N++; d[target] = ((double) N); target++; } } } void DNAbin2indelblock(unsigned char *x, int *n, int *s, int *y) { int i, j, k, pos, ngap, indel = 0; for (i = 0; i < *n; i++) { j = i; k = 0; while (k < *s) { if (x[j] == 4) { if (!indel) { pos = j; indel = 1; ngap = 1; } else ngap++; } else { if (indel) { y[pos] = ngap; indel = 0; } } j += *n; k++; } if (indel) { y[pos] = ngap; indel = 0; } } } void distDNA_indelblock(unsigned char *x, int n, int s, double *d) { int *y, i1, i2, s1, s2, target, Nd; y = (int*)R_alloc(n * s, sizeof(int)); memset(y, 0, n * s * sizeof(int)); DNAbin2indelblock(x, &n, &s, y); target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n * (s - 1); s1 += n, s2 += n) if (y[s1] != y[s2]) Nd++; d[target] = ((double) Nd); target++; } } } void distDNA_TsTv(unsigned char *x, int n, int s, double *d, int Ts, int pairdel) { int i1, i2, s1, s2, target, Nd, Ns; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { if (pairdel && !(KnownBase(x[s1]) && KnownBase(x[s2]))) continue; COUNT_TS_TV } if (Ts) d[target] = ((double) Ns); /* output number of transitions */ else d[target] = ((double) Nd - Ns); /* output number of transversions */ target++; } } } void distDNA_raw(unsigned char *x, int n, int s, double *d, int scaled) { int i1, i2, s1, s2, target, Nd; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n * (s - 1); s1 += n, s2 += n) if (DifferentBase(x[s1], x[s2])) Nd++; if (scaled) d[target] = ((double) Nd / s); else d[target] = ((double) Nd); target++; } } } void distDNA_raw_pairdel(unsigned char *x, int n, int s, double *d, int scaled) { int i1, i2, s1, s2, target, Nd, L; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n * (s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION if (DifferentBase(x[s1], x[s2])) Nd++; } if (scaled) d[target] = ((double) Nd/L); else d[target] = ((double) Nd); target++; } } } #define COMPUTE_DIST_JC69\ p = ((double) Nd/L);\ if (gamma)\ d[target] = 0.75 * alpha * (pow(1 - 4*p/3, -1/alpha) - 1);\ else d[target] = -0.75 * log(1 - 4*p/3);\ if (variance) {\ if (gamma) var[target] = p*(1 - p)/(pow(1 - 4*p/3, -2/(alpha + 1)) * L);\ else var[target] = p*(1 - p)/(pow(1 - 4*p/3, 2)*L);\ } void distDNA_JC69(unsigned char *x, int n, int s, double *d, int variance, double *var, int gamma, double alpha) { int i1, i2, s1, s2, target, Nd, L; double p; L = s; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n * (s - 1); s1 += n, s2 += n) if (DifferentBase(x[s1], x[s2])) Nd++; COMPUTE_DIST_JC69 target++; } } } void distDNA_JC69_pairdel(unsigned char *x, int n, int s, double *d, int variance, double *var, int gamma, double alpha) { int i1, i2, s1, s2, target, Nd, L; double p; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1+= n, s2 += n) { CHECK_PAIRWISE_DELETION if (DifferentBase(x[s1], x[s2])) Nd++; } COMPUTE_DIST_JC69 target++; } } } #define COMPUTE_DIST_K80\ P = ((double) Ns/L);\ Q = ((double) (Nd - Ns)/L);\ a1 = 1 - 2*P - Q;\ a2 = 1 - 2*Q;\ if (gamma) {\ b = -1 / alpha;\ d[target] = alpha * (pow(a1, b) + 0.5*pow(a2, b) - 1.5)/2;\ }\ else d[target] = -0.5 * log(a1 * sqrt(a2));\ if (variance) {\ if (gamma) {\ b = -(1 / alpha + 1);\ c1 = pow(a1, b);\ c2 = pow(a2, b);\ c3 = (c1 + c2)/2;\ } else {\ c1 = 1/a1;\ c2 = 1/a2;\ c3 = (c1 + c2)/2;\ }\ var[target] = (c1*c1*P + c3*c3*Q - pow(c1*P + c3*Q, 2))/L;\ } void distDNA_K80(unsigned char *x, int n, int s, double *d, int variance, double *var, int gamma, double alpha) { int i1, i2, s1, s2, target, Nd, Ns, L; double P, Q, a1, a2, b, c1, c2, c3; L = s; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1+= n, s2 += n) { COUNT_TS_TV } COMPUTE_DIST_K80 target++; } } } void distDNA_K80_pairdel(unsigned char *x, int n, int s, double *d, int variance, double *var, int gamma, double alpha) { int i1, i2, s1, s2, target, Nd, Ns, L; double P, Q, a1, a2, b, c1, c2, c3; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION COUNT_TS_TV } COMPUTE_DIST_K80 target++; } } } #define COMPUTE_DIST_F81\ p = ((double) Nd/L);\ if (gamma) d[target] = E * alpha * (pow(1 - p/E, -1/ alpha) - 1);\ else d[target] = -E*log(1 - p/E);\ if (variance) {\ if (gamma) var[target] = p*(1 - p)/(pow(1 - p/E, -2/(alpha + 1)) * L);\ else var[target] = p*(1 - p)/(pow(1 - p/E, 2)*L);\ } void distDNA_F81(unsigned char *x, int n, int s, double *d, double *BF, int variance, double *var, int gamma, double alpha) { int i1, i2, s1, s2, target, Nd, L; double p, E; L = s; E = 1 - BF[0]*BF[0] - BF[1]*BF[1] - BF[2]*BF[2] - BF[3]*BF[3]; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1+= n, s2 += n) if (DifferentBase(x[s1], x[s2])) Nd++; COMPUTE_DIST_F81 target++; } } } void distDNA_F81_pairdel(unsigned char *x, int n, int s, double *d, double *BF, int variance, double *var, int gamma, double alpha) { int i1, i2, s1, s2, target, Nd, L; double p, E; E = 1 - BF[0]*BF[0] - BF[1]*BF[1] - BF[2]*BF[2] - BF[3]*BF[3]; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION if (DifferentBase(x[s1], x[s2])) Nd++; } COMPUTE_DIST_F81 target++; } } } #define COUNT_TS_TV1_TV2\ if (SameBase(x[s1], x[s2])) continue;\ Nd++;\ if ((x[s1] | x[s2]) == 152 || (x[s1] | x[s2]) == 104) {\ Nv1++;\ continue;\ }\ if ((x[s1] | x[s2]) == 168 || (x[s1] | x[s2]) == 88) Nv2++; #define COMPUTE_DIST_K81\ P = ((double) (Nd - Nv1 - Nv2)/L);\ Q = ((double) Nv1/L);\ R = ((double) Nv2/L);\ a1 = 1 - 2*P - 2*Q;\ a2 = 1 - 2*P - 2*R;\ a3 = 1 - 2*Q - 2*R;\ d[target] = -0.25*log(a1*a2*a3);\ if (variance) {\ a = (1/a1 + 1/a2)/2;\ b = (1/a1 + 1/a3)/2;\ c = (1/a2 + 1/a3)/2;\ var[target] = (a*a*P + b*b*Q + c*c*R - pow(a*P + b*Q + c*R, 2))/2;\ } void distDNA_K81(unsigned char *x, int n, int s, double *d, int variance, double *var) { int i1, i2, Nd, Nv1, Nv2, L, s1, s2, target; double P, Q, R, a1, a2, a3, a, b, c; L = s; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Nv1 = Nv2 = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { COUNT_TS_TV1_TV2 } COMPUTE_DIST_K81 target++; } } } void distDNA_K81_pairdel(unsigned char *x, int n, int s, double *d, int variance, double *var) { int i1, i2, Nd, Nv1, Nv2, L, s1, s2, target; double P, Q, R, a1, a2, a3, a, b, c; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Nv1 = Nv2 = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION COUNT_TS_TV1_TV2 } COMPUTE_DIST_K81 target++; } } } #define PREPARE_BF_F84\ A = (BF[0]*BF[2])/(BF[0] + BF[2]) + (BF[1]*BF[3])/(BF[1] + BF[3]);\ B = BF[0]*BF[2] + BF[1]*BF[3];\ C = (BF[0] + BF[2])*(BF[1] + BF[3]); #define COMPUTE_DIST_F84\ P = ((double) Ns/L);\ Q = ((double) (Nd - Ns)/L);\ d[target] = -2*A*log(1 - P/(2*A) - (A - B)*Q/(2*A*C)) + 2*(A - B - C)*log(1 - Q/(2*C));\ if (variance) {\ t1 = A*C;\ t2 = C*P/2;\ t3 = (A - B)*Q/2;\ a = t1/(t1 - t2 - t3);\ b = A*(A - B)/(t1 - t2 - t3) - (A - B - C)/(C - Q/2);\ var[target] = (a*a*P + b*b*Q - pow(a*P + b*Q, 2))/L;\ } void distDNA_F84(unsigned char *x, int n, int s, double *d, double *BF, int variance, double *var) { int i1, i2, Nd, Ns, L, target, s1, s2; double P, Q, A, B, C, a, b, t1, t2, t3; PREPARE_BF_F84 L = s; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { COUNT_TS_TV } COMPUTE_DIST_F84 target++; } } } void distDNA_F84_pairdel(unsigned char *x, int n, int s, double *d, double *BF, int variance, double *var) { int i1, i2, Nd, Ns, L, target, s1, s2; double P, Q, A, B, C, a, b, t1, t2, t3; PREPARE_BF_F84 target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION COUNT_TS_TV } COMPUTE_DIST_F84 target++; } } } #define COMPUTE_DIST_T92\ P = ((double) Ns/L);\ Q = ((double) (Nd - Ns)/L);\ a1 = 1 - P/wg - Q;\ a2 = 1 - 2*Q;\ d[target] = -wg*log(a1) - 0.5*(1 - wg)*log(a2);\ if (variance) {\ c1 = 1/a1;\ c2 = 1/a2;\ c3 = wg*(c1 - c2) + c2;\ var[target] = (c1*c1*P + c3*c3*Q - pow(c1*P + c3*Q, 2))/L;\ } void distDNA_T92(unsigned char *x, int n, int s, double *d, double *BF, int variance, double *var) { int i1, i2, Nd, Ns, L, target, s1, s2; double P, Q, wg, a1, a2, c1, c2, c3; L = s; wg = 2 * (BF[1] + BF[2]) * (1 - (BF[1] + BF[2])); target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { COUNT_TS_TV } COMPUTE_DIST_T92 target++; } } } void distDNA_T92_pairdel(unsigned char *x, int n, int s, double *d, double *BF, int variance, double *var) { int i1, i2, Nd, Ns, L, target, s1, s2; double P, Q, wg, a1, a2, c1, c2, c3; wg = 2 * (BF[1] + BF[2]) * (1 - (BF[1] + BF[2])); target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION COUNT_TS_TV } COMPUTE_DIST_T92 target++; } } } /* returns 1 if one of the base is adenine and the other one is guanine surely, 0 otherwise */ #define AdenineAndGuanine(a, b) (a | b) == 200 /* returns 1 if one of the base is cytosine and the other one is thymine surely, 0 otherwise */ #define CytosineAndThymine(a, b) (a | b) == 56 #define PREPARE_BF_TN93\ gR = BF[0] + BF[2];\ gY = BF[1] + BF[3];\ k1 = 2 * BF[0] * BF[2] / gR;\ k2 = 2 * BF[1] * BF[3] / gY;\ k3 = 2 * (gR * gY - BF[0]*BF[2]*gY/gR - BF[1]*BF[3]*gR/gY); #define COUNT_TS1_TS2_TV\ if (DifferentBase(x[s1], x[s2])) {\ Nd++;\ if (AdenineAndGuanine(x[s1], x[s2])) {\ Ns1++;\ continue;\ }\ if (CytosineAndThymine(x[s1], x[s2])) Ns2++;\ } #define COMPUTE_DIST_TN93\ P1 = ((double) Ns1/L);\ P2 = ((double) Ns2/L);\ Q = ((double) (Nd - Ns1 - Ns2)/L);\ w1 = 1 - P1/k1 - Q/(2*gR);\ w2 = 1 - P2/k2 - Q/(2*gY);\ w3 = 1 - Q/(2*gR*gY);\ if (gamma) {\ k4 = 2*(BF[0]*BF[2] + BF[1]*BF[3] + gR*gY);\ b = -1 / alpha;\ c1 = pow(w1, b);\ c2 = pow(w2, b);\ c3 = pow(w3, b);\ c4 = k1*c1/(2*gR) + k2*c2/(2*gY) + k3*c3/(2*gR*gY);\ d[target] = alpha * (k1*pow(w1, b) + k2*pow(w2, b) + k3*pow(w3, b) - k4);\ } else {\ k4 = 2*((BF[0]*BF[0] + BF[2]*BF[2])/(2*gR*gR) + (BF[2]*BF[2] + BF[3]*BF[3])/(2*gY*gY));\ c1 = 1/w1;\ c2 = 1/w2;\ c3 = 1/w3;\ c4 = k1 * c1/(2 * gR) + k2 * c2/(2 * gY) + k4 * c3;\ d[target] = -k1*log(w1) - k2*log(w2) - k3*log(w3);\ }\ if (variance)\ var[target] = (c1*c1*P1 + c2*c2*P2 + c4*c4*Q - pow(c1*P1 + c2*P2 + c4*Q, 2))/L; void distDNA_TN93(unsigned char *x, int n, int s, double *d, double *BF, int variance, double *var, int gamma, double alpha) { int i1, i2, Nd, Ns1, Ns2, L, target, s1, s2; double P1, P2, Q, gR, gY, k1, k2, k3, k4, w1, w2, w3, c1, c2, c3, c4, b; L = s; PREPARE_BF_TN93 target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns1 = Ns2 = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { COUNT_TS1_TS2_TV } COMPUTE_DIST_TN93 target++; } } } void distDNA_TN93_pairdel(unsigned char *x, int n, int s, double *d, double *BF, int variance, double *var, int gamma, double alpha) { int i1, i2, Nd, Ns1, Ns2, L, target, s1, s2; double P1, P2, Q, gR, gY, k1, k2, k3, k4, w1, w2, w3, c1, c2, c3, c4, b; PREPARE_BF_TN93 target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns1 = Ns2 = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION COUNT_TS1_TS2_TV } COMPUTE_DIST_TN93 target++; } } } void distDNA_GG95(unsigned char *x, int n, int s, double *d, int variance, double *var) { int i1, i2, s1, s2, target, GC, Nd, Ns, tl, npair; double *theta, gcprop, *P, pp, *Q, qq, *tstvr, svr, A, sum, ma /* mean alpha */, K1, K2; theta = &gcprop; P = &pp; Q = &qq; tstvr = &svr; npair = n * (n - 1) / 2; theta = (double*)R_alloc(n, sizeof(double)); P = (double*)R_alloc(npair, sizeof(double)); Q = (double*)R_alloc(npair, sizeof(double)); tstvr = (double*)R_alloc(npair, sizeof(double)); /* get the proportion of GC (= theta) in each sequence */ for (i1 = 1; i1 <= n; i1++) { GC = 0; for (s1 = i1 - 1; s1 < i1 + n*(s - 1); s1 += n) if (IsCytosine(x[s1]) || IsGuanine(x[s1])) GC += 1; theta[i1 - 1] = ((double) GC / s); } /* get the proportions of transitions and transversions, and the estimates of their ratio for each pair */ target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { COUNT_TS_TV } P[target] = ((double) Ns / s); Q[target] = ((double) (Nd - Ns) / s); A = log(1 - 2*Q[target]); tstvr[target] = 2*(log(1 - 2*P[target] - Q[target]) - 0.5*A)/A; target++; } } /* compute the mean alpha (ma) = mean Ts/Tv */ sum = 0; tl = 0; for (i1 = 0; i1 < npair; i1++) /* some values of tstvr are -Inf if there is no transversions observed: we exclude them */ if (R_FINITE(tstvr[i1])) { sum += tstvr[i1]; tl += 1; } ma = sum/tl; /* compute the distance for each pair */ target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { A = 1 - 2*Q[target]; K1 = 1 + ma*(theta[i1 - 1]*(1 - theta[i1 - 1]) + theta[i2 - 1]*(1 - theta[i2 - 1])); K2 = ma*pow(theta[i1 - 1] - theta[i2 - 1], 2)/(ma + 1); d[target] = -0.5*K1*log(A) + K2*(1 - pow(A, 0.25*(ma + 1))); if (variance) var[target] = pow(K1 + K2*0.5*(ma + 1)*pow(A, 0.25*(ma + 1)), 2)*Q[target]*(1 - Q[target])/(A*A * s); target++; } } } void distDNA_GG95_pairdel(unsigned char *x, int n, int s, double *d, int variance, double *var) { int i1, i2, s1, s2, target, *L, length, GC, Nd, Ns, tl, npair; double *theta, gcprop, *P, pp, *Q, qq, *tstvr, svr, A, sum, ma /* mean alpha */, K1, K2; theta = &gcprop; L = &length; P = &pp; Q = &qq; tstvr = &svr; npair = n * (n - 1) / 2; theta = (double*)R_alloc(n, sizeof(double)); L = (int*)R_alloc(npair, sizeof(int)); P = (double*)R_alloc(npair, sizeof(double)); Q = (double*)R_alloc(npair, sizeof(double)); tstvr = (double*)R_alloc(npair, sizeof(double)); /* get the proportion of GC (= theta) in each sequence */ for (i1 = 1; i1 <= n; i1++) { tl = GC = 0; for (s1 = i1 - 1; s1 < i1 + n*(s - 1); s1 += n) { if (KnownBase(x[s1])) tl++; else continue; if (IsCytosine(x[s1]) || IsGuanine(x[s1])) GC += 1; } theta[i1 - 1] = ((double) GC / tl); } /* get the proportions of transitions and transversions, and the estimates of their ratio for each pair; we also get the sample size for each pair in L */ target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { Nd = Ns = L[target] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { if (KnownBase(x[s1]) && KnownBase(x[s2])) L[target]++; else continue; COUNT_TS_TV } P[target] = ((double) Ns/L[target]); Q[target] = ((double) (Nd - Ns)/L[target]); A = log(1 - 2*Q[target]); tstvr[target] = 2*(log(1 - 2*P[target] - Q[target]) - 0.5*A)/A; target++; } } /* compute the mean alpha (ma) = mean Ts/Tv */ sum = 0; tl = 0; for (i1 = 0; i1 < npair; i1++) /* some values of tstvr are -Inf if there is no transversions observed: we exclude them */ if (R_FINITE(tstvr[i1])) { sum += tstvr[i1]; tl += 1; } ma = sum/tl; /* compute the distance for each pair */ target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { A = 1 - 2*Q[target]; K1 = 1 + ma*(theta[i1 - 1]*(1 - theta[i1 - 1]) + theta[i2 - 1]*(1 - theta[i2 - 1])); K2 = ma*pow(theta[i1 - 1] - theta[i2 - 1], 2)/(ma + 1); d[target] = -0.5*K1*log(A) + K2*(1 - pow(A, 0.25*(ma + 1))); if (variance) var[target] = pow(K1 + K2*0.5*(ma + 1)*pow(A, 0.25*(ma + 1)), 2)*Q[target]*(1 - Q[target])/(A*A*L[target]); target++; } } } #define DO_CONTINGENCY_NUCLEOTIDES\ switch (x[s1]) {\ case 136 : m = 0; break;\ case 72 : m = 1; break;\ case 40 : m = 2; break;\ case 24 : m = 3; break;\ }\ switch (x[s2]) {\ case 72 : m += 4; break;\ case 40 : m += 8; break;\ case 24 : m += 12; break;\ }\ Ntab[m]++; #define COMPUTE_DIST_LogDet\ for (k = 0; k < 16; k++) Ftab[k] = ((double) Ntab[k]/L);\ d[target] = -log(detFourByFour(Ftab))/4 - LN4;\ if (variance) {\ /* For the inversion, we first make U an identity matrix */\ for (k = 1; k < 15; k++) U[k] = 0;\ U[0] = U[5] = U[10] = U[15] = 1;\ /* The matrix is not symmetric, so we use 'dgesv'. */\ /* This subroutine puts the result in U. */\ F77_CALL(dgesv)(&ndim, &ndim, Ftab, &ndim, ipiv, U, &ndim, &info);\ var[target] = (U[0]*U[0]*Ftab[0] + U[1]*U[1]*Ftab[4] +\ U[2]*U[2]*Ftab[8] + U[3]*U[3]*Ftab[12] +\ U[4]*U[4]*Ftab[1] + U[5]*U[5]*Ftab[5] +\ U[6]*U[6]*Ftab[9] + U[7]*U[7]*Ftab[13] +\ U[8]*U[8]*Ftab[2] + U[9]*U[9]*Ftab[6] +\ U[10]*U[10]*Ftab[10] + U[11]*U[11]*Ftab[14] +\ U[12]*U[12]*Ftab[3] + U[13]*U[13]*Ftab[7] +\ U[14]*U[14]*Ftab[11] + U[15]*U[15]*Ftab[15] - 16)/(L*16);\ } void distDNA_LogDet(unsigned char *x, int n, int s, double *d, int variance, double *var) { int i1, i2, k, m, s1, s2, target, L, Ntab[16], ndim = 4, info, ipiv[16]; double Ftab[16], U[16]; L = s; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { for (k = 0; k < 16; k++) Ntab[k] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { DO_CONTINGENCY_NUCLEOTIDES } COMPUTE_DIST_LogDet target++; } } } void distDNA_LogDet_pairdel(unsigned char *x, int n, int s, double *d, int variance, double *var) { int i1, i2, k, m, s1, s2, target, L, Ntab[16], ndim = 4, info, ipiv[16]; double Ftab[16], U[16]; target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { for (k = 0; k < 16; k++) Ntab[k] = 0; L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION DO_CONTINGENCY_NUCLEOTIDES } COMPUTE_DIST_LogDet target++; } } } void distDNA_BH87(unsigned char *x, int n, int s, double *d) /* For the moment there is no need to check for pairwise deletions since DO_CONTINGENCY_NUCLEOTIDES considers only the known nucleotides. In effect the pairwise deletion has possibly been done before. The sequence length(s) are used only to compute the variances, which is currently not available. */ { int i1, i2, k, kb, s1, s2, m, Ntab[16], ROWsums[4]; double P12[16], P21[16]; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { for (k = 0; k < 16; k++) Ntab[k] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { DO_CONTINGENCY_NUCLEOTIDES } /* get the rowwise sums of Ntab */ ROWsums[0] = Ntab[0] + Ntab[4] + Ntab[8] + Ntab[12]; ROWsums[1] = Ntab[1] + Ntab[5] + Ntab[9] + Ntab[13]; ROWsums[2] = Ntab[2] + Ntab[6] + Ntab[10] + Ntab[14]; ROWsums[3] = Ntab[3] + Ntab[7] + Ntab[11] + Ntab[15]; for (k = 0; k < 16; k++) P12[k] = ((double) Ntab[k]); /* scale each element of P12 by its rowwise sum */ for (k = 0; k < 4; k++) for (kb = 0; kb < 16; kb += 4) P12[k + kb] = P12[k + kb]/ROWsums[k]; d[n*(i2 - 1) + i1 - 1] = -log(detFourByFour(P12))/4; /* compute the columnwise sums of Ntab: these are the rowwise sums of its transpose */ ROWsums[0] = Ntab[0] + Ntab[1] + Ntab[2] + Ntab[3]; ROWsums[1] = Ntab[4] + Ntab[5] + Ntab[6] + Ntab[7]; ROWsums[2] = Ntab[8] + Ntab[9] + Ntab[10] + Ntab[11]; ROWsums[3] = Ntab[12] + Ntab[13] + Ntab[14] + Ntab[15]; /* transpose Ntab and store the result in P21 */ for (k = 0; k < 4; k++) for (kb = 0; kb < 4; kb++) P21[kb + 4*k] = Ntab[k + 4*kb]; /* scale as above */ for (k = 0; k < 4; k++) for (kb = 0; kb < 16; kb += 4) P21[k + kb] = P21[k + kb]/ROWsums[k]; d[n*(i1 - 1) + i2 - 1] = -log(detFourByFour(P21))/4; } } } #define COMPUTE_DIST_ParaLin\ for (k = 0; k < 16; k++) Ftab[k] = ((double) Ntab[k]/L);\ d[target] = -log(detFourByFour(Ftab)/\ sqrt(find[0][i1 - 1]*find[1][i1 - 1]*find[2][i1 - 1]*find[3][i1 - 1]*\ find[0][i2 - 1]*find[1][i2 - 1]*find[2][i2 - 1]*find[3][i2 - 1]))/4;\ if (variance) {\ /* For the inversion, we first make U an identity matrix */\ for (k = 1; k < 15; k++) U[k] = 0;\ U[0] = U[5] = U[10] = U[15] = 1;\ /* The matrix is not symmetric, so we use 'dgesv'. */\ /* This subroutine puts the result in U. */\ F77_CALL(dgesv)(&ndim, &ndim, Ftab, &ndim, ipiv, U, &ndim, &info);\ var[target] = (U[0]*U[0]*Ftab[0] + U[1]*U[1]*Ftab[4] +\ U[2]*U[2]*Ftab[8] + U[3]*U[3]*Ftab[12] +\ U[4]*U[4]*Ftab[1] + U[5]*U[5]*Ftab[5] +\ U[6]*U[6]*Ftab[9] + U[7]*U[7]*Ftab[13] +\ U[8]*U[8]*Ftab[2] + U[9]*U[9]*Ftab[6] +\ U[10]*U[10]*Ftab[10] + U[11]*U[11]*Ftab[14] +\ U[12]*U[12]*Ftab[3] + U[13]*U[13]*Ftab[7] +\ U[14]*U[14]*Ftab[11] + U[15]*U[15]*Ftab[15] -\ 4*(1/sqrt(find[0][i1 - 1]*find[0][i2 - 1]) +\ 1/sqrt(find[1][i1 - 1]*find[1][i2 - 1]) +\ 1/sqrt(find[2][i1 - 1]*find[2][i2 - 1]) +\ 1/sqrt(find[3][i1 - 1]*find[3][i2 - 1])))/(L*16);\ } void distDNA_ParaLin(unsigned char *x, int n, int s, double *d, int variance, double *var) { int i1, i2, k, s1, s2, m, target, L, Ntab[16], ndim = 4, info, ipiv[16]; double Ftab[16], U[16], *find[4]; L = s; for (k = 0; k < 4; k++) find[k] = (double*)R_alloc(n, sizeof(double)); for (i1 = 0; i1 < n; i1++) for (k = 0; k < 4; k++) find[k][i1] = 0.0; for (i1 = 0; i1 < n; i1++) { for (s1 = i1; s1 < i1 + n*(s - 1) + 1; s1+= n) { switch (x[s1]) { case 136 : find[0][i1]++; break; case 40 : find[1][i1]++; break; case 72 : find[2][i1]++; break; case 24 : find[3][i1]++; break; } } for (k = 0; k < 4; k++) find[k][i1] /= L; } target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { for (k = 0; k < 16; k++) Ntab[k] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { DO_CONTINGENCY_NUCLEOTIDES } COMPUTE_DIST_ParaLin target++; } } } void distDNA_ParaLin_pairdel(unsigned char *x, int n, int s, double *d, int variance, double *var) { int i1, i2, k, s1, s2, m, target, L, Ntab[16], ndim = 4, info, ipiv[16]; double Ftab[16], U[16], *find[4]; L = 0; for (k = 0; k < 4; k++) find[k] = (double*)R_alloc(n, sizeof(double)); for (i1 = 0; i1 < n; i1++) for (k = 0; k < 4; k++) find[k][i1] = 0.0; for (i1 = 0; i1 < n; i1++) { L = 0; for (s1 = i1; s1 < i1 + n*(s - 1) + 1; s1+= n) { if (KnownBase(x[s1])) { L++; switch (x[s1]) { case 136 : find[0][i1]++; break; case 40 : find[1][i1]++; break; case 72 : find[2][i1]++; break; case 24 : find[3][i1]++; break; } } } for (k = 0; k < 4; k++) find[k][i1] /= L; } target = 0; for (i1 = 1; i1 < n; i1++) { for (i2 = i1 + 1; i2 <= n; i2++) { L = 0; for (k = 0; k < 16; k++) Ntab[k] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + n*(s - 1); s1 += n, s2 += n) { CHECK_PAIRWISE_DELETION DO_CONTINGENCY_NUCLEOTIDES } COMPUTE_DIST_ParaLin target++; } } } /* a look-up table is much faster than switch (2012-01-10) */ SEXP BaseProportion(SEXP x) { long i; unsigned char *p; double n, count[256], *BF; SEXP res; PROTECT(x = coerceVector(x, RAWSXP)); memset(count, 0, 256*sizeof(double)); n = XLENGTH(x); p = RAW(x); for (i = 0; i < n; i++) count[p[i]]++; PROTECT(res = allocVector(REALSXP, 17)); BF = REAL(res); BF[0] = count[136]; BF[1] = count[40]; BF[2] = count[72]; BF[3] = count[24]; BF[4] = count[192]; BF[5] = count[160]; BF[6] = count[144]; BF[7] = count[96]; BF[8] = count[80]; BF[9] = count[48]; BF[10] = count[224]; BF[11] = count[176]; BF[12] = count[208]; BF[13] = count[112]; BF[14] = count[240]; BF[15] = count[4]; BF[16] = count[2]; UNPROTECT(2); return res; } #define SEGCOL seg[j] = 1; done = 1; break void seg_sites_a(unsigned char *x, int *seg, int n, int s) { long i, end, done; int j; unsigned char base; for (j = 0; j < s; j++) { i = (long) n * j; /* start */ end = i + n - 1; base = x[i]; done = 0; while (!KnownBase(base)) { /* in this while-loop, we are not yet sure that 'base' is known, so we must be careful with the comparisons */ i++; if (i > end) { done = 1; break; } if (base != x[i]) { if (base != 2 && x[i] != 2) { /* both should not be "?" */ if (base > 4) { if (x[i] == 4) { /* 'base' is not a gap but x[i] is one => this is a segregating site */ SEGCOL; } else { /* both are an ambiguous base */ if (DifferentBase(x[i], base)) { SEGCOL; } } } else { /* 'base' is a gap but x[i] is different => this is a segregating site */ SEGCOL; } } base = x[i]; } } if (done) continue; i++; while (i <= end) { if (x[i] != base) { if (x[i] == 4) { SEGCOL; } else { if (DifferentBase(x[i], base)) { SEGCOL; } } } i++; } } } void seg_sites_strict(unsigned char *x, int *seg, int n, int s) { long i, end; int j; unsigned char b; for (j = 0; j < s; j++) { i = (long) n * j; /* start */ end = i + n - 1; b = x[i]; i++; while (i <= end) { if (x[i] != b) { seg[j] = 1; break; } i++; } } } SEXP SegSites(SEXP DNASEQ, SEXP STRICT) { int n, s, *seg; unsigned char *x; SEXP ans; PROTECT(STRICT = coerceVector(STRICT, INTSXP)); PROTECT(DNASEQ = coerceVector(DNASEQ, RAWSXP)); x = RAW(DNASEQ); n = nrows(DNASEQ); s = ncols(DNASEQ); PROTECT(ans = allocVector(INTSXP, s)); seg = INTEGER(ans); memset(seg, 0, s * sizeof(int)); if (INTEGER(STRICT)[0]) { seg_sites_strict(x, seg, n, s); } else { seg_sites_a(x, seg, n, s); } UNPROTECT(3); return ans; } SEXP GlobalDeletionDNA(SEXP DNASEQ) { int i, j, n, s; unsigned char *x; int *keep; SEXP res; PROTECT(DNASEQ = coerceVector(DNASEQ, RAWSXP)); x = RAW(DNASEQ); n = nrows(DNASEQ); s = ncols(DNASEQ); PROTECT(res = allocVector(INTSXP, s)); keep = INTEGER(res); memset(keep, 1, s * sizeof(int)); for (j = 0; j < s; j++) { i = n * j; while (i < n * (j + 1)) { if (KnownBase(x[i])) i++; else { keep[j] = 0; break; } } } UNPROTECT(2); return res; } SEXP dist_dna(SEXP DNASEQ, SEXP MODEL, SEXP BASEFREQ, SEXP PAIRDEL, SEXP VARIANCE, SEXP GAMMA, SEXP ALPHA) { int n, s, model, pairdel, variance, gamma, Ndist; double *BF, alpha, *d, *var; unsigned char *x; SEXP res, distvar; PROTECT(DNASEQ = coerceVector(DNASEQ, RAWSXP)); PROTECT(MODEL = coerceVector(MODEL, INTSXP)); PROTECT(BASEFREQ = coerceVector(BASEFREQ, REALSXP)); PROTECT(PAIRDEL = coerceVector(PAIRDEL, INTSXP)); PROTECT(VARIANCE = coerceVector(VARIANCE, INTSXP)); PROTECT(GAMMA = coerceVector(GAMMA, INTSXP)); PROTECT(ALPHA = coerceVector(ALPHA, REALSXP)); n = nrows(DNASEQ); s = ncols(DNASEQ); x = RAW(DNASEQ); model = INTEGER(MODEL)[0]; Ndist = n * (n - 1) / 2; if (model == 11) Ndist = n * n; BF = REAL(BASEFREQ); pairdel = INTEGER(PAIRDEL)[0]; variance = INTEGER(VARIANCE)[0]; if (variance) { PROTECT(distvar = allocVector(REALSXP, Ndist)); var = REAL(distvar); } gamma = INTEGER(GAMMA)[0]; if (gamma) alpha = REAL(ALPHA)[0]; PROTECT(res = allocVector(REALSXP, Ndist)); d = REAL(res); switch (model) { case 1 : if (pairdel) { distDNA_raw_pairdel(x, n, s, d, 1); } else { distDNA_raw(x, n, s, d, 1); } break; case 2 : if (pairdel) { distDNA_JC69_pairdel(x, n, s, d, variance, var, gamma, alpha); } else { distDNA_JC69(x, n, s, d, variance, var, gamma, alpha); } break; case 3 : if (pairdel) { distDNA_K80_pairdel(x, n, s, d, variance, var, gamma, alpha); } else { distDNA_K80(x, n, s, d, variance, var, gamma, alpha); } break; case 4 : if (pairdel) { distDNA_F81_pairdel(x, n, s, d, BF, variance, var, gamma, alpha); } else { distDNA_F81(x, n, s, d, BF, variance, var, gamma, alpha); } break; case 5 : if (pairdel) { distDNA_K81_pairdel(x, n, s, d, variance, var); } else { distDNA_K81(x, n, s, d, variance, var); } break; case 6 : if (pairdel) { distDNA_F84_pairdel(x, n, s, d, BF, variance, var); } else { distDNA_F84(x, n, s, d, BF, variance, var); } break; case 7 : if (pairdel) { distDNA_T92_pairdel(x, n, s, d, BF, variance, var); } else { distDNA_T92(x, n, s, d, BF, variance, var); } break; case 8 : if (pairdel) { distDNA_TN93_pairdel(x, n, s, d, BF, variance, var, gamma, alpha); } else { distDNA_TN93(x, n, s, d, BF, variance, var, gamma, alpha); } break; case 9 : if (pairdel) { distDNA_GG95_pairdel(x, n, s, d, variance, var); } else { distDNA_GG95(x, n, s, d, variance, var); } break; case 10 : if (pairdel) { distDNA_LogDet_pairdel(x, n, s, d, variance, var); } else { distDNA_LogDet(x, n, s, d, variance, var); } break; case 11 : distDNA_BH87(x, n, s, d); break; case 12 : if (pairdel) { distDNA_ParaLin_pairdel(x, n, s, d, variance, var); } else { distDNA_ParaLin(x, n, s, d, variance, var); } break; case 13 : if (pairdel) { distDNA_raw_pairdel(x, n, s, d, 0); } else { distDNA_raw(x, n, s, d, 0); } break; case 14 : if (pairdel) { distDNA_TsTv(x, n, s, d, 1, 1); } else { distDNA_TsTv(x, n, s, d, 1, 0); } break; case 15 : if (pairdel) { distDNA_TsTv(x, n, s, d, 0, 1); } else { distDNA_TsTv(x, n, s, d, 0, 0); } break; case 16 : distDNA_indel(x, n, s, d); break; case 17 : distDNA_indelblock(x, n, s, d); break; } if (variance) { SEXP obj; PROTECT(obj = allocVector(VECSXP, 2)); SET_VECTOR_ELT(obj, 0, res); SET_VECTOR_ELT(obj, 1, distvar); UNPROTECT(10); return obj; } else { UNPROTECT(8); return res; } } SEXP C_where(SEXP DNASEQ, SEXP PAT) { int p, j, nans; double s, *buf, *a; long i, k; unsigned char *x, *pat; SEXP ans; PROTECT(DNASEQ = coerceVector(DNASEQ, RAWSXP)); PROTECT(PAT = coerceVector(PAT, RAWSXP)); x = RAW(DNASEQ); pat = RAW(PAT); s = XLENGTH(DNASEQ); p = LENGTH(PAT); nans = 0; buf = (double *)R_alloc(s, sizeof(double)); for (i = 0; i <= s - p; i++) { k = i; j = 0; while (1) { if (x[k] != pat[j]) break; j++; k++; if (j == p) { buf[nans++] = i + 1; break; } } } PROTECT(ans = allocVector(REALSXP, nans)); if (nans) { a = REAL(ans); for (i = 0; i < nans; i++) a[i] = buf[i]; } UNPROTECT(3); return ans; } unsigned char codon2aa_Code1(unsigned char x, unsigned char y, unsigned char z) { if (KnownBase(x)) { if (IsAdenine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x4b; /* codon is AAR => 'K' */ if (IsPyrimidine(z)) return 0x4e; /* codon is AAY => 'N' */ return 0x58; /* 'X' */ } if (IsCytosine(y)) { if (z > 4) return 0x54; /* codon is ACN => 'T' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x52; /* codon is AGR => 'R' */ if (IsPyrimidine(z)) return 0x53; /* codon is AGY => 'S' */ return 0x58; } if (IsThymine(y)) { if (IsGuanine(z)) return 0x4d; /* codon is ATG => 'M' */ if (z & 176) return 0x49; /* codon is ATH => 'I' */ return 0x58; } } return 0x58; } if (IsCytosine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x51; /* codon is CAR => 'Q'*/ if (IsPyrimidine(z)) return 0x48; /* codon is CAY => 'H' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x50; /* codon is CCN => 'P'*/ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x52; /* codon is CGN => 'R' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x4c; /* codon is CTN => 'L' */ return 0x58; } return 0x58; } if (IsGuanine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x45; /* codon is GAR => 'E' */ if (IsPyrimidine(z)) return 0x44; /* codon is GAY => 'D' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x41; /* codon is GCN => 'A' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x47; /* codon is GGN => 'G' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x56; /* codon is GTN => 'V' */ return 0x58; } return 0x58; } if (IsThymine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x2a; /* codon is TAR => '*' */ if (IsPyrimidine(z)) return 0x59; /* codon is TAY => 'Y' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x53; /* codon is TCN => 'S' */ return 0x58; } if (IsGuanine(y)) { if (IsAdenine(z)) return 0x2a; /* codon is TGA => '*' */ if (IsGuanine(z)) return 0x57; /* codon is TGG => 'W' */ if (IsPyrimidine(z)) return 0x43; /* codon is TGY => 'C' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4c; /* codon is TTR => 'L' */ if (IsPyrimidine(z)) return 0x46; /* codon is TTY => 'F' */ return 0x58; } } else if (IsPurine(y) & IsAdenine(z)) return 0x2a; /* codon is TRA => '*' */ return 0x58; } } else { if ((x == 144) && IsThymine(y) && IsPurine(z)) return 0x52; /* codon is MGR => 'R'*/ if ((x == 48) && IsThymine(y) && IsPurine(z)) return 0x4c; /* codon is YTR => 'L'*/ } return 0x58; } unsigned char codon2aa_Code2(unsigned char x, unsigned char y, unsigned char z) { if (KnownBase(x)) { if (IsAdenine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x4b; /* codon is AAR => 'K' */ if (IsPyrimidine(z)) return 0x4e; /* codon is AAY => 'N' */ return 0x58; /* 'X' */ } if (IsCytosine(y)) { if (z > 4) return 0x54; /* codon is ACN => 'T' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x2a; /* codon is AGR => '*' */ if (IsPyrimidine(z)) return 0x53; /* codon is AGY => 'S' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4d; /* codon is ATR => 'M' */ if (IsPyrimidine(z)) return 0x49; /* codon is ATY => 'I' */ return 0x58; } } return 0x58; } if (IsCytosine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x51; /* codon is CAR => 'Q'*/ if (IsPyrimidine(z)) return 0x48; /* codon is CAY => 'H' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x50; /* codon is CCN => 'P'*/ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x52; /* codon is CGN => 'R' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x4c; /* codon is CTN => 'L' */ return 0x58; } return 0x58; } if (IsGuanine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x45; /* codon is GAR => 'E' */ if (IsPyrimidine(z)) return 0x44; /* codon is GAY => 'D' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x41; /* codon is GCN => 'A' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x47; /* codon is GGN => 'G' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x56; /* codon is GTN => 'V' */ return 0x58; } return 0x58; } if (IsThymine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x2a; /* codon is TAR => '*' */ if (IsPyrimidine(z)) return 0x59; /* codon is TAY => 'Y' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x53; /* codon is TCN => 'S' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x57; /* codon is TGR => 'W' */ if (IsPyrimidine(z)) return 0x43; /* codon is TGY => 'C' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4c; /* codon is TTR => 'L' */ if (IsPyrimidine(z)) return 0x46; /* codon is TTY => 'F' */ return 0x58; } } return 0x58; } } else { if ((x == 48) && IsThymine(y) && IsPurine(z)) return 0x4c; /* codon is YTR => 'L'*/ } return 0x58; } unsigned char codon2aa_Code3(unsigned char x, unsigned char y, unsigned char z) { if (KnownBase(x)) { if (IsAdenine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x4b; /* codon is AAR => 'K' */ if (IsPyrimidine(z)) return 0x4e; /* codon is AAY => 'N' */ return 0x58; /* 'X' */ } if (IsCytosine(y)) { if (z > 4) return 0x54; /* codon is ACN => 'T' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x52; /* codon is AGR => 'R' */ if (IsPyrimidine(z)) return 0x53; /* codon is AGY => 'S' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4d; /* codon is ATR => 'M' */ if (IsPyrimidine(z)) return 0x49; /* codon is ATY => 'I' */ return 0x58; } } return 0x58; } if (IsCytosine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x51; /* codon is CAR => 'Q'*/ if (IsPyrimidine(z)) return 0x48; /* codon is CAY => 'H' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x50; /* codon is CCN => 'P'*/ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x52; /* codon is CGN => 'R' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x4c; /* codon is CTN => 'T' */ return 0x58; } return 0x58; } if (IsGuanine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x45; /* codon is GAR => 'E' */ if (IsPyrimidine(z)) return 0x44; /* codon is GAY => 'D' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x41; /* codon is GCN => 'A' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x47; /* codon is GGN => 'G' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x56; /* codon is GTN => 'V' */ return 0x58; } return 0x58; } if (IsThymine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x2a; /* codon is TAR => '*' */ if (IsPyrimidine(z)) return 0x59; /* codon is TAY => 'Y' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x53; /* codon is TCN => 'S' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x57; /* codon is TGR => 'W' */ if (IsPyrimidine(z)) return 0x43; /* codon is TGY => 'C' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4c; /* codon is TTR => 'L' */ if (IsPyrimidine(z)) return 0x46; /* codon is TTY => 'F' */ return 0x58; } } else if (IsPurine(y) & IsAdenine(z)) return 0x2a; /* codon is TRA => '*' */ return 0x58; } } else { if ((x == 144) && IsThymine(y) && IsPurine(z)) return 0x52; /* codon is MGR => 'R'*/ if ((x == 48) && IsThymine(y) && IsPurine(z)) return 0x4c; /* codon is YTR => 'L'*/ } return 0x58; } unsigned char codon2aa_Code4(unsigned char x, unsigned char y, unsigned char z) { if (KnownBase(x)) { if (IsAdenine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x4b; /* codon is AAR => 'K' */ if (IsPyrimidine(z)) return 0x4e; /* codon is AAY => 'N' */ return 0x58; /* 'X' */ } if (IsCytosine(y)) { if (z > 4) return 0x54; /* codon is ACN => 'T' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x52; /* codon is AGR => 'R' */ if (IsPyrimidine(z)) return 0x53; /* codon is AGY => 'S' */ return 0x58; } if (IsThymine(y)) { if (IsGuanine(z)) return 0x4d; /* codon is ATG => 'M' */ if (z & 176) return 0x49; /* codon is ATH => 'I' */ return 0x58; } } return 0x58; } if (IsCytosine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x51; /* codon is CAR => 'Q'*/ if (IsPyrimidine(z)) return 0x48; /* codon is CAY => 'H' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x50; /* codon is CCN => 'P'*/ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x52; /* codon is CGN => 'R' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x4c; /* codon is CTN => 'L' */ return 0x58; } return 0x58; } if (IsGuanine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x45; /* codon is GAR => 'E' */ if (IsPyrimidine(z)) return 0x44; /* codon is GAY => 'D' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x41; /* codon is GCN => 'A' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x47; /* codon is GGN => 'G' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x56; /* codon is GTN => 'V' */ return 0x58; } return 0x58; } if (IsThymine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x2a; /* codon is TAR => '*' */ if (IsPyrimidine(z)) return 0x59; /* codon is TAY => 'Y' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x53; /* codon is TCN => 'S' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x57; /* codon is TGR => 'W' */ if (IsPyrimidine(z)) return 0x43; /* codon is TGY => 'C' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4c; /* codon is TTR => 'L' */ if (IsPyrimidine(z)) return 0x46; /* codon is TTY => 'F' */ return 0x58; } } else if (IsPurine(y) & IsAdenine(z)) return 0x2a; /* codon is TRA => '*' */ return 0x58; } } else { if ((x == 144) && IsThymine(y) && IsPurine(z)) return 0x52; /* codon is MGR => 'R'*/ if ((x == 48) && IsThymine(y) && IsPurine(z)) return 0x4c; /* codon is YTR => 'L'*/ } return 0x58; } unsigned char codon2aa_Code5(unsigned char x, unsigned char y, unsigned char z) { if (KnownBase(x)) { if (IsAdenine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x4b; /* codon is AAR => 'K' */ if (IsPyrimidine(z)) return 0x4e; /* codon is AAY => 'N' */ return 0x58; /* 'X' */ } if (IsCytosine(y)) { if (z > 4) return 0x54; /* codon is ACN => 'T' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x53; /* codon is AGN => 'S' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4d; /* codon is ATR => 'M' */ if (IsPyrimidine(z)) return 0x49; /* codon is ATY => 'I' */ return 0x58; } } return 0x58; } if (IsCytosine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x51; /* codon is CAR => 'Q'*/ if (IsPyrimidine(z)) return 0x48; /* codon is CAY => 'H' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x50; /* codon is CCN => 'P'*/ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x52; /* codon is CGN => 'R' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x4c; /* codon is CTN => 'L' */ return 0x58; } return 0x58; } if (IsGuanine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x45; /* codon is GAR => 'E' */ if (IsPyrimidine(z)) return 0x44; /* codon is GAY => 'D' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x41; /* codon is GCN => 'A' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x47; /* codon is GGN => 'G' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x56; /* codon is GTN => 'V' */ return 0x58; } return 0x58; } if (IsThymine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x2a; /* codon is TAR => '*' */ if (IsPyrimidine(z)) return 0x59; /* codon is TAY => 'Y' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x53; /* codon is TCN => 'S' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x57; /* codon is TGR => 'W' */ if (IsPyrimidine(z)) return 0x43; /* codon is TGY => 'C' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4c; /* codon is TTR => 'L' */ if (IsPyrimidine(z)) return 0x46; /* codon is TTY => 'F' */ return 0x58; } } else if (IsPurine(y) & IsAdenine(z)) return 0x2a; /* codon is TRA => '*' */ return 0x58; } } else { if ((x == 144) && IsThymine(y) && IsPurine(z)) return 0x52; /* codon is MGR => 'R'*/ if ((x == 48) && IsThymine(y) && IsPurine(z)) return 0x4c; /* codon is YTR => 'L'*/ } return 0x58; } unsigned char codon2aa_Code6(unsigned char x, unsigned char y, unsigned char z) { if (KnownBase(x)) { if (IsAdenine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x4b; /* codon is AAR => 'K' */ if (IsPyrimidine(z)) return 0x4e; /* codon is AAY => 'N' */ return 0x58; /* 'X' */ } if (IsCytosine(y)) { if (z > 4) return 0x54; /* codon is ACN => 'T' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x52; /* codon is AGR => 'R' */ if (IsPyrimidine(z)) return 0x53; /* codon is AGY => 'S' */ return 0x58; } if (IsThymine(y)) { if (IsGuanine(z)) return 0x4d; /* codon is ATG => 'M' */ if (z & 176) return 0x49; /* codon is ATH => 'I' */ return 0x58; } } return 0x58; } if (IsCytosine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x51; /* codon is CAR => 'Q'*/ if (IsPyrimidine(z)) return 0x48; /* codon is CAY => 'H' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x50; /* codon is CCN => 'P'*/ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x52; /* codon is CGN => 'R' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x4c; /* codon is CTN => 'L' */ return 0x58; } return 0x58; } if (IsGuanine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x45; /* codon is GAR => 'E' */ if (IsPyrimidine(z)) return 0x44; /* codon is GAY => 'D' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x41; /* codon is GCN => 'A' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x47; /* codon is GGN => 'G' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x56; /* codon is GTN => 'V' */ return 0x58; } return 0x58; } if (IsThymine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x2a; /* codon is TAR => 'Q' */ if (IsPyrimidine(z)) return 0x59; /* codon is TAY => 'Y' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x53; /* codon is TCN => 'S' */ return 0x58; } if (IsGuanine(y)) { if (IsAdenine(z)) return 0x2a; /* codon is TGA => '*' */ if (IsGuanine(z)) return 0x57; /* codon is TGG => 'W' */ if (IsPyrimidine(z)) return 0x43; /* codon is TGY => 'C' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4c; /* codon is TTR => 'L' */ if (IsPyrimidine(z)) return 0x46; /* codon is TTY => 'F' */ return 0x58; } } else if (IsPurine(y) & IsAdenine(z)) return 0x2a; /* codon is TRA => '*' */ return 0x58; } } else { if ((x == 144) && IsThymine(y) && IsPurine(z)) return 0x52; /* codon is MGR => 'R'*/ if ((x == 48) && IsThymine(y) && IsPurine(z)) return 0x4c; /* codon is YTR => 'L'*/ } return 0x58; } void trans_DNA2AA(unsigned char *x, int *s, unsigned char *res, int *code) { int i = 0, j = 0; unsigned char (*FUN)(unsigned char x, unsigned char y, unsigned char z); /* NOTE: using 'switch' provokes a memory leak */ while (1) { if (*code == 1) { FUN = &codon2aa_Code1; break; } if (*code == 2) { FUN = &codon2aa_Code2; break; } if (*code == 3) { FUN = &codon2aa_Code3; break; } if (*code == 4) { FUN = &codon2aa_Code4; break; } if (*code == 5) { FUN = &codon2aa_Code5; break; } if (*code == 6) { FUN = &codon2aa_Code6; break; } } while (i < *s) { res[j] = FUN(x[i], x[i + 1], x[i + 2]); j++; i += 3; } } SEXP leading_trailing_gaps_to_N(SEXP DNASEQ) { int i, n, s; long j, k; unsigned char *x, *z; SEXP ans; PROTECT(DNASEQ = coerceVector(DNASEQ, RAWSXP)); x = RAW(DNASEQ); n = nrows(DNASEQ); s = ncols(DNASEQ); PROTECT(ans = allocVector(RAWSXP, n * s)); z = RAW(ans); memcpy(z, x, n * s); for (i = 0; i < n; i++) { /* leading gaps */ j = (long) i; /* start of the seq */ k = (long) j + n * (s - 1); /* last site of seq j */ while (x[j] == 4 && j <= k) { z[j] = 240; /* - -> N */ j += n; } } for (i = 0; i < n; i++) { /* trailing gaps */ k = (long) i; /* start of the seq */ j = (long) k + n * (s - 1); /* the last site of seq j */ while (x[j] == 4 && j >= k) { z[j] = 240; /* - -> N */ j -= n; } } UNPROTECT(2); return ans; } ape/src/me_balanced.c0000644000176200001440000003427614164530562014206 0ustar liggesusers/* me_balanced.c 2012-04-30 */ /* Copyright 2007 Vincent Lefort BMEsplitEdge() modified by Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" void BalWFext(edge *e, double **A) /*works except when e is the one edge inserted to new vertex v by firstInsert*/ { edge *f, *g; if ((leaf(e->head)) && (leaf(e->tail))) e->distance = A[e->head->index][e->head->index]; else if (leaf(e->head)) { f = e->tail->parentEdge; g = siblingEdge(e); e->distance = 0.5*(A[e->head->index][g->head->index] + A[e->head->index][f->head->index] - A[g->head->index][f->head->index]); } else { f = e->head->leftEdge; g = e->head->rightEdge; e->distance = 0.5*(A[g->head->index][e->head->index] + A[f->head->index][e->head->index] - A[f->head->index][g->head->index]); } } void BalWFint(edge *e, double **A) { int up, down, left, right; up = e->tail->index; down = (siblingEdge(e))->head->index; left = e->head->leftEdge->head->index; right = e->head->rightEdge->head->index; e->distance = 0.25*(A[up][left] + A[up][right] + A[left][down] + A[right][down]) - 0.5*(A[down][up] + A[left][right]); } void assignBMEWeights(tree *T, double **A) { edge *e; e = depthFirstTraverse(T,NULL); while (NULL != e) { if ((leaf(e->head)) || (leaf(e->tail))) BalWFext(e,A); else BalWFint(e,A); e = depthFirstTraverse(T,e); } } void BMEcalcDownAverage(tree *T, node *v, edge *e, double **D, double **A) { edge *left, *right; if (leaf(e->head)) A[e->head->index][v->index] = D[v->index2][e->head->index2]; else { left = e->head->leftEdge; right = e->head->rightEdge; A[e->head->index][v->index] = 0.5 * A[left->head->index][v->index] + 0.5 * A[right->head->index][v->index]; } } void BMEcalcUpAverage(tree *T, node *v, edge *e, double **D, double **A) { edge *up,*down; if (T->root == e->tail) A[v->index][e->head->index] = D[v->index2][e->tail->index2]; /*for now, use convention v->index first => looking up v->index second => looking down */ else { up = e->tail->parentEdge; down = siblingEdge(e); A[v->index][e->head->index] = 0.5 * A[v->index][up->head->index] +0.5 * A[down->head->index][v->index]; } } void BMEcalcNewvAverages(tree *T, node *v, double **D, double **A) { /*loop over edges*/ /*depth-first search*/ edge *e; e = NULL; e = depthFirstTraverse(T,e); /*the downward averages need to be calculated from bottom to top */ while(NULL != e) { BMEcalcDownAverage(T,v,e,D,A); e = depthFirstTraverse(T,e); } e = topFirstTraverse(T,e); /*the upward averages need to be calculated from top to bottom */ while(NULL != e) { BMEcalcUpAverage(T,v,e,D,A); e = topFirstTraverse(T,e); } } /*update Pair updates A[nearEdge][farEdge] and makes recursive call to subtree beyond farEdge*/ /*root is head or tail of edge being split, depending on direction toward v*/ void updatePair(double **A, edge *nearEdge, edge *farEdge, node *v, node *root, double dcoeff, int direction) { edge *sib; switch(direction) /*the various cases refer to where the new vertex has been inserted, in relation to the edge nearEdge*/ { case UP: /*this case is called when v has been inserted above or skew to farEdge*/ /*do recursive calls first!*/ if (NULL != farEdge->head->leftEdge) updatePair(A,nearEdge,farEdge->head->leftEdge,v,root,dcoeff,UP); if (NULL != farEdge->head->rightEdge) updatePair(A,nearEdge,farEdge->head->rightEdge,v,root,dcoeff,UP); A[farEdge->head->index][nearEdge->head->index] = A[nearEdge->head->index][farEdge->head->index] = A[farEdge->head->index][nearEdge->head->index] + dcoeff*A[farEdge->head->index][v->index] - dcoeff*A[farEdge->head->index][root->index]; break; case DOWN: /*called when v has been inserted below farEdge*/ if (NULL != farEdge->tail->parentEdge) updatePair(A,nearEdge,farEdge->tail->parentEdge,v,root,dcoeff,DOWN); sib = siblingEdge(farEdge); if (NULL != sib) updatePair(A,nearEdge,sib,v,root,dcoeff,UP); A[farEdge->head->index][nearEdge->head->index] = A[nearEdge->head->index][farEdge->head->index] = A[farEdge->head->index][nearEdge->head->index] + dcoeff*A[v->index][farEdge->head->index] - dcoeff*A[farEdge->head->index][root->index]; } } void updateSubTree(double **A, edge *nearEdge, node *v, node *root, node *newNode, double dcoeff, int direction) { edge *sib; switch(direction) { case UP: /*newNode is above the edge nearEdge*/ A[v->index][nearEdge->head->index] = A[nearEdge->head->index][v->index]; A[newNode->index][nearEdge->head->index] = A[nearEdge->head->index][newNode->index] = A[nearEdge->head->index][root->index]; if (NULL != nearEdge->head->leftEdge) updateSubTree(A, nearEdge->head->leftEdge, v, root, newNode, 0.5*dcoeff, UP); if (NULL != nearEdge->head->rightEdge) updateSubTree(A, nearEdge->head->rightEdge, v, root, newNode, 0.5*dcoeff, UP); updatePair(A, nearEdge, nearEdge, v, root, dcoeff, UP); break; case DOWN: /*newNode is below the edge nearEdge*/ A[nearEdge->head->index][v->index] = A[v->index][nearEdge->head->index]; A[newNode->index][nearEdge->head->index] = A[nearEdge->head->index][newNode->index] = 0.5*(A[nearEdge->head->index][root->index] + A[v->index][nearEdge->head->index]); sib = siblingEdge(nearEdge); if (NULL != sib) updateSubTree(A, sib, v, root, newNode, 0.5*dcoeff, SKEW); if (NULL != nearEdge->tail->parentEdge) updateSubTree(A, nearEdge->tail->parentEdge, v, root, newNode, 0.5*dcoeff, DOWN); updatePair(A, nearEdge, nearEdge, v, root, dcoeff, DOWN); break; case SKEW: /*newNode is neither above nor below nearEdge*/ A[v->index][nearEdge->head->index] = A[nearEdge->head->index][v->index]; A[newNode->index][nearEdge->head->index] = A[nearEdge->head->index][newNode->index] = 0.5*(A[nearEdge->head->index][root->index] + A[nearEdge->head->index][v->index]); if (NULL != nearEdge->head->leftEdge) updateSubTree(A, nearEdge->head->leftEdge, v, root, newNode, 0.5*dcoeff,SKEW); if (NULL != nearEdge->head->rightEdge) updateSubTree(A, nearEdge->head->rightEdge, v, root, newNode, 0.5*dcoeff,SKEW); updatePair(A, nearEdge, nearEdge, v, root, dcoeff, UP); } } /*we update all the averages for nodes (u1,u2), where the insertion point of v is in "direction" from both u1 and u2 */ /*The general idea is to proceed in a direction from those edges already corrected */ /*r is the root of the tree relative to the inserted node*/ void BMEupdateAveragesMatrix(double **A, edge *e, node *v,node *newNode) { edge *sib, *par, *left, *right; /*first, update the v,newNode entries*/ A[newNode->index][newNode->index] = 0.5*(A[e->head->index][e->head->index] + A[v->index][e->head->index]); A[v->index][newNode->index] = A[newNode->index][v->index] = A[v->index][e->head->index]; A[v->index][v->index] = 0.5*(A[e->head->index][v->index] + A[v->index][e->head->index]); left = e->head->leftEdge; right = e->head->rightEdge; if (NULL != left) updateSubTree(A,left,v,e->head,newNode,0.25,UP); /*updates left and below*/ if (NULL != right) updateSubTree(A,right,v,e->head,newNode,0.25,UP); /*updates right and below*/ sib = siblingEdge(e); if (NULL != sib) updateSubTree(A,sib,v,e->head,newNode,0.25,SKEW); /*updates sib and below*/ par = e->tail->parentEdge; if (NULL != par) updateSubTree(A,par,v,e->head,newNode,0.25,DOWN); /*updates par and above*/ /*must change values A[e->head][*] last, as they are used to update the rest of the matrix*/ A[newNode->index][e->head->index] = A[e->head->index][newNode->index] = A[e->head->index][e->head->index]; A[v->index][e->head->index] = A[e->head->index][v->index]; updatePair(A,e,e,v,e->head,0.5,UP); /*updates e->head fields only*/ } /*A is tree below sibling, B is tree below edge, C is tree above edge*/ double wf3(double D_AB, double D_AC, double D_kB, double D_kC) { return(D_AC + D_kB - D_AB - D_kC); } void BMEtestEdge(edge *e, node *v, double **A) { edge *up, *down; down = siblingEdge(e); up = e->tail->parentEdge; e->totalweight = wf3(A[e->head->index][down->head->index], A[down->head->index][e->tail->index], A[e->head->index][v->index], A[v->index][e->tail->index]) + up->totalweight; } void BMEsplitEdge(tree *T, node *v, edge *e, double **A) { edge *newPendantEdge; edge *newInternalEdge; node *newNode; int nodeLabel = 0;//char nodeLabel[NODE_LABEL_LENGTH]; char edgeLabel1[EDGE_LABEL_LENGTH]; char edgeLabel2[EDGE_LABEL_LENGTH]; //snprintf(nodeLabel,1,""); //sprintf(edgeLabel1,"E%d",T->size); //sprintf(edgeLabel2,"E%d",T->size+1); snprintf(edgeLabel1,EDGE_LABEL_LENGTH,"E%d",T->size); snprintf(edgeLabel2,EDGE_LABEL_LENGTH,"E%d",T->size+1); /*make the new node and edges*/ newNode = makeNewNode(nodeLabel,T->size+1); newPendantEdge = makeEdge(edgeLabel1,newNode,v,0.0); newInternalEdge = makeEdge(edgeLabel2,newNode,e->head,0.0); /*update the matrix of average distances*/ BMEupdateAveragesMatrix(A,e,v,newNode); /*put them in the correct topology*/ newNode->parentEdge = e; e->head->parentEdge = newInternalEdge; v->parentEdge = newPendantEdge; e->head = newNode; T->size = T->size + 2; if (e->tail->leftEdge == e) /*actually this is totally arbitrary and probably unnecessary*/ { newNode->leftEdge = newInternalEdge; newNode->rightEdge = newPendantEdge; } else { newNode->leftEdge = newInternalEdge; newNode->rightEdge = newPendantEdge; } } tree *BMEaddSpecies(tree *T,node *v, double **D, double **A) /*the key function of the program addSpeices inserts the node v to the tree T. It uses testEdge to see what the relative weight would be if v split a particular edge. Once insertion point is found, v is added to T, and A is updated. Edge weights are not assigned until entire tree is build*/ { tree *T_e; edge *e; /*loop variable*/ edge *e_min; /*points to best edge seen thus far*/ double w_min = 0.0; /*used to keep track of tree weights*/ /*initialize variables as necessary*/ /*CASE 1: T is empty, v is the first node*/ if (NULL == T) /*create a tree with v as only vertex, no edges*/ { T_e = newTree(); T_e->root = v; /*note that we are rooting T arbitrarily at a leaf. T->root is not the phylogenetic root*/ v->index = 0; T_e->size = 1; return(T_e); } /*CASE 2: T is a single-vertex tree*/ if (1 == T->size) { v->index = 1; e = makeEdge("",T->root,v,0.0); //sprintf(e->label,"E1"); snprintf(e->label,EDGE_LABEL_LENGTH,"E1"); A[v->index][v->index] = D[v->index2][T->root->index2]; T->root->leftEdge = v->parentEdge = e; T->size = 2; return(T); } /*CASE 3: T has at least two nodes and an edge. Insert new node by breaking one of the edges*/ v->index = T->size; BMEcalcNewvAverages(T,v,D,A); /*calcNewvAverages will update A for the row and column include the node v. Will do so using pre-existing averages in T and information from A,D*/ e_min = T->root->leftEdge; e = e_min->head->leftEdge; while (NULL != e) { BMEtestEdge(e,v,A); /*testEdge tests weight of tree if loop variable e is the edge split, places this value in the e->totalweight field */ if (e->totalweight < w_min) { e_min = e; w_min = e->totalweight; } e = topFirstTraverse(T,e); } /*e_min now points at the edge we want to split*/ /* if (verbose) printf("Inserting %s between %s and %s on %s\n",v->label,e_min->tail->label, e_min->head->label,e_min->label);*/ BMEsplitEdge(T,v,e_min,A); return(T); } /*calcUpAverages will ensure that A[e->head->index][f->head->index] is filled for any f >= g. Works recursively*/ void calcUpAverages(double **D, double **A, edge *e, edge *g) { node *u,*v; edge *s; if (!(leaf(g->tail))) { calcUpAverages(D,A,e,g->tail->parentEdge); s = siblingEdge(g); u = g->tail; v = s->head; A[e->head->index][g->head->index] = A[g->head->index][e->head->index] = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]); } } void makeBMEAveragesTable(tree *T, double **D, double **A) { edge *e, *f, *exclude; node *u,*v; /*first, let's deal with the averages involving the root of T*/ e = T->root->leftEdge; f = depthFirstTraverse(T,NULL); while (NULL != f) { if (leaf(f->head)) { A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->tail->index2][f->head->index2]; } else { u = f->head->leftEdge->head; v = f->head->rightEdge->head; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]); } f = depthFirstTraverse(T,f); } e = depthFirstTraverse(T,NULL); while (T->root->leftEdge != e) { f = exclude = e; while (T->root->leftEdge != f) { if (f == exclude) exclude = exclude->tail->parentEdge; else if (leaf(e->head)) { if (leaf(f->head)) A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->head->index2][f->head->index2]; else { u = f->head->leftEdge->head; /*since f is chosen using a depth-first search, other values have been calculated*/ v = f->head->rightEdge->head; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]); } } else { u = e->head->leftEdge->head; v = e->head->rightEdge->head; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[f->head->index][u->index] + A[f->head->index][v->index]); } f = depthFirstTraverse(T,f); } e = depthFirstTraverse(T,e); } e = depthFirstTraverse(T,NULL); while (T->root->leftEdge != e) { calcUpAverages(D,A,e,e); /*calculates averages for A[e->head->index][g->head->index] for any edge g in path from e to root of tree*/ e = depthFirstTraverse(T,e); } } /*makeAveragesMatrix*/ ape/src/me.c0000644000176200001440000002567214164530562012375 0ustar liggesusers/* me.c 2019-03-26 */ /* Copyright 2007-2008 Olivier Gascuel, Rick Desper, R port by Vincent Lefort and Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" //functions from me_balanced.c tree *BMEaddSpecies(tree *T, node *v, double **D, double **A); void assignBMEWeights(tree *T, double **A); void makeBMEAveragesTable(tree *T, double **D, double **A); //functions from me_ols.c tree *GMEaddSpecies(tree *T, node *v, double **D, double **A); void assignOLSWeights(tree *T, double **A); void makeOLSAveragesTable(tree *T, double **D, double **A); //functions from bNNI.c void bNNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies); //functions from NNI.c void NNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies); //functions from SPR.c void SPR(tree *T, double **D, double **A, int *count); //functions from TBR.c //void TBR(tree *T, double **D, double **A); void me_b(double *X, int *N, int *labels, int *nni, int *spr, int *tbr, int *edge1, int *edge2, double *el) { double **D, **A; set *species, *slooper; node *addNode; tree *T; int n, nniCount; n = *N; T = NULL; nniCount = 0; species = (set *) malloc(sizeof(set)); species->firstNode = NULL; species->secondNode = NULL; D = loadMatrix(X, labels, n, species); A = initDoubleMatrix(2*n - 2); for(slooper = species; NULL != slooper; slooper = slooper->secondNode) { addNode = copyNode(slooper->firstNode); T = BMEaddSpecies(T, addNode, D, A); } // Compute bNNI if (*nni) bNNI(T, A, &nniCount, D, n); assignBMEWeights(T,A); if (*spr) SPR(T, D, A, &nniCount); if (*tbr) Rprintf("argument tbr was ignored: TBR not performed\n"); //TBR(T, D, A); tree2phylo(T, edge1, edge2, el, labels, n); freeMatrix(D,n); freeMatrix(A,2*n - 2); freeSet(species); freeTree(T); T = NULL; } void me_o(double *X, int *N, int *labels, int *nni, int *edge1, int *edge2, double *el) { double **D, **A; set *species, *slooper; node *addNode; tree *T; int n, nniCount; n = *N; T = NULL; nniCount = 0; species = (set *) malloc(sizeof(set)); species->firstNode = NULL; species->secondNode = NULL; D = loadMatrix (X, labels, n, species); A = initDoubleMatrix(2 * n - 2); for(slooper = species; NULL != slooper; slooper = slooper->secondNode) { addNode = copyNode(slooper->firstNode); T = GMEaddSpecies(T,addNode,D,A); } makeOLSAveragesTable(T,D,A); // Compute NNI if (*nni) NNI(T,A,&nniCount,D,n); assignOLSWeights(T,A); tree2phylo(T, edge1, edge2, el, labels, n); freeMatrix(D,n); freeMatrix(A,2*n - 2); freeSet(species); freeTree(T); T = NULL; } /* -- MATRIX FUNCTIONS -- */ double **initDoubleMatrix(int d) { int i,j; double **A; A = (double **) malloc(d*sizeof(double *)); for(i=0;iindex2 = i; S = addToSet(v,S); for (j=i; jfirstNode = v; X->secondNode = NULL; } else if (NULL == X->firstNode) X->firstNode = v; else X->secondNode = addToSet(v,X->secondNode); return(X); } //node *makeNewNode(char *label, int i) node *makeNewNode(int label, int i) { return(makeNode(label,NULL,i)); } //node *makeNode(char *label, edge *parentEdge, int index) node *makeNode(int label, edge *parentEdge, int index) { node *newNode; /*points to new node added to the graph*/ newNode = (node *) malloc(sizeof(node)); // strncpy(newNode->label,label,NODE_LABEL_LENGTH); newNode->label = label; newNode->index = index; newNode->index2 = -1; newNode->parentEdge = parentEdge; newNode->leftEdge = NULL; newNode->middleEdge = NULL; newNode->rightEdge = NULL; /*all fields have been initialized*/ return(newNode); } /*copyNode returns a copy of v which has all of the fields identical to those of v, except the node pointer fields*/ node *copyNode(node *v) { node *w; w = makeNode(v->label,NULL,v->index); w->index2 = v->index2; return(w); } edge *siblingEdge(edge *e) { if(e == e->tail->leftEdge) return(e->tail->rightEdge); else return(e->tail->leftEdge); } edge *makeEdge(char *label, node *tail, node *head, double weight) { edge *newEdge; newEdge = (edge *) malloc(sizeof(edge)); strncpy(newEdge->label,label,EDGE_LABEL_LENGTH-1); newEdge->tail = tail; newEdge->head = head; newEdge->distance = weight; newEdge->totalweight = 0.0; return(newEdge); } tree *newTree() { tree *T; T = (tree *) malloc(sizeof(tree)); T->root = NULL; T->size = 0; T->weight = -1; return(T); } void updateSizes(edge *e, int direction) { edge *f; switch(direction) { case UP: f = e->head->leftEdge; if (NULL != f) updateSizes(f,UP); f = e->head->rightEdge; if (NULL != f) updateSizes(f,UP); e->topsize++; break; case DOWN: f = siblingEdge(e); if (NULL != f) updateSizes(f,UP); f = e->tail->parentEdge; if (NULL != f) updateSizes(f,DOWN); e->bottomsize++; break; } } /*detrifurcate takes the (possibly trifurcated) input tree and reroots the tree to a leaf*/ /*assumes tree is only trifurcated at root*/ tree *detrifurcate(tree *T) { node *v, *w; edge *e, *f; v = T->root; if(leaf(v)) return(T); if (NULL != v->parentEdge) { error("root %d is poorly rooted.", v->label); } for(e = v->middleEdge, v->middleEdge = NULL; NULL != e; e = f ) { w = e->head; v = e->tail; e->tail = w; e->head = v; f = w->leftEdge; v->parentEdge = e; w->leftEdge = e; w->parentEdge = NULL; } T->root = w; return(T); } void compareSets(tree *T, set *S) { edge *e; node *v,*w; set *X; e = depthFirstTraverse(T,NULL); while (NULL != e) { v = e->head; for(X = S; NULL != X; X = X->secondNode) { w = X->firstNode; // if (0 == strcmp(v->label,w->label)) if (v->label == w->label) { v->index2 = w->index2; w->index2 = -1; break; } } e = depthFirstTraverse(T,e); } v = T->root; for(X = S; NULL != X; X = X->secondNode) { w = X->firstNode; // if (0 == strcmp(v->label,w->label)) if (v->label == w->label) { v->index2 = w->index2; w->index2 = -1; break; } } if (-1 == v->index2) { error("leaf %d in tree not in distance matrix.", v->label); } e = depthFirstTraverse(T,NULL); while (NULL != e) { v = e->head; if ((leaf(v)) && (-1 == v->index2)) { error("leaf %d in tree not in distance matrix.", v->label); } e = depthFirstTraverse(T,e); } for(X = S; NULL != X; X = X->secondNode) if (X->firstNode->index2 > -1) { error("node %d in matrix but not a leaf in tree.", X->firstNode->label); } return; } void partitionSizes(tree *T) { edge *e; e = depthFirstTraverse(T,NULL); while (NULL != e) { if (leaf(e->head)) e->bottomsize = 1; else e->bottomsize = e->head->leftEdge->bottomsize + e->head->rightEdge->bottomsize; e->topsize = (T->size + 2)/2 - e->bottomsize; e = depthFirstTraverse(T,e); } } /************************************************************************* TRAVERSE FUNCTIONS *************************************************************************/ edge *depthFirstTraverse(tree *T, edge *e) /*depthFirstTraverse returns the edge f which is least in T according to the depth-first order, but which is later than e in the search pattern. If e is null, f is the least edge of T*/ { edge *f; if (NULL == e) { f = T->root->leftEdge; if (NULL != f) f = findBottomLeft(f); return(f); /*this is the first edge of this search pattern*/ } else /*e is non-null*/ { if (e->tail->leftEdge == e) /*if e is a left-oriented edge, we skip the entire tree cut below e, and find least edge*/ f = moveRight(e); else /*if e is a right-oriented edge, we have already looked at its sibling and everything below e, so we move up*/ f = e->tail->parentEdge; } return(f); } edge *findBottomLeft(edge *e) /*findBottomLeft searches by gottom down in the tree and to the left.*/ { edge *f; f = e; while (NULL != f->head->leftEdge) f = f->head->leftEdge; return(f); } edge *moveRight(edge *e) { edge *f; f = e->tail->rightEdge; /*this step moves from a left-oriented edge to a right-oriented edge*/ if (NULL != f) f = findBottomLeft(f); return(f); } edge *topFirstTraverse(tree *T, edge *e) /*topFirstTraverse starts from the top of T, and from there moves stepwise down, left before right*/ /*assumes tree has been detrifurcated*/ { edge *f; if (NULL == e) return(T->root->leftEdge); /*first Edge searched*/ else if (!(leaf(e->head))) return(e->head->leftEdge); /*down and to the left is preferred*/ else /*e->head is a leaf*/ { f = moveUpRight(e); return(f); } } edge *moveUpRight(edge *e) { edge *f; f = e; while ((NULL != f) && ( f->tail->leftEdge != f)) f = f->tail->parentEdge; /*go up the tree until f is a leftEdge*/ if (NULL == f) return(f); /*triggered at end of search*/ else return(f->tail->rightEdge); /*and then go right*/ } /************************************************************************* FREE FUNCTIONS *************************************************************************/ void freeMatrix(double **D, int size) { int i; for(i=0;ifirstNode); /* added by EP 2014-03-04 */ freeSet(S->secondNode); } free(S); } void freeTree(tree *T) { node *v; v = T->root; if (NULL != v->leftEdge) freeSubTree(v->leftEdge); free(T->root); free(T); } void freeSubTree(edge *e) { node *v; edge *e1, *e2; v = e->head; e1 = v->leftEdge; if (NULL != e1) freeSubTree(e1); e2 = v->rightEdge; if (NULL != e2) freeSubTree(e2); free(v); e->tail = NULL; e->head = NULL; free(e); } ape/src/NNI.c0000644000176200001440000002566514164530562012422 0ustar liggesusers/* NNI.c 2007-09-05 */ /* Copyright 2007 Vincent Lefort */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" //boolean leaf(node *v); /*edge *siblingEdge(edge *e); edge *depthFirstTraverse(tree *T, edge *e); edge *findBottomLeft(edge *e); edge *topFirstTraverse(tree *T, edge *e); edge *moveUpRight(edge *e); double wf(double lambda, double D_LR, double D_LU, double D_LD, double D_RU, double D_RD, double D_DU);*/ /*NNI functions for unweighted OLS topological switches*/ /*fillTableUp fills all the entries in D associated with e->head,f->head and those edges g->head above e->head*/ void fillTableUp(edge *e, edge *f, double **A, double **D, tree *T) { edge *g,*h; if (T->root == f->tail) { if (leaf(e->head)) A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->head->index2][f->tail->index2]; else { g = e->head->leftEdge; h = e->head->rightEdge; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->bottomsize*A[f->head->index][g->head->index] + h->bottomsize*A[f->head->index][h->head->index]) /e->bottomsize; } } else { g = f->tail->parentEdge; fillTableUp(e,g,A,D,T); /*recursive call*/ h = siblingEdge(f); A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->topsize*A[e->head->index][g->head->index] + h->bottomsize*A[e->head->index][h->head->index])/f->topsize; } } void makeOLSAveragesTable(tree *T, double **D, double **A); double **buildAveragesTable(tree *T, double **D) { int i,j; double **A; A = (double **) malloc(T->size*sizeof(double *)); for(i = 0; i < T->size;i++) { A[i] = (double *) malloc(T->size*sizeof(double)); for(j=0;jsize;j++) A[i][j] = 0.0; } makeOLSAveragesTable(T,D,A); return(A); } double wf2(double lambda, double D_AD, double D_BC, double D_AC, double D_BD, double D_AB, double D_CD) { double weight; weight = 0.5*(lambda*(D_AC + D_BD) + (1 - lambda)*(D_AD + D_BC) + (D_AB + D_CD)); return(weight); } int NNIEdgeTest(edge *e, tree *T, double **A, double *weight) { int a,b,c,d; edge *f; double *lambda; double D_LR, D_LU, D_LD, D_RD, D_RU, D_DU; double w1,w2,w0; if ((leaf(e->tail)) || (leaf(e->head))) return(NONE); lambda = (double *)malloc(3*sizeof(double)); a = e->tail->parentEdge->topsize; f = siblingEdge(e); b = f->bottomsize; c = e->head->leftEdge->bottomsize; d = e->head->rightEdge->bottomsize; lambda[0] = ((double) b*c + a*d)/((a + b)*(c+d)); lambda[1] = ((double) b*c + a*d)/((a + c)*(b+d)); lambda[2] = ((double) c*d + a*b)/((a + d)*(b+c)); D_LR = A[e->head->leftEdge->head->index][e->head->rightEdge->head->index]; D_LU = A[e->head->leftEdge->head->index][e->tail->index]; D_LD = A[e->head->leftEdge->head->index][f->head->index]; D_RU = A[e->head->rightEdge->head->index][e->tail->index]; D_RD = A[e->head->rightEdge->head->index][f->head->index]; D_DU = A[e->tail->index][f->head->index]; w0 = wf2(lambda[0],D_RU,D_LD,D_LU,D_RD,D_DU,D_LR); w1 = wf2(lambda[1],D_RU,D_LD,D_DU,D_LR,D_LU,D_RD); w2 = wf2(lambda[2],D_DU,D_LR,D_LU,D_RD,D_RU,D_LD); free(lambda); if (w0 <= w1) { if (w0 <= w2) /*w0 <= w1,w2*/ { *weight = 0.0; return(NONE); } else /*w2 < w0 <= w1 */ { *weight = w2 - w0; /* if (verbose) { printf("Swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w2); printf("New weight should be %lf.\n",T->weight + w2 - w0); }*/ return(RIGHT); } } else if (w2 <= w1) /*w2 <= w1 < w0*/ { *weight = w2 - w0; /* if (verbose) { printf("Swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w2); printf("New weight should be %lf.\n",T->weight + w2 - w0); }*/ return(RIGHT); } else /*w1 < w2, w0*/ { *weight = w1 - w0; /* if (verbose) { printf("Swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w1); printf("New weight should be %lf.\n",T->weight + w1 - w0); }*/ return(LEFT); } } int *initPerm(int size); void NNIupdateAverages(double **A, edge *e, edge *par, edge *skew, edge *swap, edge *fixed, tree *T) { node *v; edge *elooper; v = e->head; /*first, v*/ A[e->head->index][e->head->index] = (swap->bottomsize* ((skew->bottomsize*A[skew->head->index][swap->head->index] + fixed->bottomsize*A[fixed->head->index][swap->head->index]) / e->bottomsize) + par->topsize* ((skew->bottomsize*A[skew->head->index][par->head->index] + fixed->bottomsize*A[fixed->head->index][par->head->index]) / e->bottomsize) ) / e->topsize; elooper = findBottomLeft(e); /*next, we loop over all the edges which are below e*/ while (e != elooper) { A[e->head->index][elooper->head->index] = A[elooper->head->index][v->index] = (swap->bottomsize*A[elooper->head->index][swap->head->index] + par->topsize*A[elooper->head->index][par->head->index]) / e->topsize; elooper = depthFirstTraverse(T,elooper); } elooper = findBottomLeft(swap); /*next we loop over all the edges below and including swap*/ while (swap != elooper) { A[e->head->index][elooper->head->index] = A[elooper->head->index][e->head->index] = (skew->bottomsize * A[elooper->head->index][skew->head->index] + fixed->bottomsize*A[elooper->head->index][fixed->head->index]) / e->bottomsize; elooper = depthFirstTraverse(T,elooper); } /*now elooper = skew */ A[e->head->index][elooper->head->index] = A[elooper->head->index][e->head->index] = (skew->bottomsize * A[elooper->head->index][skew->head->index] + fixed->bottomsize* A[elooper->head->index][fixed->head->index]) / e->bottomsize; /*finally, we loop over all the edges in the tree on the far side of parEdge*/ elooper = T->root->leftEdge; while ((elooper != swap) && (elooper != e)) /*start a top-first traversal*/ { A[e->head->index][elooper->head->index] = A[elooper->head->index][e->head->index] = (skew->bottomsize * A[elooper->head->index][skew->head->index] + fixed->bottomsize* A[elooper->head->index][fixed->head->index]) / e->bottomsize; elooper = topFirstTraverse(T,elooper); } /*At this point, elooper = par. We finish the top-first traversal, excluding the subtree below par*/ elooper = moveUpRight(par); while (NULL != elooper) { A[e->head->index][elooper->head->index] = A[elooper->head->index][e->head->index] = (skew->bottomsize * A[elooper->head->index][skew->head->index] + fixed->bottomsize* A[elooper->head->index][fixed->head->index]) / e->bottomsize; elooper = topFirstTraverse(T,elooper); } } void NNItopSwitch(tree *T, edge *e, int direction, double **A) { edge *par, *fixed; edge *skew, *swap; /* if (verbose) printf("Branch swap across edge %s.\n",e->label);*/ if (LEFT == direction) swap = e->head->leftEdge; else swap = e->head->rightEdge; skew = siblingEdge(e); fixed = siblingEdge(swap); par = e->tail->parentEdge; /* if (verbose) { printf("Branch swap: switching edges %s and %s.\n",skew->label,swap->label); }*/ /*perform topological switch by changing f from (u,b) to (v,b) and g from (v,c) to (u,c), necessitatates also changing parent fields*/ swap->tail = e->tail; skew->tail = e->head; if (LEFT == direction) e->head->leftEdge = skew; else e->head->rightEdge = skew; if (skew == e->tail->rightEdge) e->tail->rightEdge = swap; else e->tail->leftEdge = swap; /*both topsize and bottomsize change for e, but nowhere else*/ e->topsize = par->topsize + swap->bottomsize; e->bottomsize = fixed->bottomsize + skew->bottomsize; NNIupdateAverages(A, e, par, skew, swap, fixed,T); } /*end NNItopSwitch*/ void reHeapElement(int *p, int *q, double *v, int length, int i); void pushHeap(int *p, int *q, double *v, int length, int i); void popHeap(int *p, int *q, double *v, int length, int i); void NNIRetestEdge(int *p, int *q, edge *e,tree *T, double **avgDistArray, double *weights, int *location, int *possibleSwaps) { int tloc; tloc = location[e->head->index+1]; location[e->head->index+1] = NNIEdgeTest(e,T,avgDistArray,weights + e->head->index+1); if (NONE == location[e->head->index+1]) { if (NONE != tloc) popHeap(p,q,weights,(*possibleSwaps)--,q[e->head->index+1]); } else { if (NONE == tloc) pushHeap(p,q,weights,(*possibleSwaps)++,q[e->head->index+1]); else reHeapElement(p,q,weights,*possibleSwaps,q[e->head->index+1]); } } void permInverse(int *p, int *q, int length); int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh); //void NNI(tree *T, double **avgDistArray, int *count) void NNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies) { edge *e, *centerEdge; edge **edgeArray; int *location; int *p,*q; int i,j; int possibleSwaps; double *weights; p = initPerm(T->size+1); q = initPerm(T->size+1); edgeArray = (edge **) malloc((T->size+1)*sizeof(double)); weights = (double *) malloc((T->size+1)*sizeof(double)); location = (int *) malloc((T->size+1)*sizeof(int)); double epsilon = 0.0; for (i=0; isize+1;i++) { weights[i] = 0.0; location[i] = NONE; } e = findBottomLeft(T->root->leftEdge); /* *count = 0; */ while (NULL != e) { edgeArray[e->head->index+1] = e; location[e->head->index+1] = NNIEdgeTest(e,T,avgDistArray,weights + e->head->index + 1); e = depthFirstTraverse(T,e); } possibleSwaps = makeThreshHeap(p,q,weights,T->size+1,0.0); permInverse(p,q,T->size+1); /*we put the negative values of weights into a heap, indexed by p with the minimum value pointed to by p[1]*/ /*p[i] is index (in edgeArray) of edge with i-th position in the heap, q[j] is the position of edge j in the heap */ while (weights[p[1]] + epsilon < 0) { centerEdge = edgeArray[p[1]]; (*count)++; T->weight = T->weight + weights[p[1]]; NNItopSwitch(T,edgeArray[p[1]],location[p[1]],avgDistArray); location[p[1]] = NONE; weights[p[1]] = 0.0; /*after the NNI, this edge is in optimal configuration*/ popHeap(p,q,weights,possibleSwaps--,1); /*but we must retest the other four edges*/ e = centerEdge->head->leftEdge; NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); e = centerEdge->head->rightEdge; NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); e = siblingEdge(centerEdge); NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); e = centerEdge->tail->parentEdge; NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); } free(p); free(q); free(location); free(edgeArray); } ape/src/BIONJ.c0000644000176200001440000002076714164530562012635 0ustar liggesusers/* BIONJ.c 2012-04-30 */ /* Copyright 2007-2008 Olivier Gascuel, Hoa Sien Cuong, R port by Vincent Lefort and Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ /* BIONJ program Olivier Gascuel GERAD - Montreal- Canada olivierg@crt.umontreal.ca LIRMM - Montpellier- France gascuel@lirmm.fr UNIX version, written in C by Hoa Sien Cuong (Univ. Montreal) */ #include "me.h" void Initialize(float **delta, double *X, int n); void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el); float Distance(int i, int j, float **delta); float Variance(int i, int j, float **delta); int Emptied(int i, float **delta); float Sum_S(int i, float **delta); void Compute_sums_Sx(float **delta, int n); void Best_pair(float **delta, int r, int *a, int *b, int n); float Agglomerative_criterion(int i, int j, float **delta, int r); float Branch_length(int a, int b, float **delta, int r); float Reduction4(int a, float la, int b, float lb, int i, float lamda, float **delta); float Reduction10(int a, int b, int i, float lamda, float vab, float **delta); float Lamda(int a, int b, float vab, float **delta, int n, int r); /* INPUT, OUTPUT, INITIALIZATION The lower-half of the delta matrix is occupied by dissimilarities. The upper-half of the matrix is occupied by variances. The first column is initialized as 0; during the algorithm some indices are no more used, and the corresponding positions in the first column are set to 1. */ /* -- Initialize -- This function reads an input data and returns the delta matrix input: float **delta : delta matrix double *X : distances sent from R as a lower triangle matrix int n : number of taxa output: float **delta : delta matrix initialized */ void Initialize(float **delta, double *X, int n) { int i, j; /* matrix line and column indices */ int k = 0; /* index along X */ for (i = 1; i < n; i++) for (j = i + 1; j <= n; j++) delta[i][j] = delta[j][i] = X[k++]; for (i = 1; i <= n; i++) delta[i][i] = delta[i][0] = 0; } void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el) { int *a, *b; /* pair to be agglomerated */ float **delta; /* delta matrix */ float la; /* first taxon branch-length */ float lb; /* second taxon branch-length */ float vab; /* variance of Dab */ float lamda = 0.5; int r; /* number of subtrees */ int n; /* number of taxa */ int i, x, y, curnod, k; int *ilab; /* indices of the tips (used as "labels") */ a = (int*)R_alloc(1, sizeof(int)); b = (int*)R_alloc(1, sizeof(int)); n = *N; /* Create the delta matrix */ delta = (float **)R_alloc(n + 1, sizeof(float*)); for (i = 1; i <= n; i++) delta[i] = (float *)R_alloc(n + 1, sizeof(float)); /* initialise */ r = n; *a = *b = 0; Initialize(delta, X, n); ilab = (int *)R_alloc(n + 1, sizeof(int)); for (i = 1; i <= n; i++) ilab[i] = i; curnod = 2 * n - 2; k = 0; while (r > 3) { Compute_sums_Sx(delta, n); /* compute the sum Sx */ Best_pair(delta, r, a, b, n); /* find the best pair by */ vab = Variance(*a, *b, delta); /* minimizing (1) */ la = Branch_length(*a, *b, delta, r); /* compute branch-lengths */ lb = Branch_length(*b, *a, delta, r); /* using formula (2) */ lamda = Lamda(*a, *b, vab, delta, n, r); /* compute lambda* using (9)*/ edge1[k] = edge1[k + 1] = curnod; edge2[k] = ilab[*a]; edge2[k + 1] = ilab[*b]; el[k] = la; el[k + 1] = lb; k = k + 2; for (i = 1; i <= n; i++) { if (Emptied(i,delta) || (i == *a) || (i == *b)) continue; if(*a > i) { x = *a; y = i; } else { x = i; y = *a; } /* apply reduction formulae 4 and 10 to delta */ delta[x][y] = Reduction4(*a, la, *b, lb, i, lamda, delta); delta[y][x] = Reduction10(*a, *b, i, lamda, vab, delta); } delta[*b][0] = 1.0; /* make the b line empty */ ilab[*a] = curnod; curnod--; r = r - 1; } /* finalise the three basal edges */ int last[3]; i = 1; k = 0; while (k < 3) { if (!Emptied(i, delta)) last[k++] = i; i++; } for (i = 0, k = 2 * n - 4; i < 3; i++, k--) { edge1[k] = curnod; /* <- the root at this stage */ edge2[k] = ilab[last[i]]; } double D[3]; D[0] = Distance(last[0], last[1], delta); D[1] = Distance(last[0], last[2], delta); D[2] = Distance(last[1], last[2], delta); el[2 * n - 4] = (D[0] + D[1] - D[2])/2; el[2 * n - 5] = (D[0] + D[2] - D[1])/2; el[2 * n - 6] = (D[2] + D[1] - D[0])/2; } /* -- Distance -- This function retrieves and returns the distance between taxa i and j from the delta matrix. input: int i : taxon i int j : taxon j float **delta : the delta matrix output: float distance : dissimilarity between the two taxa */ float Distance(int i, int j, float **delta) { if (i > j) return(delta[i][j]); else return(delta[j][i]); } /* -- Variance -- This function retrieves and returns the variance of the distance between i and j, from the delta matrix. input: int i : taxon i int j : taxon j float **delta : the delta matrix output: float distance : the variance of Dij */ float Variance(int i, int j, float **delta) { if (i > j) return(delta[j][i]); else return(delta[i][j]); } /* -- Emptied -- This function tests if a line is emptied or not. input: int i : subtree (or line) i float **delta : the delta matrix output: 0 : if not emptied 1 : if emptied */ int Emptied(int i, float **delta) { return((int)delta[i][0]); } /* -- Sum_S -- This function retrieves the sum Sx from the diagonal of the delta matrix input: int i : subtree i float **delta : the delta matrix output: float delta[i][i] : sum Si */ float Sum_S(int i, float **delta) { return(delta[i][i]); } /* -- Compute_sums_Sx -- This function computes the sums Sx and stores them in the diagonal the delta matrix. input: float **delta : the delta matrix int n : the number of taxa */ void Compute_sums_Sx(float **delta, int n) { float sum; int i, j; for (i = 1; i <= n ; i++) { if (Emptied(i, delta)) continue; sum = 0; for (j = 1; j <= n; j++) { if (i == j || Emptied(j, delta)) continue; sum += Distance(i, j, delta); /* compute the sum Si */ } delta[i][i] = sum; } } /* -- Best_pair -- This function finds the best pair to be agglomerated by minimizing the agglomerative criterion (1). input: float **delta : the delta matrix int r : number of subtrees int *a : contain the first taxon of the pair int *b : contain the second taxon of the pair int n : number of taxa output: int *a : the first taxon of the pair int *b : the second taxon of the pair */ void Best_pair(float **delta, int r, int *a, int *b, int n) { float Qxy; /* value of the criterion calculated */ int x, y; /* the pair which is tested */ float Qmin; /* current minimun of the criterion */ Qmin = 1.0e30; for (x = 1; x <= n; x++) { if (Emptied(x, delta)) continue; for (y = 1; y < x; y++) { if (Emptied(y, delta)) continue; Qxy = Agglomerative_criterion(x, y, delta, r); if (Qxy < Qmin - 0.000001) { Qmin = Qxy; *a = x; *b = y; } } } } /* Formulae */ /* Formula (1) */ float Agglomerative_criterion(int i, int j, float **delta, int r) { return((r - 2) * Distance(i, j, delta) - Sum_S(i, delta) - Sum_S(j, delta)); } /* Formula (2) */ float Branch_length(int a, int b, float **delta, int r) { return(0.5 * (Distance(a, b, delta) + (Sum_S(a, delta) - Sum_S(b, delta))/(r - 2))); } /* Formula (4) */ float Reduction4(int a, float la, int b, float lb, int i, float lamda, float **delta) { return(lamda * (Distance(a, i, delta) - la) + (1 - lamda) * (Distance(b, i, delta) - lb)); } /* Formula (10) */ float Reduction10(int a, int b, int i, float lamda, float vab, float **delta) { return(lamda * Variance(a, i, delta) + (1 - lamda) * Variance(b, i, delta) - lamda * (1 - lamda) * vab); } float Lamda(int a, int b, float vab, float **delta, int n, int r) { float lamda = 0.0; int i; if (vab == 0.0) lamda = 0.5; else { for (i = 1; i <= n ; i++) { if (a == i || b == i || Emptied(i, delta)) continue; lamda += (Variance(b, i, delta) - Variance(a, i, delta)); } lamda = 0.5 + lamda/(2 * (r - 2) * vab); /* Formula (9) */ } if (lamda > 1.0) lamda = 1.0; /* force 0 < lamda < 1 */ if (lamda < 0.0) lamda = 0.0; return(lamda); } ape/src/read_dna.c0000644000176200001440000003043714164530562013524 0ustar liggesusers/* read_dna.c 2020-05-02 */ /* Copyright 2013-2020 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include /* translation table CHAR -> DNAbin */ static unsigned char tab_trans[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 0-9 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 10-19 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 20-29 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 30-39 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x04, 0x00, 0x00, 0x00, 0x00, /* 40-49 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 50-59 */ 0x00, 0x00, 0x00, 0x02, 0x00, 0x88, 0x70, 0x28, 0xd0, 0x00, /* 60-69 */ 0x00, 0x48, 0xb0, 0x00, 0x00, 0x50, 0x00, 0xa0, 0xf0, 0x00, /* 70-79 */ 0x00, 0x00, 0xc0, 0x60, 0x18, 0x00, 0xe0, 0x90, 0x00, 0x30, /* 80-89 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x88, 0x70, 0x28, /* 90-99 */ 0xd0, 0x00, 0x00, 0x48, 0xb0, 0x00, 0x00, 0x50, 0x00, 0xa0, /* 100-109 */ 0xf0, 0x00, 0x00, 0x00, 0xc0, 0x60, 0x18, 0x00, 0xe0, 0x90, /* 110-119 */ 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 120-129 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 130-139 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 140-149 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 150-159 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 160-169 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 170-179 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 180-189 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 190-199 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 200-209 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 210-219 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 220-229 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 230-239 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 240-249 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; /* 250-255 */ /* translation table DNAbin -> CHAR */ static const unsigned char tab_trans_rev[] = { 0x00, 0x00, 0x3f, 0x00, 0x2d, 0x00, 0x00, 0x00, 0x00, 0x00, /* 0-9 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 10-19 */ 0x00, 0x00, 0x00, 0x00, 0x54, 0x00, 0x00, 0x00, 0x00, 0x00, /* 20-29 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 30-39 */ 0x43, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x59, 0x00, /* 40-49 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 50-59 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 60-69 */ 0x00, 0x00, 0x47, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 70-79 */ 0x4b, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 80-89 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x53, 0x00, 0x00, 0x00, /* 90-99 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 100-109 */ 0x00, 0x00, 0x42, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 110-119 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 120-129 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x41, 0x00, 0x00, 0x00, /* 130-139 */ 0x00, 0x00, 0x00, 0x00, 0x57, 0x00, 0x00, 0x00, 0x00, 0x00, /* 140-149 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 150-159 */ 0x4d, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 160-169 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x48, 0x00, 0x00, 0x00, /* 170-179 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 180-189 */ 0x00, 0x00, 0x52, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 190-199 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x44, 0x00, /* 200-209 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 210-219 */ 0x00, 0x00, 0x00, 0x00, 0x56, 0x00, 0x00, 0x00, 0x00, 0x00, /* 220-229 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 230-239 */ 0x4e, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 240-249 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; /* 250-255 */ /* translation table CHAR -> AAbin */ static unsigned char tab_trans_aminoacid[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 0-9 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 10-19 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 20-29 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 30-39 */ 0x00, 0x00, 0x2a, 0x00, 0x00, 0x2d, 0x00, 0x00, 0x00, 0x00, /* 40-49 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 50-59 */ 0x00, 0x00, 0x00, 0x3f, 0x00, 0x41, 0x41, 0x43, 0x44, 0x45, /* 60-69 */ 0x46, 0x47, 0x48, 0x49, 0x00, 0x4b, 0x4c, 0x4d, 0x4e, 0x00, /* 70-79 */ 0x50, 0x51, 0x52, 0x53, 0x54, 0x00, 0x56, 0x57, 0x58, 0x59, /* 80-89 */ 0x5a, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x61, 0x62, 0x63, /* 90-99 */ 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x00, 0x6b, 0x6c, 0x6d, /* 100-109 */ 0x6e, 0x00, 0x70, 0x71, 0x72, 0x73, 0x74, 0x00, 0x76, 0x77, /* 110-119 */ 0x78, 0x79, 0x7a, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 120-129 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 130-139 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 140-149 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 150-159 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 160-169 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 170-179 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 180-189 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 190-199 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 200-209 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 210-219 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 220-229 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 230-239 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 240-249 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; /* 250-255 */ static const unsigned char hook = 0x3e; static const unsigned char lineFeed = 0x0a; /* static const unsigned char space = 0x20; */ SEXP rawStreamToDNAorAAbin(SEXP x, SEXP DNA) { int k, startOfSeq; long i, j, n; unsigned char *xr, *rseq, *buffer, tmp, *TAB_TRANS; SEXP obj, nms, seq; PROTECT(x = coerceVector(x, RAWSXP)); PROTECT(DNA = coerceVector(DNA, INTSXP)); if (INTEGER(DNA)[0]) TAB_TRANS = tab_trans; else TAB_TRANS = tab_trans_aminoacid; double N = XLENGTH(x); xr = RAW(x); /* do a 1st pass to find the number of sequences this code should be robust to '>' present inside a label or in the header text before the sequences */ n = 0; k = 0; /* use k as a flag */ if (xr[0] == hook) { k = 1; startOfSeq = 0; } for (i = 1; i < N; i++) { if (k && xr[i] == lineFeed) { n++; k = 0; } else if (xr[i] == hook) { if (!n) startOfSeq = i; k = 1; } } if (n == 0) { PROTECT(obj = allocVector(INTSXP, 1)); INTEGER(obj)[0] = 0; UNPROTECT(3); return obj; } PROTECT(obj = allocVector(VECSXP, n)); PROTECT(nms = allocVector(STRSXP, n)); /* Refine the way the size of the buffer is set? */ buffer = (unsigned char *)R_alloc(N, sizeof(unsigned char)); i = (long) startOfSeq; j = 0; /* gives the index of the sequence */ while (i < N) { /* 1st read the label... */ i++; k = 0; while (xr[i] != lineFeed) buffer[k++] = xr[i++]; buffer[k] = '\0'; SET_STRING_ELT(nms, j, mkChar((char *)buffer)); /* ... then read the sequence */ n = 0; while (i < N && xr[i] != hook) { tmp = TAB_TRANS[xr[i++]]; /* If we are sure that the FASTA file is correct (ie, the sequence on a single line and only the IUAPC code (plus '-' and '?') is used, then the following check would not be needed; additionally the size of tab_trans could be restriced to 0-121. This check has the advantage that all invalid characters are simply ignored without causing error -- except if '>' occurs in the middle of a sequence. */ if (tmp) buffer[n++] = tmp; } PROTECT(seq = allocVector(RAWSXP, n)); rseq = RAW(seq); for (k = 0; k < n; k++) rseq[k] = buffer[k]; SET_VECTOR_ELT(obj, j, seq); UNPROTECT(1); j++; } setAttrib(obj, R_NamesSymbol, nms); UNPROTECT(4); return obj; } static const int BUFF = 1e9; #define WRITELABELS\ o[0] = hook; /* start with ">" */\ p = RAW(VECTOR_ELT(labels, i)); \ nchr = LENGTH(VECTOR_ELT(labels, i)); \ for (k = 1, w = 0; w < nchr; k++, w++) o[k] = p[w]; \ o[k++] = lineFeed; \ fwrite(o, 1, k, fl) SEXP writeDNAbinToFASTA(SEXP x, SEXP FILENAME, SEXP n, SEXP s, SEXP labels) { int i, w, k, nchr; const char *filename; FILE *fl; unsigned char *p, *px, *o; /* IMPORTANT: two distinct pointers *p and *px must be used, otherwise, this does not work correctly */ PROTECT(s = coerceVector(s, INTSXP)); int S = INTEGER(s)[0]; if (S != -1) /* x is a matrix */ PROTECT(x = coerceVector(x, RAWSXP)); else /* x is a list */ PROTECT(x = coerceVector(x, VECSXP)); PROTECT(labels = coerceVector(labels, VECSXP)); PROTECT(FILENAME = coerceVector(FILENAME, STRSXP)); PROTECT(n = coerceVector(n, INTSXP)); int nseq = INTEGER(n)[0]; filename = CHAR(STRING_ELT(FILENAME, 0)); fl = fopen(filename, "a+"); o = (unsigned char*)R_alloc(BUFF, sizeof(unsigned char)); /* the output stream */ SEXP res; PROTECT(res = allocVector(INTSXP, 1)); INTEGER(res)[0] = 0; if (S != -1) { /* x is a matrix */ px = RAW(x); for (i = 0; i < nseq; i++) { WRITELABELS; w = i; k = 0; while (k < S) { o[k++] = tab_trans_rev[px[w]]; w = w + nseq; //if (!((k + 1) % (COLW + 1))) o[k++] = lineFeed; } //if (o[k - 1] != 0x0a) o[k++] = lineFeed; o[k++] = lineFeed; fwrite(o, 1, k, fl); } } else { /* x is a list */ for (i = 0; i < nseq; i++) { WRITELABELS; int seql = XLENGTH(VECTOR_ELT(x, i)); p = RAW(VECTOR_ELT(x, i)); /* w: position where to start copy the bases to the output stream k: position in the output stream */ for (k = 0, w = 0; w < seql; w++) o[k++] = tab_trans_rev[p[w]]; //if (!((k + 1) % (COLW + 1))) o[k++] = lineFeed; //} //if (o[k - 1] != 0x0a) o[k++] = lineFeed; o[k++] = lineFeed; fwrite(o, 1, k, fl); } } fclose(fl); UNPROTECT(6); return res; } SEXP writeAAbinToFASTA(SEXP x, SEXP FILENAME, SEXP n, SEXP s, SEXP labels) { int i, w, k, nchr; const char *filename; FILE *fl; unsigned char *p, *px, *o; /* IMPORTANT: two distinct pointers *p and *px must be used, otherwise, this does not work correctly */ PROTECT(s = coerceVector(s, INTSXP)); int S = INTEGER(s)[0]; if (S != -1) /* x is a matrix */ PROTECT(x = coerceVector(x, RAWSXP)); else /* x is a list */ PROTECT(x = coerceVector(x, VECSXP)); PROTECT(labels = coerceVector(labels, VECSXP)); PROTECT(FILENAME = coerceVector(FILENAME, STRSXP)); PROTECT(n = coerceVector(n, INTSXP)); int nseq = INTEGER(n)[0]; filename = CHAR(STRING_ELT(FILENAME, 0)); fl = fopen(filename, "a+"); o = (unsigned char*)R_alloc(BUFF, sizeof(unsigned char)); /* the output stream */ SEXP res; PROTECT(res = allocVector(INTSXP, 1)); INTEGER(res)[0] = 0; if (S != -1) { /* x is a matrix */ px = RAW(x); for (i = 0; i < nseq; i++) { WRITELABELS; w = i; k = 0; while (k < S) { o[k++] = px[w]; w = w + nseq; } o[k++] = lineFeed; fwrite(o, 1, k, fl); } } else { /* x is a list */ for (i = 0; i < nseq; i++) { WRITELABELS; int seql = XLENGTH(VECTOR_ELT(x, i)); p = RAW(VECTOR_ELT(x, i)); /* w: position where to start copy the bases to the output stream k: position in the output stream */ for (k = 0, w = 0; w < seql; w++) o[k++] = p[w]; o[k++] = lineFeed; fwrite(o, 1, k, fl); } } fclose(fl); UNPROTECT(6); return res; } #undef WRITELABELS SEXP charVectorToDNAbinVector(SEXP x) { SEXP res; const char *xr; unsigned char *rs; PROTECT(x = coerceVector(x, STRSXP)); xr = CHAR(STRING_ELT(x, 0)); \ int n = strlen(xr); PROTECT(res = allocVector(RAWSXP, n)); rs = RAW(res); for (long i = 0; i < n; i++) rs[i] = tab_trans[(unsigned char) xr[i]]; UNPROTECT(2); return res; } ape/src/RcppExports.cpp0000644000176200001440000000355414164530562014620 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include using namespace Rcpp; #ifdef RCPP_USE_GLOBAL_ROSTREAM Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // bipartition2 std::vector< std::vector > bipartition2(IntegerMatrix orig, int nTips); RcppExport SEXP _ape_bipartition2(SEXP origSEXP, SEXP nTipsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< IntegerMatrix >::type orig(origSEXP); Rcpp::traits::input_parameter< int >::type nTips(nTipsSEXP); rcpp_result_gen = Rcpp::wrap(bipartition2(orig, nTips)); return rcpp_result_gen; END_RCPP } // prop_part2 List prop_part2(SEXP trees, int nTips); RcppExport SEXP _ape_prop_part2(SEXP treesSEXP, SEXP nTipsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< SEXP >::type trees(treesSEXP); Rcpp::traits::input_parameter< int >::type nTips(nTipsSEXP); rcpp_result_gen = Rcpp::wrap(prop_part2(trees, nTips)); return rcpp_result_gen; END_RCPP } // reorderRcpp IntegerVector reorderRcpp(IntegerMatrix orig, int nTips, int root, int order); RcppExport SEXP _ape_reorderRcpp(SEXP origSEXP, SEXP nTipsSEXP, SEXP rootSEXP, SEXP orderSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< IntegerMatrix >::type orig(origSEXP); Rcpp::traits::input_parameter< int >::type nTips(nTipsSEXP); Rcpp::traits::input_parameter< int >::type root(rootSEXP); Rcpp::traits::input_parameter< int >::type order(orderSEXP); rcpp_result_gen = Rcpp::wrap(reorderRcpp(orig, nTips, root, order)); return rcpp_result_gen; END_RCPP } ape/src/tree_phylo.c0000644000176200001440000000360714164530562014140 0ustar liggesusers/* tree_phylo.c 2012-04-30 */ /* Copyright 2008-2012 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" static int curnod, curtip, iedge; #define DO_EDGE\ el[iedge] = EDGE->distance;\ if (leaf(EDGE->head)) {\ edge2[iedge] = curtip;\ ilab[curtip - 1] = EDGE->head->label;\ iedge++;\ curtip++;\ } else {\ edge2[iedge] = curnod;\ iedge++;\ subtree2phylo(EDGE->head, edge1, edge2, el, ilab);\ } int leaf(node *v) { int count = 0; if (NULL != v->parentEdge) count++; if (NULL != v->leftEdge) count++; if (NULL != v->rightEdge) count++; if (NULL != v->middleEdge) count++; if (count > 1) return(0); return(1); } void subtree2phylo(node *parent, int *edge1, int *edge2, double *el, int *ilab) { edge *EDGE; int localnode; EDGE = parent->leftEdge; /* 'localnode' keeps a copy of the node ancestor # between the two (recursive) calls of subtree2phylo */ localnode = edge1[iedge] = curnod; curnod++; DO_EDGE EDGE = parent->rightEdge; edge1[iedge] = localnode; DO_EDGE } /* transforms a 'tree' struc of pointers into an object of class "phylo" assumes the tree is unrooted and binary, so there are 2n - 3 edges assumes labels are int */ void tree2phylo(tree *T, int *edge1, int *edge2, double *el, int *ilab, int n) { edge *EDGE; curnod = n + 1; /* the root for ape */ /* there's in fact only one edge from the "root" which is a tip in ape's terminology (i.e., a node of degree 1) */ EDGE = T->root->leftEdge; edge1[0] = curnod; edge2[0] = 1; /* <- the 1st tip */ ilab[0] = T->root->label; el[0] = EDGE->distance; /* now can initialize these two: */ curtip = 2; /* <- the 2nd tip */ iedge = 1; /* <- the 2nd edge */ edge1[iedge] = curnod; /* 'T->root->leftEdge->head' is the root for ape, so don't need to test if it's a leaf */ subtree2phylo(EDGE->head, edge1, edge2, el, ilab); } ape/src/reorder_phylo.c0000644000176200001440000000436714164530562014647 0ustar liggesusers/* reorder_phylo.c 2021-04-07 */ /* Copyright 2008-2021 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #define DO_NODE_PRUNING\ /* go back down in `edge' to set `neworder' */\ for (j = 0; j <= i; j++) {\ /* if find the edge where `node' is */\ /* the descendant, make as ready */\ if (edge2[j] == node) ready[j] = 1;\ if (edge1[j] != node) continue;\ neworder[nextI] = j + 1;\ ready[j] = 0; /* mark the edge as done */\ nextI++;\ } void neworder_pruningwise(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, int *neworder) { int *ready, *Ndegr, i, j, node, nextI, n; nextI = *ntip + *nnode; Ndegr = (int*)R_alloc(nextI, sizeof(int)); memset(Ndegr, 0, nextI*sizeof(int)); for (i = 0; i < *nedge; i++) (Ndegr[edge1[i] - 1])++; ready = (int*)R_alloc(*nedge, sizeof(int)); /* `ready' indicates whether an edge is ready to be */ /* collected; only the terminal edges are initially ready */ for (i = 0; i < *nedge; i++) ready[i] = (edge2[i] <= *ntip) ? 1 : 0; /* `n' counts the number of times a node has been seen. */ /* This algo will work if the tree is in cladewise order, */ /* so that the nodes of "cherries" will be contiguous in `edge'. */ n = 0; nextI = 0; while (nextI < *nedge - Ndegr[*ntip]) { for (i = 0; i < *nedge; i++) { if (!ready[i]) continue; if (!n) { /* if found an edge ready, initialize `node' and start counting */ node = edge1[i]; n = 1; } else { /* else counting has already started */ if (edge1[i] == node) n++; else { /* if the node has changed we checked that all edges */ /* from `node' have been found */ if (n == Ndegr[node - 1]) { DO_NODE_PRUNING } /* in all cases reset `n' and `node' and carry on */ node = edge1[i]; n = 1; } } /* go to the next edge */ /* if at the end of `edge', check that we can't do a node */ if (n == Ndegr[node - 1]) { DO_NODE_PRUNING n = 0; } } } for (i = 0; i < *nedge; i++) { if (!ready[i]) continue; neworder[nextI] = i + 1; nextI++; } } ape/vignettes/0000755000176200001440000000000014164530667013043 5ustar liggesusersape/vignettes/DrawingPhylogenies.Rnw0000644000176200001440000012244714164530562017341 0ustar liggesusers\documentclass[a4paper]{article} %\VignetteIndexEntry{Drawing Phylogenies} %\VignettePackage{ape} \usepackage{ape} \author{Emmanuel Paradis} \title{Drawing Phylogenies in \R: Basic and Advanced Features With \pkg{ape}} \begin{document} \DefineVerbatimEnvironment{Sinput}{Verbatim}{formatcom=\color{darkblue}} \DefineVerbatimEnvironment{Soutput}{Verbatim}{formatcom=\color{black}\vspace{-1.5em}} \maketitle \tableofcontents\vspace*{1pc}\hrule <>= options(width = 80, prompt = "> ") @ \vspace{1cm} \section{Introduction} Graphical functions have been present in \ape\ since its first version (0.1, released in August 2002). Over the years, these tools have been improved to become quite sophisticated although complicated to use efficiently. This document gives an overview of these functionalities. Section~\ref{sec:basic} explains the basic concepts and tools behind graphics in \ape. A figure made with \ape\ usually starts by calling the function \code{plot.phylo} which is detailed in Section~\ref{sec:plotphylo}, and further graphical annotations can be done with functions covered in Section~\ref{sec:annot}. Section~\ref{sec:spec} shows some specialized functions available in \ape, and finally, Sections~\ref{sec:geom} and \ref{sec:build} give an overview of some ideas to help making complicated figures. \section{Basic Concepts}\label{sec:basic} The core of \ape's graphical tools is the \code{plot} method for the class \code{"phylo"}, the function \code{plot.phylo}. This function is studied in details in Section~\ref{sec:plotphylo}, but first we see the basic ideas behind it and other functions mentioned in this document. \subsection{Graphical Model} The graphical functions in \ape\ use the package \pkg{graphics}. Overall, the conventions of this package are followed quite closely (see Murrell's book \cite{Murrell2006}), so users familiar with graphics in \R\ are expected to find their way relatively easily when plotting phylogenies with \ape. \ape\ has several functions to perform computations before drawing a tree, so that they may be used to implement the same graphical functionalities with other graphical engines such as the \pkg{grid} package. These functions are detailed in the next section. To start simply, we build a small tree with three genera of primates which we will use in several examples in this document: <<>>= library(ape) mytr <- read.tree(text = "((Pan:5,Homo:5):2,Gorilla:7);") @ \noindent Now let's build a small function to show the frame around the plot with dots, and the $x$- and $y$-axes in green: <<>>= foo <- function() { col <- "green" for (i in 1:2) axis(i, col = col, col.ticks = col, col.axis = col, las = 1) box(lty = "19") } @ \noindent We then plot the tree in four different ways (see below for explanations about the options) and call for each of them the previous small function: <>= layout(matrix(1:4, 2, 2, byrow = TRUE)) plot(mytr); foo() plot(mytr, "c", FALSE); foo() plot(mytr, "u"); foo() par(xpd = TRUE) plot(mytr, "f"); foo() box("outer") @ \noindent The last command (\code{box("outer")}) makes visible the most outer frame of the figure showing more clearly the margins around each tree (more on this in Sect.~\ref{sec:geom}). We note also the command \code{par(xpd = TRUE)}: by default this parameter is \code{FALSE} so that graphical elements (points, lines, text, \dots) outside the plotting region (i.e., in the margins or beyond) are cut (clipped).\footnote{\code{par(xpd = TRUE)} is used in several examples in this document mainly because of the small size of the trees drawn here. However, in practice, this is rarely needed.} These small figures illustrate the way trees are drawn with \ape. This can be summarised with the following (pseudo-)algorithm: \bigskip\hrule height 1pt\relax %\renewcommand{\theenumi}{\alph{enumi}} \renewcommand{\labelenumi}{\textbf{\theenumi.}} \begin{enumerate}\small \item Compute the node coordinates depending on the type of tree plot, the branch lengths, and other parameters. \item Evaluate the space required for printing the tip labels. \item Depending on the options, do some rotations and/or translations. \item Set the limits of the $x$- and $y$-axes. \item Open a graphical device (or reset it if already open) and draw an empty plot with the limits found at the previous step. \item Call \code{segments()} to draw the branches. \item Call \code{text()} to draw the labels. \end{enumerate} \hrule height 1pt\relax\bigskip There are a lot of ways to control these steps. The main variations along these steps are given below. \textbf{Step 1. } The option \code{type} specifies the shape of the tree plot: five values are possible, \code{"phylogram"}, \code{"cladogram"}, \code{"fan"}, \code{"unrooted"}, and \code{"radial"} (the last one is not considered in this document). The first three types are valid representations for rooted trees, while the fourth one should be selected for unrooted trees. The node coordinates depend also on whether the tree has branch lengths or not, and on the options \code{node.pos} and \code{node.depth}. This is illustrated below using a tree with eight tips and all branch length equal to one (these options have little effect if the tree has only three tips): <<>>= tr <- compute.brlen(stree(8, "l"), 0.1) tr$tip.label[] <- "" @ \noindent We now draw this tree using the option \code{type = "phylogram"} (first column of plots) or \code{type = "cladogram"} (second column) and different options: <>= foo <- function() { col <- "green" axis(1, col = col, col.ticks = col, col.axis = col) axis(2, col = col, col.ticks = col, col.axis = col, at = 1:Ntip(tr), las = 1) box(lty = "19") } @ <<>>= @ <>= layout(matrix(1:12, 6, 2)) par(mar = c(2, 2, 0.3, 0)) for (type in c("p", "c")) { plot(tr, type); foo() plot(tr, type, node.pos = 2); foo() plot(tr, type, FALSE); foo() plot(tr, type, FALSE, node.pos = 1, node.depth = 2); foo() plot(tr, type, FALSE, node.pos = 2); foo() plot(tr, type, FALSE, node.pos = 2, node.depth = 2); foo() } @ \noindent Some combinations of options may result in the same tree shape as shown by the last two rows of trees. For unrooted and circular trees, only the option \code{use.edge.length} has an effect on the layout and/or the scales of the axes: <>= foo <- function() { col <- "green" for (i in 1:2) axis(i, col = col, col.ticks = col, col.axis = col, las = 1) box(lty = "19") } @ <>= layout(matrix(1:4, 2, 2)) par(las = 1) plot(tr, "u"); foo() plot(tr, "u", FALSE); foo() plot(tr, "f"); foo() plot(tr, "f", FALSE); foo() @ \textbf{Step 2.} In the \pkg{graphics} package, text are printed with a fixed size, which means that whether you draw a small tree or a large tree, on a small or large device, the labels will have the same size. However, before anything is plotted or drawn on the device it is difficult to find the correspondence between this size (in inches) and the user coordinates used for the node coordinates. Therefore, the following steps are implemented to determine the limits on the $x$-axis: \renewcommand{\labelenumi}{\theenumi.} \begin{enumerate} \item Find the width of the device in inches (see Sect.~\ref{sec:overlay}). \item Find the widths of all labels in inches: if at least one of them is wider than the device, assign two thirds of the device for the branches and one third to the tip labels. (This makes sure that by default the tree is visible in the case there are very long tip labels.) \item Otherwise, the space allocated to the tip labels is increased incrementally until all labels are visible on the device. \end{enumerate} The limits on the $y$-axis are easier to determine since it depends only on the number of branches in the tree. The limits on both axes can be changed manually with the options \code{x.lim} and \code{y.lim} which take one or two values: if only one value is given this will set the rightmost or uppermost limit, respectively; if two values are given these will set both limits on the respecive axis.\footnote{These two options differ from their standard counterparts \code{xlim} and \code{ylim} which always require two values.} By default, there is no space between the tip labels and the tips of the terminal branches; however, text strings are printed with a bounding box around them making sure there is actually a small space (besides, the default font is italics making this space more visible). The option \code{label.offset} (which is 0 by default) makes possible to add an explicit space between them (this must be in user coordinates). \textbf{Step 3.} For rooted trees, only 90\textdegree\ rotations are supported using the option \code{direction}.\footnote{To have full control of the tree rotation, the option `rotate' in \LaTeX\ does the job very well.} For unrooted (\code{type = "u"}) and circular (\code{type = "fan"}) trees, full rotation is supported with the option \code{rotate.tree}. If these options are used, the tip labels are not rotated. Label rotation is controlled by other options: \code{srt}\footnote{\code{srt} is for \textit{string rotation}, not to be confused with the function \code{str} to print the \textit{structure} of an object.} for all trees, and \code{lab4ut} for unrooted trees. \textbf{Step 4.} These can be fully controlled with the options \code{x.lim} and \code{y.lim}. Note that the options \code{xlim} and \code{ylim} \emph{cannot} be used from \code{plot.phylo}. \textbf{Step 5.} If the options \code{plot = FALSE} is used, then steps 6 and 7 are not performed. \subsection{Computations}\label{sec:comput} As we can see from the previous section, a lot of computations are done before a tree is plotted. Some of these computations are performed by special functions accessible to all users, particularly the three functions used to calculate the node coordinates. First, two functions calculate ``node depths'' which are the coordinates of the nodes on the $x$-axis for rooted trees: <<>>= args(node.depth.edgelength) args(node.depth) @ \noindent Here, \code{phy} is an object of class \code{"phylo"}. The first function uses edge lengths to calculate these coordinates, while the second one calculates these coordinates proportional to the number of tips descending from each node (if \code{method = 1}), or evenly spaced (if \code{method = 2}). The third function is \code{node.height} and is used to calculate ``node heights'', the coordinates of the nodes on the $y$-axis: <<>>= args(node.height) @ \noindent If \code{clado.style = TRUE}, the node heights are calculated for a ``triangular cladogram'' (see figure above). Otherwise, by default they are calculated to fall in the middle of the vertical segments with the default \code{type = "phylogram"}.\footnote{It may be good to remind here than these segments, vertical since \code{direction = "rightwards"} is the default, are not part of the edges of the tree.} For unrooted trees, the node coordinates are calculated with the ``equal angle'' algorithm described by Felsenstein \cite{Felsenstein2004}. This is done by an internal function which arguments are: <<>>= args(unrooted.xy) @ \noindent There are three other internal functions used to plot the segments of the tree after the above calculations have been performed (steps 1--4 in the previous section): <<>>= args(phylogram.plot) args(cladogram.plot) args(circular.plot) @ \noindent Although these four functions are not formally documented, they are anyway exported because they are used by several packages outside \ape. \section{The \code{plot.phylo} Function}\label{sec:plotphylo} The \code{plot} method for \code{"phylo"} objects follows quite closely the \R\ standard practice. It has a relatively large number of arguments: the first one (\code{x}) is mandatory and is the tree to be drawn. It is thus not required to name it, so in practice the tree \code{tr} can be plotted with the command \code{plot(tr)}. All other arguments have default values: <<>>= args(plot.phylo) @ \noindent The second and third arguments are the two commonly used in practice, so they can be modified without explicitly naming them like in the above examples. Besides, \code{"cladogram"} can be abbreviated with \code{"c"}, \code{"unrooted"} with \code{"u"}, and so on. For the other arguments, it is better to name them if they are used or modified (e.g., \code{lab4ut = "a"}). \subsection{Overview on the Options} The logic of this long list of options is double: the user can modify the aspect of the tree plot, and/or use some of these options to display some data in association with the tree. Therefore, the table below group these options into three categories. The following two sections show how data can be displayed in connection to the tips or to the branches of the tree. \begin{center} \begin{tabular}{lll} \toprule Aspect of the tree & Attributes of the labels & Attributes of the edges\\ \midrule \code{type} & \code{show.tip.label} & \code{edge.color}\\ \code{use.edge.length} & \code{show.node.label} & \code{edge.width}\\ \code{node.pos} & \code{font} & \code{edge.lty}\\ \code{x.lim} & \code{tip.color}\\ \code{y.lim} & \code{cex}\\ \code{direction} & \code{adj}\\ \code{no.margin} & \code{underscore}\\ \code{root.edge} & \code{srt}\\ \code{rotate.tree} & \code{lab4ut}\\ \code{open.angle} & \code{label.offset}\\ \code{node.depth} & \code{align.tip.label}\\ \bottomrule \end{tabular} \end{center} \subsection{Connecting Data to the Tips} It is common that some data are associated with the tips of a tree: body mass, population, treatment, \dots\ The options \code{font}, \code{tip.color}, and \code{cex} make possible to show this kind of information by changing the font (normal, bold, italics, or bold-italics), the colour, or the size of the tip labels, or any combination of these. These three arguments work in the usual \R\ way: they can a vector of any length whose values are eventually recycled if this length is less than the number of tips. This makes possible to change all tips if a single value is given. For instance, consider the small primate tree where we want to show the geographic distributions stored in a factor: <<>>= geo <- factor(c("Africa", "World", "Africa")) @ \noindent We can define a color for each region and use the above factor as a numeric index vector and pass it to \code{tip.color}: \begin{center} \setkeys{Gin}{width=.5\textwidth} <>= (mycol <- c("blue", "red")[geo]) plot(mytr, tip.color = mycol) @ \end{center} The values must be in the same order than in the vector of tip labels, here \code{mytr\$tip.label}. Reordering can be done in the usual \R\ way (e.g., with \code{names} or with \code{row.names} if the data are in a data frame). This can be combined with another argument, for instance to show (relative) body size: \begin{center} \setkeys{Gin}{width=.5\textwidth} <>= par(xpd = TRUE) plot(mytr, tip.color = mycol, cex = c(1, 1, 1.5)) @ \end{center} The function \code{def} gives another way to define the above arguments given a vector of labels (\code{x}): <<>>= args(def) @ \noindent The `\code{...}' are arguments separated by commas of the form \code{\textsl{

Files sorted by directory (in new tab)


') for (type in filetypes) { nr <- NR[type] mycat('

', toupper(type), '

') if (nr == 0) { mycat('no file of this type') next } DF <- FILES[[type]] mycat('') mycat('') for (i in 1:nr) mycat('') mycat('
File name Size (KB)
', DF[i, 1], '', round(DF[i, 2]/1000, 1), '
') } mycat('') browseURL(OUT) } .bydir.html <- function(x) { nofile <- which(sapply(x, nrow) == 0) if (length(nofile)) x <- x[-nofile] if (!length(x)) return(NULL) for (i in seq_along(x)) x[[i]]$Type <- names(x)[i] x <- do.call(rbind, x) x <- x[order(x$File), ] SPLIT <- strsplit(x$File, "/") LL <- lengths(SPLIT) foo <- function(i, PATH) { K <- grep(paste0("^", PATH, "/"), x$File) sel <- intersect(K, which(LL == i + 1L)) if (length(sel)) { y <- x[sel, ] y$File <- gsub(".*/", "", y$File) cat('

', PATH, '/

', sep = "") cat('') cat('') for (i in 1:nrow(y)) cat('', sep = "") cat('
File Size (KB) Type
', y[i, 1], '', round(y[i, 2]/1000, 1), '', y[i, 3], '

') } if (length(sel) < length(K)) { d <- setdiff(K, sel) subdir <- unlist(lapply(SPLIT[d], "[", i + 1L)) for (z in unique(subdir)) foo(i + 1L, paste(PATH, z, sep = "/")) } } top <- unlist(lapply(SPLIT, "[", 1L)) for (z in unique(top)) foo(1L, z) } ape/R/dist.topo.R0000644000176200001440000003403414164530562013300 0ustar liggesusers## dist.topo.R (2021-04-18) ## Topological Distances, Tree Bipartitions, ## Consensus Trees, and Bootstrapping Phylogenies ## Copyright 2005-2021 Emmanuel Paradis, 2016-2021 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .getTreesFromDotdotdot <- function(...) { obj <- list(...) if (length(obj) == 1 && !inherits(obj[[1]], "phylo")) obj <- obj[[1]] obj } dist.topo <- function(x, y = NULL, method = "PH85") { method <- match.arg(method, c("PH85", "score")) if (!is.null(y)) x <- c(x, y) testroot <- any(is.rooted(x)) n <- length(x) # number of trees res <- numeric(n * (n - 1) /2) nms <- names(x) if (is.null(nms)) nms <- paste0("tree", 1:n) if (method == "PH85") { if (testroot) warning("Some trees were rooted: topological distances may be spurious.") x <- .compressTipLabel(x) ntip <- length(attr(x, "TipLabel")) nnode <- sapply(x, Nnode) foo <- function(phy, ntip) { phy <- reorder(phy, "postorder") pp <- bipartition2(phy$edge, ntip) attr(pp, "labels") <- phy$tip.label ans <- SHORTwise(pp) sapply(ans, paste, collapse = "\r") } x <- lapply(x, foo, ntip = ntip) k <- 0L for (i in 1:(n - 1)) { y <- x[[i]] m1 <- nnode[i] for (j in (i + 1):n) { z <- x[[j]] k <- k + 1L res[k] <- m1 + nnode[j] - 2 * sum(z %in% y) } } } else { # method == "score" k <- 0L for (i in 1:(n - 1)) { for (j in (i + 1):n) { k <- k + 1L ## still very slow...... res[k] <- .dist.topo.score(x[[i]], x[[j]]) } } } attr(res, "Size") <- n attr(res, "Labels") <- nms attr(res, "Diag") <- attr(res, "Upper") <- FALSE attr(res, "method") <- method class(res) <- "dist" res } .dist.topo.score <- function(x, y) { if (is.null(x$edge.length) || is.null(y$edge.length)) stop("trees must have branch lengths for branch score distance.") nx <- length(x$tip.label) x <- reorder.phylo(unroot(x), "postorder") y <- reorder.phylo(unroot(y), "postorder") ##bp1 <- .Call(bipartition, x$edge, nx, x$Nnode) bp1 <- bipartition2(x$edge, nx) bp1 <- lapply(bp1, function(xx) sort(x$tip.label[xx])) ny <- length(y$tip.label) # fix by Otto Cordero ## fix by Tim Wallstrom: bp2.tmp <- bipartition2(y$edge, ny) ##bp2.tmp <- .Call(bipartition, y$edge, ny, y$Nnode) bp2 <- lapply(bp2.tmp, function(xx) sort(y$tip.label[xx])) bp2.comp <- lapply(bp2.tmp, function(xx) setdiff(1:ny, xx)) bp2.comp <- lapply(bp2.comp, function(xx) sort(y$tip.label[xx])) ## End q1 <- length(bp1) q2 <- length(bp2) dT <- 0 found1 <- FALSE found2 <- logical(q2) found2[1] <- TRUE for (i in 2:q1) { for (j in 2:q2) { if (identical(bp1[[i]], bp2[[j]]) | identical(bp1[[i]], bp2.comp[[j]])) { dT <- dT + (x$edge.length[which(x$edge[, 2] == nx + i)] - y$edge.length[which(y$edge[, 2] == ny + j)])^2 found1 <- found2[j] <- TRUE break } } if (found1) found1 <- FALSE else dT <- dT + (x$edge.length[which(x$edge[, 2] == nx + i)])^2 } if (!all(found2)) dT <- dT + sum((y$edge.length[y$edge[, 2] %in% (ny + which(!found2))])^2) sqrt(dT) } .compressTipLabel <- function(x, ref = NULL) { ## 'x' is a list of objects of class "phylo" possibly with no class if (!is.null(attr(x, "TipLabel"))) return(x) if (is.null(ref)) ref <- x[[1]]$tip.label n <- length(ref) if (length(unique(ref)) != n) stop("some tip labels are duplicated in tree no. 1") ## serious improvement by Joseph W. Brown! relabel <- function (y) { label <- y$tip.label if (!identical(label, ref)) { if (length(label) != length(ref)) stop("one tree has a different number of tips") ilab <- match(label, ref) if (any(is.na(ilab))) stop("one tree has different tip labels") ie <- match(1:n, y$edge[, 2]) y$edge[ie, 2] <- ilab } y$tip.label <- NULL y } x <- unclass(x) # another killer improvement by Tucson's hackathon (1/2/2013) x <- lapply(x, relabel) attr(x, "TipLabel") <- ref class(x) <- "multiPhylo" x } prop.part <- function(..., check.labels = TRUE) { obj <- .getTreesFromDotdotdot(...) ntree <- length(obj) if (ntree == 1) check.labels <- FALSE if (check.labels) obj <- .compressTipLabel(obj) # fix by Klaus Schliep (2011-02-21) class(obj) <- NULL # fix by Klaus Schliep (2014-03-06) for (i in 1:ntree) storage.mode(obj[[i]]$Nnode) <- "integer" class(obj) <- "multiPhylo" obj <- reorder(obj, "postorder") # the following line should not be necessary any more # obj <- .uncompressTipLabel(obj) # fix a bug (2010-11-18) nTips <- length(obj[[1]]$tip.label) clades <- prop_part2(obj, nTips) attr(clades, "labels") <- obj[[1]]$tip.label clades } print.prop.part <- function(x, ...) { if (is.null(attr(x, "labels"))) { for (i in 1:length(x)) { cat("==>", attr(x, "number")[i], "time(s):") print(x[[i]], quote = FALSE) } } else { for (i in 1:length(attr(x, "labels"))) cat(i, ": ", attr(x, "labels")[i], "\n", sep = "") cat("\n") for (i in 1:length(x)) { cat("==>", attr(x, "number")[i], "time(s):") print(x[[i]], quote = FALSE) } } } summary.prop.part <- function(object, ...) attr(object, "number") plot.prop.part <- function(x, barcol = "blue", leftmar = 4, col = "red", ...) { if (is.null(attr(x, "labels"))) stop("cannot plot this partition object; see ?prop.part for details.") L <- length(x) n <- length(attr(x, "labels")) layout(matrix(1:2, 2, 1), heights = c(1, 3)) par(mar = c(0.1, leftmar, 0.1, 0.1)) one2L <- seq_len(L) plot(one2L - 0.5, attr(x, "number"), type = "h", col = barcol, xlim = c(0, L), xaxs = "i", xlab = "", ylab = "Frequency", xaxt = "n", bty = "n", ...) M <- matrix(0L, L, n) for (i in one2L) M[i, x[[i]]] <- 1L image.default(one2L, 1:n, M, col = c("white", col), xlab = "", ylab = "", yaxt = "n") mtext(attr(x, "labels"), side = 2, at = 1:n, las = 1) } ### by Klaus (2016-03-23): prop.clades <- function(phy, ..., part = NULL, rooted = FALSE) { if (is.null(part)) { obj <- .getTreesFromDotdotdot(...) ## avoid double counting of edges if trees are rooted if (!rooted) obj <- lapply(obj, unroot) part <- prop.part(obj, check.labels = TRUE) } LABS <- attr(part, "labels") if (!identical(phy$tip.label, LABS)) { i <- match(phy$tip.label, LABS) j <- match(seq_len(Ntip(phy)), phy$edge[, 2]) phy$edge[j, 2] <- i phy$tip.label <- LABS } bp <- prop.part(phy) if (!rooted) { ## avoid messing up the order and length if phy is rooted in some cases bp <- SHORTwise(bp) part <- postprocess.prop.part(part, "SHORTwise") } pos <- match(bp, part) tmp <- which(!is.na(pos)) n <- rep(NA_real_, phy$Nnode) n[tmp] <- attr(part, "number")[pos[tmp]] n } boot.phylo <- function(phy, x, FUN, B = 100, block = 1, trees = FALSE, quiet = FALSE, rooted = is.rooted(phy), jumble = TRUE, mc.cores = 1) { if (is.null(dim(x)) || length(dim(x)) != 2) stop("the data 'x' must have two dimensions (e.g., a matrix or a data frame)") if (anyDuplicated(rownames(x))) stop("some labels are duplicated in the data: you won't be able to analyse tree bipartitions") boot.tree <- vector("list", B) y <- nc <- ncol(x) nr <- nrow(x) if (nr < 4 && !trees) { warning("not enough rows in 'x' to compute bootstrap values.\nSet 'trees = TRUE' if you want to get the bootstrap trees") return(integer()) } if (block > 1) { a <- seq(1, nc - 1, block) b <- seq(block, nc, block) y <- mapply(":", a, b, SIMPLIFY = FALSE) getBootstrapIndices <- function() unlist(sample(y, replace = TRUE)) } else getBootstrapIndices <- function() sample.int(y, replace = TRUE) if (!quiet) { prefix <- "\rRunning bootstraps: " suffix <- paste("/", B) updateProgress <- function(i) cat(prefix, i, suffix) } if (mc.cores == 1) { for (i in 1:B) { boot.samp <- x[, getBootstrapIndices()] if (jumble) boot.samp <- boot.samp[sample.int(nr), ] boot.tree[[i]] <- FUN(boot.samp) if (!quiet && !(i %% 100)) updateProgress(i) } } else { if (!quiet) cat("Running parallel bootstraps...") foo <- function(i) { boot.samp <- x[, getBootstrapIndices()] if (jumble) boot.samp <- boot.samp[sample.int(nr), ] FUN(boot.samp) } boot.tree <- mclapply(1:B, foo, mc.cores = mc.cores) if (!quiet) cat(" done.") } if (nr < 4 && trees) return(list(BP = integer(), trees = boot.tree)) if (!quiet) cat("\nCalculating bootstrap values...") ## sort labels after mixed them up if (jumble) { boot.tree <- .compressTipLabel(boot.tree, ref = phy$tip.label) boot.tree <- .uncompressTipLabel(boot.tree) boot.tree <- unclass(boot.tree) # otherwise countBipartitions crashes } class(boot.tree) <- "multiPhylo" if (rooted) { pp <- prop.part(boot.tree) ans <- prop.clades(phy, part = pp, rooted = rooted) } else { phy <- reorder(phy, "postorder") ints <- phy$edge[, 2] > Ntip(phy) ans <- countBipartitions(phy, boot.tree) ans <- c(NA_integer_, ans[order(phy$edge[ints, 2])]) } if (!quiet) cat(" done.\n") if (trees) ans <- list(BP = ans, trees = boot.tree) ans } ### The next function transforms an object of class "prop.part" so ### that the vectors which are identical in terms of splits are aggregated. ### For instance if n = 5 tips, 1:2 and 3:5 actually represent the same ### split though they are different clades. The aggregation is done ### arbitrarily. ### The call to SHORTwise() insures that all splits are the shortest ones. ### The call to ONEwise() insures that all splits include the first tip. ### (rewritten by Klaus) postprocess.prop.part <- function(x, method = "ONEwise") { w <- attr(x, "number") labels <- attr(x, "labels") method <- match.arg(toupper(method), c("ONEWISE", "SHORTWISE")) FUN <- switch(method, "ONEWISE" = ONEwise, "SHORTWISE" = SHORTwise) x <- FUN(x) drop <- duplicated(x) if (any(drop)) { ind1 <- match(x[drop], x) ind2 <- which(drop) for (i in seq_along(ind2)) w[ind1[i]] <- w[ind1[i]] + w[ind2[i]] x <- x[!drop] w <- w[!drop] } attr(x, "number") <- w attr(x, "labels") <- labels class(x) <- "prop.part" x } ### This function changes an object of class "prop.part" so that they ### all include the first tip. For instance if n = 5 tips, 3:5 is ### changed to 1:2. ONEwise <- function(x) { nTips <- length(attr(x, "labels")) v <- seq_len(nTips) l <- lengths(x) == 0 if (any(l)) x[l] <- list(v) for (i in which(!l)) { y <- x[[i]] if (y[1] != 1) x[[i]] <- v[-y] } x } ### This function changes an object of class "prop.part" so that they ### all include the shorter part of the partition. ### For instance if n = 5 tips, 1:3 is changed to 4:5. In case n is even, e.g. ### n = 6 similar to ONEwise. SHORTwise <- function(x) { ## ensures the next line should also work for splits objects from phangorn nTips <- length(attr(x, "labels")) v <- seq_len(nTips) l <- lengths(x) lv <- nTips / 2 for (i in which(l >= lv)) { y <- x[[i]] if (l[i] > lv) { x[[i]] <- v[-y] } else { # (l[i] == lv) only possible alternative if (y[1] != 1) x[[i]] <- v[-y] } } x } consensus <- function(..., p = 1, check.labels = TRUE, rooted = FALSE) { foo <- function(ic, node) { ## ic: index of 'pp' ## node: node number in the final tree pool <- pp[[ic]] if (ic < m) { for (j in (ic + 1):m) { wh <- match(pp[[j]], pool) if (!any(is.na(wh))) { edge[pos, 1] <<- node pool <- pool[-wh] edge[pos, 2] <<- nextnode <<- nextnode + 1L pos <<- pos + 1L foo(j, nextnode) } } } size <- length(pool) if (size) { ind <- pos:(pos + size - 1) edge[ind, 1] <<- node edge[ind, 2] <<- pool pos <<- pos + size } } obj <- .getTreesFromDotdotdot(...) if (!is.null(attr(obj, "TipLabel"))) labels <- attr(obj, "TipLabel") else { labels <- obj[[1]]$tip.label if (check.labels) obj <- .compressTipLabel(obj) } if(!rooted) obj <- root(obj, 1) ntree <- length(obj) ## Get all observed partitions and their frequencies: pp <- prop.part(obj, check.labels = FALSE) ## Drop the partitions whose frequency is less than 'p': if (p == 0.5) p <- 0.5000001 # avoid incompatible splits bs <- attr(pp, "number") pp <- pp[bs >= p * ntree] bs <- bs[bs >= p * ntree] ## Get the order of the remaining partitions by decreasing size: ind <- order(lengths(pp), decreasing = TRUE) pp <- pp[ind] bs <- bs[ind] n <- length(labels) m <- length(pp) edge <- matrix(0L, n + m - 1, 2) if (m == 1) { edge[, 1] <- n + 1L edge[, 2] <- 1:n } else { nextnode <- n + 1L pos <- 1L foo(1, nextnode) } structure(list(edge = edge, tip.label = labels, node.label = bs/ntree, Nnode = m), class = "phylo") } ape/R/MoranI.R0000644000176200001440000001562214164530562012544 0ustar liggesusers## MoranI.R (2008-01-14) ## Moran's I Autocorrelation Index ## Copyright 2004 Julien Dutheil, 2007-2008 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. ## code cleaned-up by EP (Dec. 2007) Moran.I <- function(x, weight, scaled = FALSE, na.rm = FALSE, alternative = "two.sided") { if(dim(weight)[1] != dim(weight)[2]) stop("'weight' must be a square matrix") n <- length(x) if(dim(weight)[1] != n) stop("'weight' must have as many rows as observations in 'x'") ## Expected mean: ei <- -1/(n - 1) nas <- is.na(x) if (any(nas)) { if (na.rm) { x <- x[!nas] n <- length(x) weight <- weight[!nas, !nas] } else { warning("'x' has missing values: maybe you wanted to set na.rm = TRUE?") return(list(observed = NA, expected = ei, sd = NA, p.value = NA)) } } ## normalizing the weights: ## Note that we normalize after possibly removing the ## missing data. ROWSUM <- rowSums(weight) ## the following is useful if an observation has no "neighbour": ROWSUM[ROWSUM == 0] <- 1 weight <- weight/ROWSUM # ROWSUM is properly recycled s <- sum(weight) m <- mean(x) y <- x - m # centre the x's cv <- sum(weight * y %o% y) v <- sum(y^2) obs <- (n/s) * (cv/v) ## Scaling: if (scaled) { i.max <- (n/s) * (sd(rowSums(weight) * y)/sqrt(v/(n - 1))) obs <- obs/i.max } ## Expected sd: S1 <- 0.5 * sum((weight + t(weight))^2) S2 <- sum((apply(weight, 1, sum) + apply(weight, 2, sum))^2) ## the above is the same than: ##S2 <- 0 ##for (i in 1:n) ## S2 <- S2 + (sum(weight[i, ]) + sum(weight[, i]))^2 s.sq <- s^2 k <- (sum(y^4)/n) / (v/n)^2 sdi <- sqrt((n*((n^2 - 3*n + 3)*S1 - n*S2 + 3*s.sq) - k*(n*(n - 1)*S1 - 2*n*S2 + 6*s.sq))/ ((n - 1)*(n - 2)*(n - 3)*s.sq) - 1/((n - 1)^2)) alternative <- match.arg(alternative, c("two.sided", "less", "greater")) pv <- pnorm(obs, mean = ei, sd = sdi) if (alternative == "two.sided") pv <- if (obs <= ei) 2*pv else 2*(1 - pv) if (alternative == "greater") pv <- 1 - pv list(observed = obs, expected = ei, sd = sdi, p.value = pv) } weight.taxo <- function(x) { d <- outer(x, x, "==") diag(d) <- 0 # implicitly converts 'd' into numeric d } weight.taxo2 <- function(x, y) { d <- outer(x, x, "==") & outer(y, y, "!=") diag(d) <- 0 d } correlogram.formula <- function(formula, data = NULL, use = "all.obs") { err <- 'formula must be of the form "y1+...+yn ~ x1/x2/../xn"' use <- match.arg(use, c("all.obs", "complete.obs", "pairwise.complete.obs")) if (formula[[1]] != "~") stop(err) lhs <- formula[[2]] y.nms <- if (length(lhs) > 1) unlist(strsplit(as.character(as.expression(lhs)), " \\+ ")) else as.character(as.expression(lhs)) rhs <- formula[[3]] gr.nms <- if (length(rhs) > 1) rev(unlist(strsplit(as.character(as.expression(rhs)), "/"))) else as.character(as.expression(rhs)) if (is.null(data)) { ## we 'get' the variables in the .GlobalEnv: y <- as.data.frame(sapply(y.nms, get)) gr <- as.data.frame(sapply(gr.nms, get)) } else { y <- data[y.nms] gr <- data[gr.nms] } if (use == "all.obs") { na.fail(y) na.fail(gr) } if (use == "complete.obs") { sel <- complete.cases(y, gr) y <- y[sel] gr <- gr[sel] } na.rm <- use == "pairwise.complete.obs" foo <- function(x, gr, na.rm) { res <- data.frame(obs = NA, p.values = NA, labels = colnames(gr)) for (i in 1:length(gr)) { sel <- if (na.rm) !is.na(x) & !is.na(gr[, i]) else TRUE xx <- x[sel] g <- gr[sel, i] w <- if (i > 1) weight.taxo2(g, gr[sel, i - 1]) else weight.taxo(g) o <- Moran.I(xx, w, scaled = TRUE) res[i, 1] <- o$observed res[i, 2] <- o$p.value } ## We need to specify the two classes; if we specify ## only "correlogram", 'res' is coerced as a list ## (data frames are of class "data.frame" and mode "list") structure(res, class = c("correlogram", "data.frame")) } if (length(y) == 1) foo(y[[1]], gr, na.rm) else structure(lapply(y, foo, gr = gr, na.rm = na.rm), names = y.nms, class = "correlogramList") } plot.correlogram <- function(x, legend = TRUE, test.level = 0.05, col = c("grey", "red"), type = "b", xlab = "", ylab = "Moran's I", pch = 21, cex = 2, ...) { BG <- col[(x$p.values < test.level) + 1] if (pch > 20 && pch < 26) { bg <- col col <- CO <- "black" } else { CO <- BG BG <- bg <- NULL } plot(1:length(x$obs), x$obs, type = type, xaxt = "n", xlab = xlab, ylab = ylab, col = CO, bg = BG, pch = pch, cex = cex, ...) axis(1, at = 1:length(x$obs), labels = x$labels) if (legend) legend("top", legend = paste(c("P >=", "P <"), test.level), pch = pch, col = col, pt.bg = bg, pt.cex = cex, horiz = TRUE) } plot.correlogramList <- function(x, lattice = TRUE, legend = TRUE, test.level = 0.05, col = c("grey", "red"), xlab = "", ylab = "Moran's I", type = "b", pch = 21, cex = 2, ...) { n <- length(x) obs <- unlist(lapply(x, "[[", "obs")) pval <- unlist(lapply(x, "[[", "p.values")) gr <- factor(unlist(lapply(x, "[[", "labels")), ordered = TRUE, levels = x[[1]]$labels) vars <- gl(n, nlevels(gr), labels = names(x)) BG <- col[(pval < test.level) + 1] if (lattice) { ## trellis.par.set(list(plot.symbol=list(pch=19))) xyplot(obs ~ gr | vars, xlab = xlab, ylab = ylab, panel = function(x, y) { panel.lines(x, y, lty = 2) panel.points(x, y, cex = cex, pch = 19, col = BG) ##lattice::panel.abline(h = 0, lty = 3) }) } else { if (pch > 20 && pch < 26) { bg <- col CO <- rep("black", length(obs)) col <- "black" } else { CO <- BG BG <- bg <- NULL } plot(as.numeric(gr), obs, type = "n", xlab = xlab, ylab = ylab, xaxt = "n") for (i in 1:n) { sel <- as.numeric(vars) == i lines(as.numeric(gr[sel]), obs[sel], type = type, lty = i, col = CO[sel], bg = BG[sel], pch = pch, cex = cex, ...) } axis(1, at = 1:length(x[[i]]$obs), labels = x[[i]]$labels) if (legend) { legend("topright", legend = names(x), lty = 1:n, bty = "n") legend("top", legend = paste(c("P >=", "P <"), test.level), pch = pch, col = col, pt.bg = bg, pt.cex = cex, horiz = TRUE) } } } ape/R/howmanytrees.R0000644000176200001440000000423014164530562014075 0ustar liggesusers## howmanytrees.R (2020-11-13) ## Calculate Numbers of Phylogenetic Trees ## Copyright 2004-2020 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. LargeNumber <- function(a, b) { c <- b * log10(a) n <- floor(c) x <- 10^(c - n) ## cat(a, "^", b, " ~= ", x, " * 10^", n, "\n", sep = "") structure(c(x = x, n = n), class = "LargeNumber") } print.LargeNumber <- function(x, ...) cat("approximately ", x["x"], " * 10^", x["n"], "\n", sep = "") howmanytrees <- function(n, rooted = TRUE, binary = TRUE, labeled = TRUE, detail = FALSE) { if (!labeled && !(rooted & binary)) stop("can compute number of unlabeled trees only for rooted binary cases.") if (n < 3) N <- 1 else { if (labeled) { if (!rooted) n <- n - 1 if (binary) { if (n < 152) { N <- prod(seq(1, 2*n - 3, by = 2)) # double factorial } else { ldfac <- lfactorial(2 * n - 3) - (n - 2) * log(2) - lfactorial(n - 2) N <- LargeNumber(exp(1), ldfac) } } else { N <- matrix(0, n, n - 1) N[1:n, 1] <- 1 for (i in 3:n) for (j in 2:(i - 1)) N[i, j] <- (i + j - 2)*N[i - 1, j - 1] + j*N[i - 1, j] if (detail) { rownames(N) <- 1:n colnames(N) <- 1:(n - 1) } else N <- sum(N[n, ]) } } else { N <- numeric(n) N[1] <- 1 for (i in 2:n) { if (i %% 2) { im1 <- i - 1L x <- N[1:(im1 / 2)] y <- N[im1:((i + 1) / 2)] } else { ion2 <- i / 2 x <- N[1:ion2] y <- N[(i - 1):ion2] ny <- length(y) y[ny] <- (y[ny] + 1) / 2 } N[i] <- sum(x * y) } if (detail) names(N) <- 1:n else N <- N[n] } } N } ape/R/lmorigin.R0000644000176200001440000001204614164530562013174 0ustar liggesusers'lmorigin' <- function(formula, data=NULL, origin=TRUE, nperm=999, method=NULL, silent=FALSE) # # This program computes a multiple linear regression and performs tests # of significance of the equation parameters using permutations. # # origin=TRUE: the regression line can be forced through the origin. Testing # the significance in that case requires a special permutation procedure. # # Permutation methods: raw data or residuals of full model # Default method in regression through the origin: raw data # Default method in ordinary multiple regression: residuals of full model # - In ordinary multiple regression when m = 1: raw data # # Pierre Legendre, March 2009 { if(!is.null(method)) method <- match.arg(method, c("raw", "residuals")) if(is.null(method) & origin==TRUE) method <- "raw" if(is.null(method) & origin==FALSE) method <- "residuals" if(nperm < 0) stop("Incorrect value for 'nperm'") ## From the formula, find the variables and the number of observations 'n' toto <- lm(formula, data) mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "offset"), names(mf), 0) mf <- mf[c(1, m)] mf$drop.unused.levels <- TRUE mf[[1]] <- as.name("model.frame") mf <- eval(mf, parent.frame()) var.names = colnames(mf) # Noms des variables y <- as.matrix(mf[,1]) colnames(y) <- var.names[1] X <- as.matrix(mf[,-1]) n <- nrow(mf) m <- ncol(X) a <- system.time({ mm<- m # No. regression coefficients, possibly including the intercept if(m == 1) method <- "raw" if(nrow(X) != n) stop("Unequal number of rows in y and X") if(origin) { if(!silent) cat("Regression through the origin",'\n') reg <- lm(y ~ 0 + X) } else { if(!silent) cat("Multiple regression with estimation of intercept",'\n') reg <- lm(y ~ X) mm <- mm+1 } if(!silent) { if(nperm > 0) { if(method == "raw") { cat("Permutation method =",method,"data",'\n') } else { cat("Permutation method =",method,"of full model",'\n') } } } t.vec <- summary(reg)$coefficients[,3] p.param.t <- summary(reg)$coefficients[,4] df1 <- summary(reg)$fstatistic[[2]] df2 <- summary(reg)$fstatistic[[3]] F <- summary(reg)$fstatistic[[1]] y.res <- summary(reg)$residuals # b.vec <- summary(reg)$coefficients[,1] # r.sq <- summary(reg)$r.squared # adj.r.sq <- summary(reg)$adj.r.squared # p.param.F <- pf(F, df1, df2, lower.tail=FALSE) if(df1 < m) stop("\nCollinearity among the X variables. Check using 'lm'") # Permutation tests if(nperm > 0) { nGT.F <- 1 nGT1.t <- rep(1,mm) nGT2.t <- rep(1,mm) sign.t <- sign(t.vec) for(i in 1:nperm) # Permute raw data. Always use this method for F-test { if(origin) { # Regression through the origin dia.bin <- diag((rbinom(n,1,0.5)*2)-1) y.perm <- dia.bin %*% sample(y) reg.perm <- lm(y.perm ~ 0 + X) } else { # Multiple linear regression y.perm <- sample(y,n) reg.perm <- lm(y.perm ~ X) } # Permutation test of the F-statistic F.perm <- summary(reg.perm)$fstatistic[1] if(F.perm >= F) nGT.F <- nGT.F+1 # Permutation tests of the t-statistics: permute raw data if(method == "raw") { t.perm <- summary(reg.perm)$coefficients[,3] if(nperm <= 5) cat(t.perm,'\n') for(j in 1:mm) { # One-tailed test in direction of sign if(t.perm[j]*sign.t[j] >= t.vec[j]*sign.t[j]) nGT1.t[j] <- nGT1.t[j]+1 # Two-tailed test if( abs(t.perm[j]) >= abs(t.vec[j]) ) nGT2.t[j] <- nGT2.t[j]+1 } } } if(method == "residuals") { # Permute residuals of full model for(i in 1:nperm) { if(origin) { # Regression through the origin dia.bin <- diag((rbinom(n,1,0.5)*2)-1) y.perm <- dia.bin %*% sample(y.res) reg.perm <- lm(y.perm ~ 0 + X) } else { # Multiple linear regression y.perm <- sample(y.res,n) reg.perm <- lm(y.perm ~ X) } # Permutation tests of the t-statistics: permute residuals t.perm <- summary(reg.perm)$coefficients[,3] if(nperm <= 5) cat(t.perm,'\n') for(j in 1:mm) { # One-tailed test in direction of sign if(t.perm[j]*sign.t[j] >= t.vec[j]*sign.t[j]) nGT1.t[j] <- nGT1.t[j]+1 # Two-tailed test if( abs(t.perm[j]) >= abs(t.vec[j]) ) nGT2.t[j] <- nGT2.t[j]+1 } } } # Compute the permutational probabilities p.perm.F <- nGT.F/(nperm+1) p.perm.t1 <- nGT1.t/(nperm+1) p.perm.t2 <- nGT2.t/(nperm+1) ### Do not test intercept by permutation of residuals in multiple regression if(!origin & method=="residuals") { if(silent) { # Note: silent==TRUE in simulation programs p.perm.t1[1] <- p.perm.t2[1] <- 1 } else { p.perm.t1[1] <- p.perm.t2[1] <- NA } } } }) a[3] <- sprintf("%2f",a[3]) if(!silent) cat("Computation time =",a[3]," sec",'\n') # if(nperm == 0) { out <- list(reg=reg, p.param.t.2tail=p.param.t, p.param.t.1tail=p.param.t/2, origin=origin, nperm=nperm, var.names=var.names, call=match.call()) } else { out <- list(reg=reg, p.param.t.2tail=p.param.t, p.param.t.1tail=p.param.t/2, p.perm.t.2tail=p.perm.t2, p.perm.t.1tail=p.perm.t1, p.perm.F=p.perm.F, origin=origin, nperm=nperm, method=method, var.names=var.names, call=match.call()) } # class(out) <- "lmorigin" out } ape/R/is.compatible.R0000644000176200001440000000147514164530562014111 0ustar liggesusers## is.compatible.R (2017-06-03) ## Check Compatibility of Splits ## Copyright 2011 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. is.compatible <- function(obj) UseMethod("is.compatible") is.compatible.bitsplits <- function(obj) { m <- obj$matsplit n <- ncol(m) ntaxa <- length(obj$labels) for (i in 1:(n - 1)) for (j in (i + 1):n) if (!arecompatible(m[, i], m[, j], ntaxa)) return(FALSE) TRUE } arecompatible <-function(x, y, n) { msk <- !as.raw(2^(8 - (n %% 8)) - 1) foo <- function(v) { lv <- length(v) v[lv] <- v[lv] & msk as.integer(all(v == as.raw(0))) } nE <- foo(x & y) + foo(x & !y) + foo(!x & y) + foo(!x & !y) if (nE >= 1) TRUE else FALSE } ape/R/comparePhylo.R0000644000176200001440000001515314164530562014020 0ustar liggesusers## comparePhylo.R (2021-12-12) ## Compare Two "phylo" Objects ## Copyright 2018-2021 Emmanuel Paradis, 2021 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. comparePhylo <- function(x, y, plot = FALSE, force.rooted = FALSE, use.edge.length = FALSE, commons = TRUE, location = "bottomleft", ...) { tree1 <- deparse(substitute(x)) tree2 <- deparse(substitute(y)) res <- list() msg <- paste("=> Comparing", tree1, "with", tree2) res$messages <- msg n1 <- Ntip(x) n2 <- Ntip(y) tmp <- if (n1 == n2) paste("Both trees have the same number of tips:", n1) else paste("Trees have different numbers of tips:", n1, "and", n2) msg <- c(msg, tmp) tips1 <- x$tip.label tips2 <- y$tip.label tips12 <- match(tips1, tips2) tips21 <- match(tips2, tips1) tmp <- is.na(tips12) if (any(tmp)) msg <- c(msg, paste("Tips in", tree1, "not in", tree2, ":", paste(tips1[tmp], collapse = ", "))) tmp2 <- is.na(tips21) if (any(tmp2)) msg <- c(msg, paste("Tips in", tree2, "not in", tree1, ":", paste(tips2[tmp2], collapse = ", "))) sameTips <- FALSE if (!sum(tmp, tmp2)) { msg <- c(msg, "Both trees have the same tip labels") sameTips <- TRUE } m1 <- Nnode(x) m2 <- Nnode(y) tmp <- if (m1 == m2) paste("Both trees have the same number of nodes:", m1) else paste("Trees have different numbers of nodes:", m1, "and", m2) msg <- c(msg, tmp) rooted1 <- is.rooted(x) rooted2 <- is.rooted(y) tmp <- if (rooted1) { if (rooted2) "Both trees are rooted" else paste(tree1, "is rooted,", tree2, "is unrooted") } else { if (rooted2) paste(tree1, "is unrooted,", tree2, "is rooted") else "Both trees are unrooted" } msg <- c(msg, tmp) ultra1 <- ultra2 <- FALSE if (!is.null(x$edge.length)) ultra1 <- is.ultrametric(x) if (!is.null(y$edge.length)) ultra2 <- is.ultrametric(y) tmp <- if (ultra1) { if (ultra2) "Both trees are ultrametric" else paste(tree1, "is ultrametric,", tree2, "is not") } else { if (ultra2) paste(tree1, "is not ultrametric,", tree2, "is ultrametric") else "Both trees are not ultrametric" } msg <- c(msg, tmp) if (rooted1 && rooted2 || force.rooted) { key1 <- makeNodeLabel(x, "md5sum")$node.label key2 <- makeNodeLabel(y, "md5sum")$node.label mk12 <- match(key1, key2) mk21 <- match(key2, key1) if (any(tmp <- is.na(mk12))) { nk <- sum(tmp) msg <- c(msg, paste(nk, if (nk == 1) "clade" else "clades", "in", tree1, "not in", tree2)) } if (plot) { layout(matrix(1:2, 1, 2)) plot(x, use.edge.length = use.edge.length, main = tree1, ...) nodelabels(node = which(tmp) + n1, pch = 19, col = "blue", cex = 2) legend(location, legend = paste("Clade absent in", tree2), pch = 19, col = "blue") } if (any(tmp <- is.na(mk21))) { nk <- sum(tmp) msg <- c(msg, paste(nk, if (nk == 1) "clade" else "clades", "in", tree2, "not in", tree1)) } if (plot) { plot(y, use.edge.length = use.edge.length, main = tree2, ...) nodelabels(node = which(tmp) + n2, pch = 19, col = "red", cex = 2) legend(location, legend = paste("Clade absent in", tree1), pch = 19, col = "red") } nodes1 <- which(!is.na(mk12)) nodes2 <- mk12[!is.na(mk12)] if (ultra1 && ultra2) { bt1 <- branching.times(x) bt2 <- branching.times(y) BT <- data.frame(paste0(bt1[nodes1], " (", nodes1 + n1, ")"), paste0(bt2[nodes2], " (", nodes2 + n2, ")")) names(BT) <- c(tree1, tree2) res$BT <- BT msg <- c(msg, "Branching times of clades in common between both trees: see ..$BT (node number in parentheses)") } if (!is.null(nl1 <- x$node.label) && !is.null(nl2 <- y$node.label)) { NODES <- data.frame(paste0(nl1[nodes1], " (", nodes1 + n1, ")"), paste0(nl2[nodes2], " (", nodes2 + n2, ")")) names(NODES) <- c(tree1, tree2) res$NODES <- NODES msg <- c(msg, "Node labels of clades in common between both trees: see ..$NODES (node number in parentheses)") } } if (sameTips) { TR <- .compressTipLabel(c(x, y)) bs <- bitsplits(unroot(TR)) common.splits <- which(bs$freq == 2L) ncs <- length(common.splits) tmp <- if (ncs) paste(ncs, if (ncs == 1) "split" else "splits", "in common") else "No split in common" msg <- c(msg, tmp) if (plot) { co <- "black"#rgb(0, 0, 1, 0.7) layout(matrix(1:2, 1, 2)) edgecol1 <- rep("black", Nedge(x)) edgew1 <- rep(1, Nedge(x)) edgecol2 <- rep("black", Nedge(y)) edgew2 <- rep(1, Nedge(y)) if (ncs) { pp1 <- SHORTwise(prop.part(TR[[1]])) pp2 <- SHORTwise(prop.part(TR[[2]])) if (commons) { k1 <- which(!is.na(match(pp1, pp2)) & lengths(pp1) > 1) k2 <- which(!is.na(match(pp2, pp1)) & lengths(pp2) > 1) } else { k1 <- which(is.na(match(pp1, pp2)) & lengths(pp1) > 1) k2 <- which(is.na(match(pp2, pp1)) & lengths(pp2) > 1) } e1 <- match(k1 + n1, TR[[1]]$edge[, 2]) e2 <- match(k2 + n2, TR[[2]]$edge[, 2]) edgecol1[e1] <- edgecol2[e2] <- co edgew1[e1] <- edgew2[e2] <- 5 } text4leg <- if (commons) "Split present in both trees" else "Split specific to each tree" plot(TR[[1]], "u", use.edge.length = use.edge.length, edge.color = edgecol1, edge.width = edgew1, main = tree1, ...) legend(location, legend = text4leg, lty = 1, col = "black", lwd = 5, xpd = NA) plot(TR[[2]], "u", use.edge.length = use.edge.length, edge.color = edgecol2, edge.width = edgew2, main = tree2, ...) } } res$messages <- paste0(msg, ".") class(res) <- "comparePhylo" res } print.comparePhylo <- function(x, ...) { cat(x$messages, sep = "\n") cat("\n") x$messages <- class(x) <- NULL if (length(x)) print.default(x) } ape/R/corphylo.R0000644000176200001440000002444314164530562013217 0ustar liggesusers## corphylo.R (2021-04-24) ## Ancestral Character Estimation ## Copyright 2015 Anthony R. Ives ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. corphylo <- function(X, U = list(), SeM = NULL, phy = NULL, REML = TRUE, method = c("Nelder-Mead", "SANN"), constrain.d = FALSE, reltol = 10^-6, maxit.NM = 1000, maxit.SA = 1000, temp.SA = 1, tmax.SA = 1, verbose = FALSE) { # Begin corphylo.LL corphylo.LL <- function(par, XX, UU, MM, tau, Vphy, REML, constrain.d, verbose) { n <- nrow(X) p <- ncol(X) L.elements <- par[1:(p + p * (p - 1)/2)] L <- matrix(0, nrow = p, ncol = p) L[lower.tri(L, diag = T)] <- L.elements R <- t(L) %*% L if (constrain.d == TRUE) { logit.d <- par[(p + p * (p - 1)/2 + 1):length(par)] if (max(abs(logit.d)) > 10) return(10^10) d <- 1/(1 + exp(-logit.d)) } else { d <- par[(p + p * (p - 1)/2 + 1):length(par)] if (max(d) > 10) return(10^10) } # OU transform C <- matrix(0, nrow = p * n, ncol = p * n) for (i in 1:p) for (j in 1:p) { Cd <- (d[i]^tau * (d[j]^t(tau)) * (1 - (d[i] * d[j])^Vphy))/(1 - d[i] * d[j]) C[(n * (i - 1) + 1):(i * n), (n * (j - 1) + 1):(j * n)] <- R[i, j] * Cd } V <- C + diag(as.numeric(MM)) if (anyNA(V)) return(10^10) if (is.nan(rcond(V)) || rcond(V) < 10^-10) return(10^10) iV <- solve(V) denom <- t(UU) %*% iV %*% UU if (anyNA(denom)) return(10^10) if (is.nan(rcond(denom)) || rcond(denom) < 10^-10) return(10^10) num <- t(UU) %*% iV %*% XX B <- solve(denom, num) B <- as.matrix(B) H <- XX - UU %*% B logdetV <- -determinant(iV)$modulus[1] if (is.infinite(logdetV)) return(10^10) if (REML == TRUE) { # REML likelihood function LL <- 0.5 * (logdetV + determinant(t(UU) %*% iV %*% UU)$modulus[1] + t(H) %*% iV %*% H) } else { # ML likelihood function LL <- 0.5 * (logdetV + t(H) %*% iV %*% H) } if (verbose == T) show(c(as.numeric(LL), par)) return(as.numeric(LL)) } # End corphylo.LL # Main program if (!inherits(phy, "phylo")) stop("Object \"phy\" is not of class \"phylo\".") if (is.null(phy$edge.length)) stop("The tree has no branch lengths.") if (is.null(phy$tip.label)) stop("The tree has no tip labels.") phy <- reorder(phy, "postorder") n <- length(phy$tip.label) # Input X if (dim(X)[1] != n) stop("Number of rows of the data matrix does not match the length of the tree.") if (is.null(rownames(X))) { warning("No tip labels on X; order assumed to be the same as in the tree.\n") data.names = phy$tip.label } else data.names = rownames(X) order <- match(data.names, phy$tip.label) if (sum(is.na(order)) > 0) { warning("Data names do not match with the tip labels.\n") rownames(X) <- data.names } else { temp <- X rownames(X) <- phy$tip.label X[order, ] <- temp[1:nrow(temp), ] } p <- dim(X)[2] # Input SeM if (!is.null(SeM)) { if (dim(SeM)[1] != n) stop("Number of rows of the SeM matrix does not match the length of the tree.") if (is.null(rownames(SeM))) { warning("No tip labels on SeM; order assumed to be the same as in the tree.\n") data.names = phy$tip.label } else data.names = rownames(SeM) order <- match(data.names, phy$tip.label) if (sum(is.na(order)) > 0) { warning("SeM names do not match with the tip labels.\n") rownames(SeM) <- data.names } else { temp <- SeM rownames(SeM) <- phy$tip.label SeM[order, ] <- temp[1:nrow(temp), ] } } else { SeM <- matrix(0, nrow = n, ncol = p) } # Input U if (length(U) > 0) { if (length(U) != p) stop("Number of elements of list U does not match the number of columns in X.") for (i in 1:p) { if (!is.null(U[[i]])){ if (dim(U[[i]])[1] != n) stop("Number of rows of an element of U does not match the tree.") if (is.null(rownames(U[[i]]))) { warning("No tip labels on U; order assumed to be the same as in the tree.\n") data.names = phy$tip.label } else data.names = rownames(U[[i]]) order <- match(data.names, phy$tip.label) if (sum(is.na(order)) > 0) { warning("U names do not match with the tip labels.\n") rownames(U[[i]]) <- data.names } else { temp <- U[[i]] rownames(U[[i]]) <- phy$tip.label U[[i]][order, ] <- temp[1:nrow(temp), ] } } else { U[[i]] <- matrix(0, nrow=n, ncol=1) rownames(U[[i]]) <- phy$tip.label } } } # Standardize all variables Xs <- X for (i in 1:p) Xs[, i] <- (X[, i] - mean(X[, i]))/sd(X[, i]) if (!is.null(SeM)) { SeMs <- SeM for (i in 1:p) SeMs[, i] <- SeM[, i]/sd(X[, i]) } if (length(U) > 0) { Us <- U for (i in 1:p) for (j in 1:ncol(U[[i]])) { if (sd(U[[i]][, j]) > 0) { Us[[i]][, j] <- (U[[i]][, j] - mean(U[[i]][, j]))/sd(U[[i]][, j]) } else { Us[[i]][, j] <- U[[i]][, j] - mean(U[[i]][, j]) } } } # Set up matrices Vphy <- vcv(phy) Vphy <- Vphy/max(Vphy) Vphy <- Vphy/exp(determinant(Vphy)$modulus[1]/n) XX <- matrix(as.matrix(Xs), ncol = 1) MM <- matrix(as.matrix(SeMs^2), ncol = 1) UU <- kronecker(diag(p), matrix(1, nrow = n, ncol = 1)) if (length(U) > 0) { zeros <- 0 * (1:p) for (i in 1:p) { dd <- zeros dd[i] <- 1 u <- kronecker(dd, as.matrix(Us[[i]])) for (j in 1:dim(u)[2]) if (sd(u[, j]) > 0) UU <- cbind(UU, u[, j]) } } # Compute initial estimates assuming no phylogeny if not provided if (length(U) > 0) { eps <- matrix(nrow = n, ncol = p) for (i in 1:p) { if (ncol(U[[i]]) > 0) { u <- as.matrix(Us[[i]]) z <- lm(Xs[, i] ~ u) eps[, i] <- resid(z) } else { eps[, i] <- Xs[, i] - mean(Xs[, i]) } } L <- t(chol(cov(eps))) } else { L <- t(chol(cov(Xs))) } L.elements <- L[lower.tri(L, diag = T)] par <- c(L.elements, array(0.5, dim = c(1, p))) tau <- matrix(1, nrow = n, ncol = 1) %*% diag(Vphy) - Vphy if (method == "Nelder-Mead") opt <- optim(fn = corphylo.LL, par = par, XX = XX, UU = UU, MM = MM, tau = tau, Vphy = Vphy, REML = REML, verbose = verbose, constrain.d = constrain.d, method = "Nelder-Mead", control = list(maxit = maxit.NM, reltol = reltol)) if (method == "SANN") { opt <- optim(fn = corphylo.LL, par = par, XX = XX, UU = UU, MM = MM, tau = tau, Vphy = Vphy, REML = REML, verbose = verbose, constrain.d = constrain.d, method = "SANN", control = list(maxit = maxit.SA, temp = temp.SA, tmax = tmax.SA, reltol = reltol)) par <- opt$par opt <- optim(fn = corphylo.LL, par = par, XX = XX, UU = UU, MM = MM, tau = tau, Vphy = Vphy, REML = REML, verbose = verbose, constrain.d = constrain.d, method = "Nelder-Mead", control = list(maxit = maxit.NM, reltol = reltol)) } # Extract parameters par <- Re(opt$par) LL <- opt$value L.elements <- par[1:(p + p * (p - 1)/2)] L <- matrix(0, nrow = p, ncol = p) L[lower.tri(L, diag = T)] <- L.elements R <- t(L) %*% L Rd <- diag(diag(R)^-0.5) cor.matrix <- Rd %*% R %*% Rd if (constrain.d == TRUE) { logit.d <- par[(p + p * (p - 1)/2 + 1):length(par)] d <- 1/(1 + exp(-logit.d)) } else { d <- par[(p + p * (p - 1)/2 + 1):length(par)] } # OU transform C <- matrix(0, nrow = p * n, ncol = p * n) for (i in 1:p) for (j in 1:p) { Cd <- (d[i]^tau * (d[j]^t(tau)) * (1 - (d[i] * d[j])^Vphy))/(1 - d[i] * d[j]) C[(n * (i - 1) + 1):(i * n), (n * (j - 1) + 1):(j * n)] <- R[i, j] * Cd } V <- C + diag(MM) iV <- solve(V) denom <- t(UU) %*% iV %*% UU num <- t(UU) %*% iV %*% XX B <- solve(denom, num) B <- as.matrix(B) B.cov <- solve(t(UU) %*% iV %*% UU) H <- XX - UU %*% B # Back-transform B counter <- 0 sd.list <- matrix(0, nrow = dim(UU)[2], ncol = 1) for (i in 1:p) { counter <- counter + 1 B[counter] <- B[counter] + mean(X[, i]) sd.list[counter] <- sd(X[, i]) if (length(U) > 0) { for (j in 1:ncol(U[[i]])) { if (sd(U[[i]][, j]) > 0) { counter <- counter + 1 B[counter] <- B[counter] * sd(X[, i])/sd(U[[i]][, j]) sd.list[counter] <- sd(X[, i])/sd(U[[i]][, j]) } } } } B.cov <- diag(as.numeric(sd.list)) %*% B.cov %*% diag(as.numeric(sd.list)) B.se <- as.matrix(diag(B.cov))^0.5 B.zscore <- B/B.se B.pvalue <- 2 * pnorm(abs(B/B.se), lower.tail = FALSE) # RowNames for B if (length(U) > 0) { B.rownames <- NULL for (i in 1:p) { B.rownames <- c(B.rownames, paste("B", i, ".0", sep = "")) if (ncol(U[[i]]) > 0) for (j in 1:ncol(U[[i]])) if (sd(U[[i]][, j]) > 0) { if (is.null(colnames(U[[i]])[j])) B.rownames <- c(B.rownames, paste("B", i, ".", j, sep = "")) if (!is.null(colnames(U[[i]])[j])) B.rownames <- c(B.rownames, paste("B", i, ".", colnames(U[[i]])[j], sep = "")) } } } else { B.rownames <- NULL for (i in 1:p) { B.rownames <- c(B.rownames, paste("B", i, ".0", sep = "")) } } rownames(B) <- B.rownames rownames(B.cov) <- B.rownames colnames(B.cov) <- B.rownames rownames(B.se) <- B.rownames rownames(B.zscore) <- B.rownames rownames(B.pvalue) <- B.rownames if (REML == TRUE) { logLik <- -0.5 * ((n * p) - ncol(UU)) * log(2 * pi) + 0.5 * determinant(t(XX) %*% XX)$modulus[1] - LL } else { logLik <- -0.5 * (n * p) * log(2 * pi) - LL } k <- length(par) + ncol(UU) AIC <- -2 * logLik + 2 * k BIC <- -2 * logLik + k * (log(n) - log(pi)) results <- list(cor.matrix = cor.matrix, d = d, B = B, B.se = B.se, B.cov = B.cov, B.zscore = B.zscore, B.pvalue = B.pvalue, logLik = logLik, AIC = AIC, BIC = BIC, REML = REML, constrain.d = constrain.d, XX = XX, UU = UU, MM = MM, Vphy = Vphy, R = R, V = V, C = C, convcode = opt$convergence, niter = opt$counts) class(results) <- "corphylo" return(results) } # Printing corphylo objects print.corphylo <- function(x, digits = max(3, getOption("digits") - 3), ...) { cat("Call to corphylo\n\n") logLik = x$logLik AIC = x$AIC BIC = x$BIC names(logLik) = "logLik" names(AIC) = "AIC" names(BIC) = "BIC" print(c(logLik, AIC, BIC), digits = digits) cat("\ncorrelation matrix:\n") rownames(x$cor.matrix) <- 1:dim(x$cor.matrix)[1] colnames(x$cor.matrix) <- 1:dim(x$cor.matrix)[1] print(x$cor.matrix, digits = digits) cat("\nfrom OU process:\n") d <- data.frame(d = x$d) print(d, digits = digits) if (x$constrain.d == TRUE) cat("\nvalues of d constrained to be in [0, 1]\n") cat("\ncoefficients:\n") coef <- data.frame(Value = x$B, Std.Error = x$B.se, Zscore = x$B.zscore, Pvalue = x$B.pvalue) rownames(coef) <- rownames(x$B) printCoefmat(coef, P.values = TRUE, has.Pvalue = TRUE) cat("\n") if (x$convcode != 0) cat("\nWarning: convergence in optim() not reached\n") } ape/R/collapsed.intervals.R0000644000176200001440000000243414164530562015330 0ustar liggesusers## collapsed.intervals.R (2002-09-12) ## Collapsed coalescent intervals (e.g. for the skyline plot) ## Copyright 2002 Korbinian Strimmer ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. # construct collapsed intervals from coalescent intervals collapsed.intervals <- function(ci, epsilon=0.0) { if (class(ci) != "coalescentIntervals") stop("object \"ci\" is not of class \"coalescentIntervals\"") sz <- ci$interval.length lsz <- length(sz) idx <- c <- 1:lsz p <- 1 w <- 0 # starting from tips collapes intervals # until total size is >= epsilon for (i in 1:lsz) { idx[[i]] <- p w <- w + sz[[i]] if (w >= epsilon) { p <- p+1 w <- 0 } } # if last interval is smaller than epsilon merge # with second last interval lastInterval <- idx==p if ( sum(sz[lastInterval]) < epsilon ) { p <- p-1 idx[lastInterval] <- p } obj <- list( lineages=ci$lineages, interval.length=ci$interval.length, collapsed.interval=idx, # collapsed intervals (via reference) interval.count=ci$interval.count, collapsed.interval.count = idx[[ci$interval.count]], total.depth =ci$total.depth, epsilon = epsilon ) class(obj) <- "collapsedIntervals" return(obj) } ape/R/me.R0000644000176200001440000000450214164530562011753 0ustar liggesusers## me.R (2019-03-26) ## Tree Estimation Based on Minimum Evolution Algorithm ## Copyright 2007 Vincent Lefort with modifications by ## Emmanuel Paradis (2008-2019) ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. fastme.bal <- function(X, nni = TRUE, spr = TRUE, tbr = FALSE) { if (tbr) { warning("option 'tbr = TRUE' was ignored: see ?fastme.bal") tbr <- FALSE } if (is.matrix(X)) X <- as.dist(X) N <- as.integer(attr(X, "Size")) nedge <- 2L * N - 3L ans <- .C(me_b, as.double(X), N, 1:N, as.integer(nni), as.integer(spr), as.integer(tbr), integer(nedge), integer(nedge), double(nedge), NAOK = TRUE) labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) labels <- labels[ans[[3]]] obj <- list(edge = cbind(ans[[7]], ans[[8]]), edge.length = ans[[9]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" attr(obj, "order") <- "cladewise" obj } fastme.ols <- function(X, nni = TRUE) { if (is.matrix(X)) X <- as.dist(X) N <- as.integer(attr(X, "Size")) nedge <- 2L * N - 3L ans <- .C(me_o, as.double(X), N, 1:N, as.integer(nni), integer(nedge), integer(nedge), double(nedge), NAOK = TRUE) labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) labels <- labels[ans[[3]]] obj <- list(edge = cbind(ans[[5]], ans[[6]]), edge.length = ans[[7]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" attr(obj, "order") <- "cladewise" obj } bionj <- function(X) { if (is.matrix(X)) X <- as.dist(X) if (any(is.na(X))) stop("missing values are not allowed in the distance matrix.\nConsider using bionjs()") if (any(X > 100)) stop("at least one distance was greater than 100") N <- as.integer(attr(X, "Size")) ans <- .C(C_bionj, as.double(X), N, integer(2 * N - 3), integer(2 * N - 3), double(2*N - 3), NAOK = TRUE) labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } ape/R/compute.brtime.R0000644000176200001440000000323014164530562014304 0ustar liggesusers## compute.brtime.R (2012-03-02) ## Compute and Set Branching Times ## Copyright 2011-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. compute.brtime <- function(phy, method = "coalescent", force.positive = NULL) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') n <- length(phy$tip.label) m <- phy$Nnode N <- Nedge(phy) ## x: branching times (aka, node ages, depths, or heights) if (identical(method, "coalescent")) { # the default x <- 2 * rexp(m)/(as.double((m + 1):2) * as.double(m:1)) ## x <- 2 * rexp(n - 1)/(as.double(n:2) * as.double((n - 1):1)) if (is.null(force.positive)) force.positive <- TRUE } else if (is.numeric(method)) { x <- as.vector(method) if (length(x) != m) stop("number of branching times given is not equal to the number of nodes") if (is.null(force.positive)) force.positive <- FALSE } y <- c(rep(0, n), x) # for all nodes (terminal and internal) e1 <- phy$edge[, 1L] # local copies of the pointers e2 <- phy$edge[, 2L] # if (force.positive) { o <- .Call(seq_root2tip, phy$edge, n, m) list.nodes <- list(n + 1L) i <- 2L repeat { z <- sapply(o, "[", i) z <- unique(z[!(z <= n | is.na(z))]) if (!length(z)) break list.nodes[[i]] <- z i <- i + 1L } nodes <- unlist(lapply(list.nodes, function(x) x[sample(length(x))])) y[nodes] <- sort(x, decreasing = TRUE) } phy$edge.length <- y[e1] - y[e2] phy } ape/R/makeLabel.R0000644000176200001440000001402014164530562013223 0ustar liggesusers## makeLabel.R (2019-10-14) ## Label Management ## Copyright 2010-2019 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. makeLabel <- function(x, ...) UseMethod("makeLabel") makeLabel.character <- function(x, len = 99, space = "_", make.unique = TRUE, illegal = "():;,[]", quote = FALSE, ...) { x <- gsub("[[:space:]]", space, x) if (illegal != "") { illegal <- unlist(strsplit(illegal, NULL)) for (i in illegal) x <- gsub(i, "", x, fixed = TRUE) } if (quote) len <- len - 2 nc <- nchar(x) > len if (any(nc)) x[nc] <- substr(x[nc], 1, len) tab <- table(x) if (all(tab == 1)) make.unique <- FALSE if (make.unique) { dup <- tab[which(tab > 1)] nms <- names(dup) for (i in 1:length(dup)) { j <- which(x == nms[i]) end <- nchar(x[j][1]) ## w: number of characters to be added as suffix w <- floor(log10(dup[i])) + 1 suffix <- formatC(1:dup[i], width = w, flag = "0") if (end + w > len) { start <- end - w + 1 substr(x[j], start, end) <- suffix } else x[j] <- paste(x[j], suffix, sep = "") } } if (quote) x <- paste('"', x, '"', sep = "") x } makeLabel.phylo <- function(x, tips = TRUE, nodes = TRUE, ...) { if (tips) x$tip.label <- makeLabel.character(x$tip.label, ...) if (!is.null(x$node.label) && nodes) x$node.label <- makeLabel.character(x$node.label, ...) x } makeLabel.multiPhylo <- function(x, tips = TRUE, nodes = TRUE, ...) { y <- attr(x, "TipLabel") if (is.null(y)) { for (i in 1:length(x)) x[[i]] <- makeLabel.phylo(x[[i]], tips = tips, nodes = nodes, ...) } else { attr(x, "TipLabel") <- makeLabel.character(y, ...) } x } makeLabel.DNAbin <- function(x, ...) { if (is.list(x)) names(x) <- makeLabel.character(names(x), ...) else rownames(x) <- makeLabel.character(rownames(x), ...) x } mixedFontLabel <- function(..., sep = " ", italic = NULL, bold = NULL, parenthesis = NULL, always.upright = c("sp.", "spp.", "ssp.")) { x <- list(...) n <- length(x) if (!is.null(italic)) { for (i in italic) { y <- x[[i]] s <- ! y %in% always.upright y[s] <- paste("italic(\"", y[s], "\")", sep = "") if (any(!s)) y[!s] <- paste("plain(\"", y[!s], "\")", sep = "") x[[i]] <- y } } if (!is.null(bold)) { for (i in bold) { y <- x[[i]] s <- logical(length(y)) s[grep("^italic", y)] <- TRUE y[s] <- sub("^italic", "bolditalic", y[s]) y[!s] <- paste("bold(\"", y[!s], "\")", sep = "") x[[i]] <- y } } k <- which(! 1:n %in% c(italic, bold)) # those in upright if (length(k)) for (i in k) x[[i]] <- paste("plain(\"", x[[i]], "\")", sep = "") if (!is.null(parenthesis)) for (i in parenthesis) x[[i]] <- paste("(", x[[i]], ")", sep = "") res <- x[[1L]] if (n > 1) { sep <- rep(sep, length.out = n - 1L) for (i in 2:n) res <- paste(res, "*\"", sep[i - 1L], "\"*", x[[i]], sep = "") } parse(text = res) } .getSeparatorTaxaLabels <- function(x) { if (length(grep("_", x))) "_" else " " } label2table <- function(x, sep = NULL, as.is = FALSE) { n <- length(x) if (is.null(sep)) sep <- .getSeparatorTaxaLabels(x) x <- strsplit(x, sep) maxlen <- max(lengths(x)) x <- unlist(lapply(x, "[", 1:maxlen)) x <- matrix(x, n, maxlen, byrow = TRUE) x <- as.data.frame(x, as.is = as.is) baselevels <- c("genus", "species", "subspecies") nmx <- if (maxlen <= 3) baselevels[1:maxlen] else c(baselevels, paste0("type", 1:(maxlen - 3))) names(x) <- nmx x } stripLabel <- function(x, species = FALSE, subsp = TRUE, sep = NULL) { if (is.null(sep)) sep <- .getSeparatorTaxaLabels(x) n <- 0 if (species) n <- 1 else if (subsp) n <- 2 if (!n) return(x) x <- strsplit(x, sep) x <- lapply(x, "[", 1:n) sapply(x, paste, collapse = sep) } abbreviateGenus <- function(x, genus = TRUE, species = FALSE, sep = NULL) { if (is.null(sep)) sep <- .getSeparatorTaxaLabels(x) if (genus) x <- sub(paste0("[[:lower:]]{1,}", sep), paste0(".", sep), x) if (!species) return(x) x <- strsplit(x, sep) k <- which(lengths(x, use.names = FALSE) > 1) for (i in k) x[[i]][2] <- paste0(substr(x[[i]][2], 1, 1), ".") sapply(x, paste, collapse = sep) } updateLabel <- function(x, old, new, ...) UseMethod("updateLabel") updateLabel.character <- function(x, old, new, exact = TRUE, ...) { if (length(old) != length(new)) stop("'old' and 'new' not of the same length") if (exact) { for (i in seq_along(old)) x[x == old[i]] <- new[i] } else { for (i in seq_along(old)) x[grep(old[i], x)] <- new[i] } x } updateLabel.DNAbin <- function(x, old, new, exact = TRUE, ...) { labs <- labels(x) labs <- updateLabel.character(labs, old, new, exact, ...) if (is.list(x)) names(x) <- labs else rownames(x) <- labs x } updateLabel.AAbin <- function(x, old, new, exact = TRUE, ...) updateLabel.DNAbin(x, old, new, exact, ...) updateLabel.phylo <- function(x, old, new, exact = TRUE, nodes = FALSE, ...) { x$tip.label <- updateLabel.character(x$tip.label, old, new, exact, ...) if (nodes) x$node.label <- updateLabel.character(x$node.label, old, new, exact, ...) x } updateLabel.evonet <- function(x, old, new, exact = TRUE, nodes = FALSE, ...) updateLabel.phylo(x, old, new, exact, nodes, ...) updateLabel.data.frame <- function(x, old, new, exact = TRUE, ...) { row.names(x) <- updateLabel.character(row.names(x), old, new, exact, ...) x } updateLabel.matrix <- function(x, old, new, exact = TRUE, ...) { rownames(x) <- updateLabel.character(rownames(x), old, new, exact, ...) x } ape/R/checkValidPhylo.R0000644000176200001440000000775614164530562014441 0ustar liggesusers## checkValidPhylo.R (2016-07-26) ## Check the Structure of a "phylo" Object ## Copyright 2015-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. checkValidPhylo <- function(phy) { cat("Starting checking the validity of ", deparse(substitute(phy)), "...\n", sep = "") n <- m <- NULL if (is.null(phy$tip.label)) { cat(" FATAL: no element named 'tip.label' in the tree -- did you extract this tree from a \"multiPhylo\" object?\n") } else { if (!is.vector(phy$tip.label)) { cat(" FATAL: 'tip.label' is not a vector\n") } else { if (!is.character(phy$tip.label)) cat(" MODERATE: 'tip.label' is not of mode \"character\"\n") n <- length(phy$tip.label) cat("Found number of tips: n =", n, "\n") } } if (is.null(n)) cat(" FATAL: cannot determine the number of tips\n") if (is.null(phy$Nnode)) { cat(" FATAL: no element named 'Nnode' in the tree\n") } else { if (!is.vector(phy$Nnode)) cat(" MODERATE: 'Nnode' is not a vector\n") if (length(phy$Nnode) != 1) cat(" FATAL: 'Nnode' is not of length 1\n") if (!is.numeric(phy$Nnode)) { cat(" FATAL: 'Nnode' is not numeric\n") } else { if (storage.mode(phy$Nnode) != "integer") cat(" MODERATE: 'Nnode' is not stored as an integer\n") } if (length(phy$Nnode) == 1 && is.numeric(phy$Nnode)) { m <- phy$Nnode cat("Found number of nodes: m =", m, "\n") } } if (is.null(m)) cat(" FATAL: cannot determine the number of nodes\n") if (is.null(phy$edge)) { cat(" FATAL: no element named 'edge' in the tree\n") } else { if (!is.matrix(phy$edge)) { cat(" FATAL: 'edge' is not a matrix\n") } else { nc <- ncol(phy$edge) if (nc != 2) cat(" FATAL: 'edge' has", nc, "columns: it MUST have 2\n") if (!is.numeric(phy$edge)) { cat(" FATAL: 'edge' is not a numeric matrix\n") } else { if (storage.mode(phy$edge) != "integer") cat(" MODERATE: the matrix 'edge' is not stored as integers\n") if (nc == 2) { if (any(phy$edge <= 0)) cat(" FATAL: some elements in 'edge' are negative or zero\n") if (is.null(n) || is.null(m)) { cat("The number of tips and/or nodes was not found: cannot check completely the 'edge' matrix\n") } else { tab <- tabulate(phy$edge) if (length(tab) > n + m) cat(" FATAL: some numbers in 'edge' are larger than 'n + m'\n") if (length(tab) < n + m) cat(" MODERATE: some nodes are missing in 'edge'\n") if (any(tab[1:n] != 1)) cat(" FATAL: each tip must appear once in 'edge'\n") if (any(tab[n + 1:m] < 2)) cat(" FATAL: all nodes should appear at least twice in 'edge'\n") if (m > 1) if (any(tab[n + 2:m] < 2)) cat(" MODERATE: some nodes are of degree 1 or less\n") if (any(phy$edge[, 1] <= n & phy$edge[, 1] > 0)) cat(" FATAL: tips should not appear in the 1st column of 'edge'\n") if (any(table(phy$edge[, 2]) > 1)) cat(" FATAL: nodes and tips should appear only once in the 2nd column of 'edge'\n") if (any(phy$edge[, 2] == n + 1L)) cat(" FATAL: the root node should not appear in the 2nd column of 'edge'\n") } } } } } cat("Done.\n") } ape/R/print.lmorigin.R0000644000176200001440000000440514164530562014327 0ustar liggesusers'print.lmorigin' <- function(x, ...) { if(x$origin) { cat("\nRegression through the origin",'\n') } else { cat("\nMultiple regression with estimation of intercept",'\n') } cat("\nCall:\n") cat(deparse(x$call),'\n') if(x$origin) { names <- x$var.names[-1] } else { names <- c("(Intercept)",x$var.names[-1]) } cat("\nCoefficients and parametric test results \n",'\n') res <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], summary(x$reg)$coefficients[,2], summary(x$reg)$coefficients[,3], summary(x$reg)$coefficients[,4])) rownames(res) <- names colnames(res) <- c("Coefficient","Std_error","t-value","Pr(>|t|)") printCoefmat(res, P.values=TRUE, signif.stars=TRUE) if(x$nperm > 0) { cat("\nTwo-tailed tests of regression coefficients\n",'\n') res2 <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], x$p.param.t.2tail, x$p.perm.t.2tail)) rownames(res2) <- names colnames(res2) <- c("Coefficient","p-param","p-perm") nc <- 3 printCoefmat(res2, P.values=TRUE, signif.stars=TRUE, has.Pvalue = 3 && substr(colnames(res2)[3],1,6) == "p-perm") cat("\nOne-tailed tests of regression coefficients:",'\n') cat("test in the direction of the sign of the coefficient\n",'\n') res1 <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], x$p.param.t.1tail, x$p.perm.t.1tail)) rownames(res1) <- names colnames(res1) <- c("Coefficient","p-param","p-perm") nc <- 3 printCoefmat(res1, P.values=TRUE, signif.stars=TRUE, has.Pvalue = 3 && substr(colnames(res1)[3],1,6) == "p-perm") } cat("\nResidual standard error:", summary(x$reg)$sigma, "on", summary(x$reg)$df[2],"degrees of freedom",'\n') cat("Multiple R-square:", summary(x$reg)$r.squared," Adjusted R-square:", summary(x$reg)$adj.r.squared,'\n') F <- summary(x$reg)$fstatistic[[1]] df1 <- summary(x$reg)$fstatistic[[2]] df2 <- summary(x$reg)$fstatistic[[3]] p.param.F <- pf(F, df1, df2, lower.tail=FALSE) cat("\nF-statistic:", F, "on", df1, "and", df2, "DF:\n") cat(" parametric p-value :", p.param.F,'\n') if(x$nperm > 0) { cat(" permutational p-value:", x$p.perm.F,'\n') if(x$method == "raw") { cat("after",x$nperm,"permutations of",x$method,"data",'\n','\n') } else { cat("after",x$nperm,"permutations of",x$method,"of full model",'\n','\n') } } invisible(x) } ape/R/ace.R0000644000176200001440000003526414164530562012113 0ustar liggesusers## ace.R (2021-12-15) ## Ancestral Character Estimation ## Copyright 2005-2021 Emmanuel Paradis and 2005 Ben Bolker ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .getSEs <- function(out) { h <- out$hessian if (any(diag(h) == 0)) { warning("The likelihood gradient seems flat in at least one dimension (gradient null):\ncannot compute the standard-errors of the transition rates.\n") se <- rep(NaN, nrow(h)) } else { se <- sqrt(diag(solve(h))) } se } ace <- function(x, phy, type = "continuous", method = if (type == "continuous") "REML" else "ML", CI = TRUE, model = if (type == "continuous") "BM" else "ER", scaled = TRUE, kappa = 1, corStruct = NULL, ip = 0.1, use.expm = FALSE, use.eigen = TRUE, marginal = FALSE) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') if (is.null(phy$edge.length)) stop("tree has no branch lengths") type <- match.arg(type, c("continuous", "discrete")) nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode if (nb.node != nb.tip - 1) stop('"phy" is not rooted AND fully dichotomous.') if (length(x) != nb.tip) stop("length of phenotypic and of phylogenetic data do not match.") if (!is.null(names(x))) { if(all(names(x) %in% phy$tip.label)) x <- x[phy$tip.label] else warning("the names of 'x' and the tip labels of the tree do not match: the former were ignored in the analysis.") } obj <- list() if (kappa != 1) phy$edge.length <- phy$edge.length^kappa if (type == "continuous") { switch(method, "REML" = { minusLogLik <- function(sig2) { if (sig2 < 0) return(1e100) V <- sig2 * vcv(phy) ## next three lines borrowed from dmvnorm() in 'mvtnorm' distval <- mahalanobis(x, center = mu, cov = V) logdet <- sum(log(eigen(V, symmetric = TRUE, only.values = TRUE)$values)) (nb.tip * log(2 * pi) + logdet + distval)/2 } mu <- rep(ace(x, phy, method="pic")$ace[1], nb.tip) out <- nlm(minusLogLik, 1, hessian = TRUE) sigma2 <- out$estimate se_sgi2 <- sqrt(1/out$hessian) tip <- phy$edge[, 2] <= nb.tip minus.REML.BM <- function(p) { x1 <- p[phy$edge[, 1] - nb.tip] x2 <- numeric(length(x1)) x2[tip] <- x[phy$edge[tip, 2]] x2[!tip] <- p[phy$edge[!tip, 2] - nb.tip] -(-sum((x1 - x2)^2/phy$edge.length)/(2 * sigma2) - nb.node * log(sigma2)) } out <- nlm(function(p) minus.REML.BM(p), p = rep(mu[1], nb.node), hessian = TRUE) obj$resloglik <- -out$minimum obj$ace <- out$estimate names(obj$ace) <- nb.tip + 1:nb.node obj$sigma2 <- c(sigma2, se_sgi2) if (CI) { se <- .getSEs(out) tmp <- se * qt(0.025, nb.node) obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp) } }, "pic" = { if (model != "BM") stop('the "pic" method can be used only with model = "BM".') ## See pic.R for some annotations. phy <- reorder(phy, "postorder") phenotype <- numeric(nb.tip + nb.node) phenotype[1:nb.tip] <- if (is.null(names(x))) x else x[phy$tip.label] contr <- var.con <- numeric(nb.node) ans <- .C(C_pic, as.integer(nb.tip), as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), as.double(phy$edge.length), as.double(phenotype), as.double(contr), as.double(var.con), as.integer(CI), as.integer(scaled)) obj$ace <- ans[[5]][-(1:nb.tip)] names(obj$ace) <- nb.tip + 1:nb.node if (CI) { se <- sqrt(ans[[7]]) tmp <- se * qnorm(0.025) obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp) } }, "ML" = { if (model == "BM") { tip <- phy$edge[, 2] <= nb.tip dev.BM <- function(p) { if (p[1] < 0) return(1e100) # in case sigma^2 is negative x1 <- p[-1][phy$edge[, 1] - nb.tip] x2 <- numeric(length(x1)) x2[tip] <- x[phy$edge[tip, 2]] x2[!tip] <- p[-1][phy$edge[!tip, 2] - nb.tip] -2 * (-sum((x1 - x2)^2/phy$edge.length)/(2*p[1]) - nb.node * log(p[1])) } out <- nlm(function(p) dev.BM(p), p = c(1, rep(mean(x), nb.node)), hessian = TRUE) obj$loglik <- -out$minimum / 2 obj$ace <- out$estimate[-1] names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node) se <- .getSEs(out) obj$sigma2 <- c(out$estimate[1], se[1]) if (CI) { tmp <- se[-1] * qt(0.025, nb.node) obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp) } } }, "GLS" = { if (is.null(corStruct)) stop('you must give a correlation structure if method = "GLS".') if (class(corStruct)[1] == "corMartins") M <- corStruct[1] * dist.nodes(phy) if (class(corStruct)[1] == "corGrafen") phy <- compute.brlen(attr(corStruct, "tree"), method = "Grafen", power = exp(corStruct[1])) if (class(corStruct)[1] %in% c("corBrownian", "corGrafen")) { dis <- dist.nodes(attr(corStruct, "tree")) MRCA <- mrca(attr(corStruct, "tree"), full = TRUE) M <- dis[as.character(nb.tip + 1), MRCA] dim(M) <- rep(sqrt(length(M)), 2) } one2n <- 1:nb.tip varAY <- M[-one2n, one2n] varA <- M[-one2n, -one2n] DF <- data.frame(x) V <- corMatrix(Initialize(corStruct, DF), corr = FALSE) invV <- solve(V) o <- gls(x ~ 1, DF, correlation = corStruct) GM <- o$coefficients obj$ace <- drop(varAY %*% invV %*% (x - GM) + GM) names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node) if (CI) { se <- sqrt((varA - varAY %*% invV %*% t(varAY))[cbind(1:nb.node, 1:nb.node)]) tmp <- se * qnorm(0.025) obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp) } }) } else { # type == "discrete" if (method != "ML") stop("only ML estimation is possible for discrete characters.") if (any(phy$edge.length < 0)) stop("some branches have negative length") if (!is.factor(x)) x <- factor(x) nl <- nlevels(x) lvls <- levels(x) x <- as.integer(x) if (is.character(model)) { rate <- matrix(NA, nl, nl) switch(model, "ER" = np <- rate[] <- 1, "ARD" = { np <- nl*(nl - 1) rate[col(rate) != row(rate)] <- 1:np }, "SYM" = { np <- nl * (nl - 1)/2 sel <- col(rate) < row(rate) rate[sel] <- 1:np rate <- t(rate) rate[sel] <- 1:np }) } else { if (ncol(model) != nrow(model)) stop("the matrix given as 'model' is not square") if (ncol(model) != nl) stop("the matrix 'model' must have as many rows as the number of categories in 'x'") rate <- model np <- max(rate) } index.matrix <- rate tmp <- cbind(1:nl, 1:nl) index.matrix[tmp] <- NA rate[tmp] <- 0 rate[rate == 0] <- np + 1 # to avoid 0's since we will use this as numeric indexing liks <- matrix(0, nb.tip + nb.node, nl) TIPS <- 1:nb.tip liks[cbind(TIPS, x)] <- 1 if (anyNA(x)) liks[which(is.na(x)), ] <- 1 phy <- reorder(phy, "postorder") Q <- matrix(0, nl, nl) e1 <- phy$edge[, 1] e2 <- phy$edge[, 2] EL <- phy$edge.length if (use.eigen) { dev <- function(p, output.liks = FALSE) { if (any(is.nan(p)) || any(is.infinite(p))) return(1e+50) comp <- numeric(nb.tip + nb.node) Q[] <- c(p, 0)[rate] diag(Q) <- -rowSums(Q) decompo <- eigen(Q) lambda <- decompo$values GAMMA <- decompo$vectors invGAMMA <- solve(GAMMA) for (i in seq(from = 1, by = 2, length.out = nb.node)) { j <- i + 1L anc <- e1[i] des1 <- e2[i] des2 <- e2[j] v.l <- GAMMA %*% diag(exp(lambda * EL[i])) %*% invGAMMA %*% liks[des1, ] v.r <- GAMMA %*% diag(exp(lambda * EL[j])) %*% invGAMMA %*% liks[des2, ] v <- v.l * v.r comp[anc] <- sum(v) liks[anc, ] <- v/comp[anc] } if (output.liks) return(liks[-TIPS, , drop = FALSE]) dev <- -2 * sum(log(comp[-TIPS])) if (is.na(dev)) Inf else dev } } else { if (!requireNamespace("expm", quietly = TRUE) && use.expm) { warning("package 'expm' not available; using function 'matexpo' from 'ape'") use.expm <- FALSE } E <- if (use.expm) expm::expm # to avoid Matrix::expm else matexpo dev <- function(p, output.liks = FALSE) { if (any(is.nan(p)) || any(is.infinite(p))) return(1e50) comp <- numeric(nb.tip + nb.node) # from Rich FitzJohn Q[] <- c(p, 0)[rate] diag(Q) <- -rowSums(Q) for (i in seq(from = 1, by = 2, length.out = nb.node)) { j <- i + 1L anc <- e1[i] des1 <- e2[i] des2 <- e2[j] v.l <- E(Q * EL[i]) %*% liks[des1, ] v.r <- E(Q * EL[j]) %*% liks[des2, ] v <- v.l * v.r comp[anc] <- sum(v) liks[anc, ] <- v/comp[anc] } if (output.liks) return(liks[-TIPS, , drop = FALSE]) dev <- -2 * sum(log(comp[-TIPS])) if (is.na(dev)) Inf else dev } } out <- nlminb(rep(ip, length.out = np), function(p) dev(p), lower = rep(0, np), upper = rep(1e50, np)) obj$loglik <- -out$objective/2 obj$rates <- out$par oldwarn <- options("warn") options(warn = -1) out.nlm <- try(nlm(function(p) dev(p), p = obj$rates, iterlim = 1, stepmax = 0, hessian = TRUE), silent = TRUE) options(oldwarn) obj$se <- if (class(out.nlm) == "try-error") { warning("model fit suspicious: gradients apparently non-finite") rep(NaN, np) } else .getSEs(out.nlm) obj$index.matrix <- index.matrix if (CI) { lik.anc <- dev(obj$rates, TRUE) if (!marginal) { Q[] <- c(obj$rates, 0)[rate] diag(Q) <- -rowSums(Q) for (i in seq(to = 1, by = -2, length.out = nb.node)) { anc <- e1[i] - nb.tip des1 <- e2[i] - nb.tip if (des1 > 0) { P <- matexpo(Q * EL[i]) tmp <- lik.anc[anc, ] / (lik.anc[des1, ] %*% P) lik.anc[des1, ] <- (tmp %*% P) * lik.anc[des1, ] } j <- i + 1L des2 <- e2[j] - nb.tip if (des2 > 0) { P <- matexpo(Q * EL[j]) tmp <- lik.anc[anc, ] / (lik.anc[des2, ] %*% P) lik.anc[des2, ] <- (tmp %*% P) * lik.anc[des2, ] } lik.anc <- lik.anc / rowSums(lik.anc) } } rownames(lik.anc) <- nb.tip + 1:nb.node colnames(lik.anc) <- lvls obj$lik.anc <- lik.anc } } obj$call <- match.call() class(obj) <- "ace" obj } logLik.ace <- function(object, ...) object$loglik deviance.ace <- function(object, ...) -2*object$loglik AIC.ace <- function(object, ..., k = 2) { if (is.null(object$loglik)) return(NULL) ## Trivial test of "type"; may need to be improved ## if other models are included in ace(type = "c") np <- if (!is.null(object$sigma2)) 1 else length(object$rates) -2*object$loglik + np*k } ### by BB: anova.ace <- function(object, ...) { X <- c(list(object), list(...)) df <- lengths(lapply(X, "[[", "rates")) ll <- sapply(X, "[[", "loglik") ## check if models are in correct order dev <- c(NA, 2*diff(ll)) ddf <- c(NA, diff(df)) table <- data.frame(ll, df, ddf, dev, pchisq(dev, ddf, lower.tail = FALSE)) dimnames(table) <- list(1:length(X), c("Log lik.", "Df", "Df change", "Resid. Dev", "Pr(>|Chi|)")) structure(table, heading = "Likelihood Ratio Test Table", class = c("anova", "data.frame")) } print.ace <- function(x, digits = 4, ...) { cat("\n Ancestral Character Estimation\n\n") cat("Call: ") print(x$call) cat("\n") if (!is.null(x$loglik)) cat(" Log-likelihood:", x$loglik, "\n\n") if (!is.null(x$resloglik)) cat(" Residual log-likelihood:", x$resloglik, "\n\n") ratemat <- x$index.matrix if (is.null(ratemat)) { # to be improved class(x) <- NULL x$resloglik <- x$loglik <- x$call <- NULL print(x) } else { dimnames(ratemat)[1:2] <- dimnames(x$lik.anc)[2] cat("Rate index matrix:\n") print(ratemat, na.print = ".") cat("\n") npar <- length(x$rates) estim <- data.frame(1:npar, round(x$rates, digits), round(x$se, digits)) cat("Parameter estimates:\n") names(estim) <- c("rate index", "estimate", "std-err") print(estim, row.names = FALSE) if (!is.null(x$lik.anc)) { cat("\nScaled likelihoods at the root (type '...$lik.anc' to get them for all nodes):\n") print(x$lik.anc[1, ]) } } } ape/R/clustal.R0000644000176200001440000002344314164530562013026 0ustar liggesusers## clustal.R (2018-03-28) ## Multiple Sequence Alignment with External Applications ## Copyright 2011-2018 Emmanuel Paradis, 2018 Franz Krah ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .errorAlignment <- function(exec, prog) { dirs <- strsplit(Sys.getenv("PATH"), .Platform$path.sep)[[1]] paste0("\n cannot find executable ", sQuote(exec), " on your computer.\n", " It is recommended that you place the executable of ", prog, "\n", " in a directory on the PATH of your computer which is:\n", paste(sort(dirs), collapse = "\n")) } clustalomega <- function (x, y, guide.tree, exec = NULL, MoreArgs = "", quiet = TRUE, original.ordering = TRUE, file) { os <- Sys.info()[1] if (is.null(exec)) { exec <- switch(os, Linux = "clustalo", Darwin = "clustalo", Windows = "clustalo.exe") } if (missing(x)) { out <- system(paste(exec, "-h")) if (out == 127) stop(.errorAlignment(exec, "Clustal-Omega")) return(invisible(NULL)) } type <- if (inherits(x, "DNAbin")) "DNA" else "AA" if (type == "AA" && !inherits(x, "AAbin")) stop("'x' should be of class \"DNAbin\" or \"AAbin\"") noy <- missing(y) fns <- character(4) for (i in 1:3) fns[i] <- tempfile(pattern = "clustal", tmpdir = tempdir(), fileext = ".fas") fns[4] <- tempfile(pattern = "guidetree", tmpdir = tempdir(), fileext = ".nwk") unlink(fns[file.exists(fns)]) x <- as.list(x) labels.bak <- names(x) names(x) <- paste0("Id", 1:length(x)) write.FASTA(x, fns[1]) if (noy) { opts <- paste("-i", fns[1], "-o", fns[3], "--force") ## add input guide tree if (!missing(guide.tree)) { if (!inherits(guide.tree, "phylo")) stop("object 'guide.tree' is not of class \"phylo\"") if (length(setdiff(labels.bak, guide.tree$tip.label))) stop("guide tree does not match sequence names") guide.tree$tip.label[match(guide.tree$tip.label, labels.bak)] <- names(x) if (!is.binary(guide.tree)) guide.tree <- multi2di(guide.tree) if (is.null(guide.tree$edge.length)) guide.tree$edge.length <- rep(1, Nedge(guide.tree)) write.tree(guide.tree, fns[4]) opts <- paste(opts, paste("--guidetree-in", fns[4])) } } else { y <- as.list(y) labels.baky <- names(y) names(y) <- paste0("Id", length(x) + 1:length(y)) write.FASTA(y, fns[2]) if (length(y) == 1) { opts <- paste("-i", fns[1],"--profile1", fns[2], "-o", fns[3], "--force") } else { opts <- paste("--profile1", fns[1],"--profile2", fns[2], "-o", fns[3], "--force") } } opts <- paste(opts, MoreArgs) if (!quiet) opts <- paste(opts, "-v") out <- system(paste(exec, opts), ignore.stdout = quiet) if (out == 127) stop(.errorAlignment(exec, "Clustal-Omega")) res <- as.matrix(read.FASTA(fns[3], type)) if (noy) { if (original.ordering) res <- res[labels(x), ] rownames(res) <- labels.bak } else { if (original.ordering) res <- res[c(labels(x), labels(y)), ] rownames(res) <- c(labels.bak, labels.baky) } unlink(fns[file.exists(fns)]) if (missing(file)) return(res) else write.FASTA(res, file) } clustal <- function(x, y, guide.tree, pw.gapopen = 10, pw.gapext = 0.1, gapopen = 10, gapext = 0.2, exec = NULL, MoreArgs = "", quiet = TRUE, original.ordering = TRUE, file) { os <- Sys.info()[1] if (is.null(exec)) { exec <- switch(os, Linux = "clustalw", Darwin = "clustalw2", Windows = "clustalw2.exe") } if (missing(x)) { out <- system(paste(exec, "-help")) if (out == 127) stop(.errorAlignment(exec, "Clustal")) return(invisible(NULL)) } type <- if (inherits(x, "DNAbin")) "DNA" else "AA" if (type == "AA" && !inherits(x, "AAbin")) stop("'x' should be of class \"DNAbin\" or \"AAbin\"") noy <- missing(y) fns <- character(4) for (i in 1:3) fns[i] <- tempfile(pattern = "clustal", tmpdir = tempdir(), fileext = ".fas") fns[4] <- tempfile(pattern = "guidetree", tmpdir = tempdir(), fileext = ".nwk") unlink(fns[file.exists(fns)]) x <- as.list(x) labels.bak <- names(x) names(x) <- paste0("Id", 1:length(x)) write.FASTA(x, fns[1]) if (noy) { prefix <- c("-INFILE", "-PWGAPOPEN", "-PWGAPEXT", "-GAPOPEN","-GAPEXT", "-OUTFILE","-OUTPUT") suffix <- c(fns[1], pw.gapopen, pw.gapext, gapopen, gapext, fns[3], "FASTA") ## add input guide tree if (!missing(guide.tree)) { if (!inherits(guide.tree, "phylo")) stop("object 'guide.tree' is not of class \"phylo\"") if (length(setdiff(labels.bak, guide.tree$tip.label))) stop("guide tree does not match sequence names") guide.tree$tip.label[match(guide.tree$tip.label, labels.bak)] <- names(x) if (!is.binary(guide.tree)) guide.tree <- multi2di(guide.tree) if (is.null(guide.tree$edge.length)) guide.tree$edge.length <- rep(1, Nedge(guide.tree)) write.tree(guide.tree, fns[4]) prefix <- c(prefix, "-USETREE") suffix <- c(suffix, fns[4]) } } else { y <- as.list(y) labels.baky <- names(y) names(y) <- paste0("Id", length(x) + 1:length(y)) write.FASTA(y, fns[2]) prefix <- c("-PROFILE1", "-PROFILE2", "-PWGAPOPEN", "-PWGAPEXT", "-GAPOPEN","-GAPEXT", "-OUTFILE","-OUTPUT") suffix <- c(fns[1], fns[2], pw.gapopen, pw.gapext, gapopen, gapext, fns[3], "FASTA") } opts <- paste(prefix, suffix, sep = "=", collapse = " ") opts <- paste(opts, MoreArgs) out <- system(paste(exec, opts), ignore.stdout = quiet) if (out == 127) stop(.errorAlignment(exec, "Clustal")) res <- as.matrix(read.FASTA(fns[3], type)) if (noy) { if (original.ordering) res <- res[labels(x), ] rownames(res) <- labels.bak } else { if (original.ordering) res <- res[c(labels(x), labels(y)), ] rownames(res) <- c(labels.bak, labels.baky) } unlink(fns[file.exists(fns)]) if (missing(file)) return(res) else write.FASTA(res, file) } muscle <- function (x, y, guide.tree, exec = "muscle", MoreArgs = "", quiet = TRUE, original.ordering = TRUE, file) { if (missing(x)) { out <- system(exec) if (out == 127) stop(.errorAlignment(exec, "MUSCLE")) return(invisible(NULL)) } type <- if (inherits(x, "DNAbin")) "DNA" else "AA" if (type == "AA" && !inherits(x, "AAbin")) stop("'x' should be of class \"DNAbin\" or \"AAbin\"") noy <- missing(y) ## Produce TEMP files fns <- character(4) for (i in 1:3) fns[i] <- tempfile(pattern = "muscle", tmpdir = tempdir(), fileext = ".fas") fns[4] <- tempfile(pattern = "guidetree", tmpdir = tempdir(), fileext = ".nwk") unlink(fns[file.exists(fns)]) ## Write input sequences x to file x <- as.list(x) labels.bak <- names(x) names(x) <- paste0("Id", 1:length(x)) write.FASTA(x, fns[1]) ## Run muscle for X if (noy) { opts <- paste("-in", fns[1], "-out", fns[3]) ## add input guide tree if (!missing(guide.tree)) { if (!inherits(guide.tree, "phylo")) stop("object 'guide.tree' is not of class \"phylo\"") if (length(setdiff(labels.bak, guide.tree$tip.label))) stop("guide tree does not match sequence names") guide.tree$tip.label[match(guide.tree$tip.label, labels.bak)] <- names(x) if (!is.binary(guide.tree)) guide.tree <- multi2di(guide.tree) if (is.null(guide.tree$edge.length)) guide.tree$edge.length <- rep(1, Nedge(guide.tree)) write.tree(guide.tree, fns[4]) opts <- paste(opts, paste("-usetree_nowarn", fns[4])) } } else { y <- as.list(y) labels.baky <- names(y) names(y) <- paste0("Id", length(x) + 1:length(y)) write.FASTA(y, fns[2]) opts <- paste("-profile", "-in1", fns[1],"-in2", fns[2], "-out", fns[3]) } if (quiet) opts <- paste(opts, "-quiet") opts <- paste(opts, MoreArgs) out <- system(paste(exec, opts)) if (out == 127) stop(.errorAlignment(exec, "MUSCLE")) res <- as.matrix(read.FASTA(fns[3], type)) if (noy) { if (original.ordering) res <- res[labels(x), ] rownames(res) <- labels.bak } else { if (original.ordering) res <- res[c(labels(x), labels(y)), ] rownames(res) <- c(labels.bak, labels.baky) } unlink(fns[file.exists(fns)]) if (missing(file)) return(res) else write.FASTA(res, file) } tcoffee <- function(x, exec = "t_coffee", MoreArgs = "", quiet = TRUE, original.ordering = TRUE) { if (missing(x)) { out <- system(exec) if (out == 127) stop(.errorAlignment(exec, "T-Coffee")) return(invisible(NULL)) } x <- as.list(x) labels.bak <- names(x) names(x) <- paste0("Id", 1:length(x)) d <- tempdir() od <- setwd(d) on.exit(setwd(od)) inf <- "input_tcoffee.fas" write.dna(x, inf, "fasta") opts <- paste(inf, MoreArgs) if (quiet) opts <- paste(opts, "-quiet=nothing") out <- system(paste(exec, opts)) if (out == 127) stop(.errorAlignment(exec, "T-Coffee")) res <- read.dna("input_tcoffee.aln", "clustal") if (original.ordering) res <- res[labels(x), ] rownames(res) <- labels.bak res } ape/R/Cheverud.R0000644000176200001440000000666714164530562013135 0ustar liggesusers## Cheverud.R (2004-10-29) ## Cheverud's 1985 Autoregression Model ## Copyright 2004 Julien Dutheil ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. # This function is adapted from a MatLab code from # Rholf, F. J. (2001) Comparative Methods for the Analysis of Continuous Variables: Geometric Interpretations. # Evolution 55(11): 2143-2160 compar.cheverud <- function(y, W, tolerance=1e-6, gold.tol=1e-4) { ## fix by Michael Phelan diag(W) <- 0 # ensure diagonal is zero ## end of fix y <- as.matrix(y) if(dim(y)[2] != 1) stop("Error: y must be a single column vector.") D <- solve(diag(apply(t(W),2,sum))) Wnorm <- D %*% W #Row normalize W matrix n <- dim(y)[1] m <- dim(y)[2] y <- y-matrix(rep(1, n)) %*% apply(y,2,mean) # Deviations from mean Wy <- Wnorm %*% y Wlam <- eigen(Wnorm)$values # eigenvalues of W # Find distinct eigenvalues sorted <- sort(Wlam) # Check real: for (ii in 1:n) { if(abs(Im(sorted[ii])) > 1e-12) { warning(paste("Complex eigenvalue coerced to real:", Im(sorted[ii]))) } sorted[ii] <- Re(sorted[ii]) # Remove imaginary part } sorted <- as.double(sorted) Distinct <- numeric(0) Distinct[1] <- -Inf Distinct[2] <- sorted[1] nDistinct <- 2 for(ii in 2:n) { if(sorted[ii] - Distinct[nDistinct] > tolerance) { nDistinct <- nDistinct + 1 Distinct[nDistinct] <- sorted[ii] } } # Search for minimum of LL likelihood <- function(rhohat) { DetProd <- 1 for(j in 1:n) { prod <- 1 - rhohat * Wlam[j] DetProd <- DetProd * prod } absValDet <- abs(DetProd) #[abs to allow rho > 1] logDet <- log(absValDet) LL <- log(t(y) %*% y - 2 * rhohat * t(y) %*% Wy + rhohat * rhohat * t(Wy) %*% Wy) - logDet*2/n return(LL) } GoldenSearch <- function(ax, cx) { # Golden section search over the interval ax to cx # Return rhohat and likelihood value. r <- 0.61803399 x0 <- ax x3 <- cx bx <- (ax + cx)/2 if(abs(cx - bx) > abs(bx - ax)) { x1 <- bx x2 <- bx + (1-r)*(cx - bx) } else { x2 <- bx x1 <- bx - (1-r)*(bx - ax) } f1 <- likelihood(x1) f2 <- likelihood(x2) while(abs(x3 - x0) > gold.tol*(abs(x1) + abs(x2))) { if(f2 < f1) { x0 <- x1 x1 <- x2 x2 <- r * x1 + (1 - r) * x3 f1 <- f2 f2 <- likelihood(x2) } else { x3 <- x2 x2 <- x1 x1 <- r * x2 + (1 - r) * x0 f2 <- f1 f1 <- likelihood(x1) } } if(f1 < f2) { likelihood <- f1 xmin <- x1 } else { likelihood <- f2 xmin <- x2 } return(list(rho=xmin, LL=likelihood)) } LL <- Inf for(ii in 2:(nDistinct -1)) {# Search between pairs of roots # [ constrain do not use positive roots < 1] ax <- 1/Distinct[ii] cx <- 1/Distinct[ii+1] GS <- GoldenSearch(ax, cx) if(GS$LL < LL) { LL <- GS$LL rho <- GS$rho } } # Compute residuals: res <- y - rho * Wy return(list(rhohat=rho, Wnorm=Wnorm, residuals=res)) } #For debugging: #W<- matrix(c( # 0,1,1,2,0,0,0,0, # 1,0,1,2,0,0,0,0, # 1,1,0,2,0,0,0,0, # 2,2,2,0,0,0,0,0, # 0,0,0,0,0,1,1,2, # 0,0,0,0,1,0,1,2, # 0,0,0,0,1,1,0,2, # 0,0,0,0,2,2,2,0 #),8) #W <- 1/W #W[W == Inf] <- 0 #y<-c(-0.12,0.36,-0.1,0.04,-0.15,0.29,-0.11,-0.06) #compar.cheverud(y,W) # #y<-c(10,8,3,4) #W <- matrix(c(1,1/6,1/6,1/6,1/6,1,1/2,1/2,1/6,1/2,1,1,1/6,1/2,1,1), 4) #compar.cheverud(y,W) ape/R/MPR.R0000644000176200001440000000404014164530562012005 0ustar liggesusers## MPR.R (2010-08-10) ## Most Parsimonious Reconstruction ## Copyright 2010 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. MPR <- function(x, phy, outgroup) { if (is.rooted(phy)) stop("the tree must be unrooted") if (!is.binary.phylo(phy)) stop("the tree must be fully dichotomous") if (length(outgroup) > 1L) stop("outgroup must be a single tip") if (is.character(outgroup)) outgroup <- which(phy$tip.label == outgroup) if (!is.null(names(x))) { if (all(names(x) %in% phy$tip.label)) x <- x[phy$tip.label] else warning("the names of 'x' and the tip labels of the tree do not match: the former were ignored in the analysis.") } n <- length(phy$tip.label) if (is.null(phy$node.label)) phy$node.label <- n + 1:(phy$Nnode) phy <- drop.tip(root(phy, outgroup), outgroup) n <- n - 1L m <- phy$Nnode phy <- reorder(phy, "postorder") root.state <- x[outgroup] I <- as.integer(x[-outgroup]) I[n + 1:m] <- NA I <- cbind(I, I) # interval map med <- function(x) { i <- length(x)/2 sort(x)[c(i, i + 1L)] } ## 1st pass s <- seq(from = 1, by = 2, length.out = m) anc <- phy$edge[s, 1] des <- matrix(phy$edge[, 2], ncol = 2, byrow = TRUE) for (i in 1:m) I[anc[i], ] <- med(I[des[i, ], ]) ## 2nd pass out <- matrix(NA, m, 2) colnames(out) <- c("lower", "upper") ## do the most basal node before looping Iw <- as.vector(I[des[m, ], ]) # interval maps of the descendants out[anc[m] - n, ] <- range(med(c(root.state, root.state, Iw))) for (i in (m - 1):1) { j <- anc[i] Iw <- as.vector(I[des[i, ], ]) # interval maps of the descendants k <- which(phy$edge[, 2] == j) # find the ancestor tmp <- out[phy$edge[k, 1] - n, ] out[j - n, 1] <- min(med(c(tmp[1], tmp[1], Iw))) out[j - n, 2] <- max(med(c(tmp[2], tmp[2], Iw))) } rownames(out) <- phy$node.label out } ape/R/subtreeplot.R0000644000176200001440000000306514164530562013725 0ustar liggesusers## subtreeplot.R (2017-05-26) ## Zoom on a Portion of a Phylogeny by Successive Clicks ## Copyright 2008 Damien de Vienne ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. subtreeplot<-function(x, wait=FALSE, ...) { sub<-subtrees(x, wait=wait) y<-NULL plot.default(0, type="n",axes=FALSE, ann=FALSE) repeat { split.screen(c(1,2)) screen(2) if (is.null(y)) plot(x,...) else plot(y,sub=paste("Node :", click),...) screen(1) plot(x,sub="Complete tree",main="Type ESC or right click to exit", cex.main=0.9, ...) N.tip<-Ntip(x) N.node<-Nnode(x) # 5/24/17 changed by Klaus # coor<-plotPhyloCoor(x) lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) tips<-x$tip.label nodes<-x$node.label if (is.null(x$node.label)) nodes<-(N.tip+1):(N.tip+N.node) labs<-c(rep("",N.tip), nodes) #click<-identify(coor[,1], coor[,2], labels=labs, n=1) click<-identify(lastPP$xx, lastPP$yy, labels=labs, n=1) if (length(click) == 0) {return(y)} if (click > N.tip) { close.screen(c(1,2),all.screens = TRUE) split.screen(c(1,2)) screen(1) #selects the screen to plot in plot(x, sub="Complete tree", ...) # plots x in screen 1 (left) screen(2) for (i in 1:length(sub)) if (sub[[i]]$name==click) break y<-sub[[i]] } else cat("this is a tip, you have to choose a node\n") } on.exit(return(y)) } ape/R/chronos.R0000644000176200001440000005231214164530562013027 0ustar liggesusers## chronos.R (2021-09-23) ## Molecular Dating With Penalized and Maximum Likelihood ## Copyright 2013-2021 Emmanuel Paradis, 2018-2020 Santiago Claramunt, 2020 Guillaume Louvel ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .chronos.ctrl <- list(tol = 1e-8, iter.max = 1e4, eval.max = 1e4, nb.rate.cat = 10, dual.iter.max = 20, epsilon = 1e-6) makeChronosCalib <- function(phy, node = "root", age.min = 1, age.max = age.min, interactive = FALSE, soft.bounds = FALSE) { n <- Ntip(phy) if (interactive) { plot(phy) cat("Click close to a node and enter the ages (right-click to exit)\n\n") node <- integer() age.min <- age.max <- numeric() repeat { ans <- identify(phy, quiet = TRUE) if (is.null(ans)) break NODE <- ans$nodes nodelabels(node = NODE, col = "white", bg = "blue") cat("constraints for node ", NODE, sep = "") cat("\n youngest age: ") AGE.MIN <- as.numeric(readLines(n = 1)) cat(" oldest age (ENTER if not applicable): ") AGE.MAX <- as.numeric(readLines(n = 1)) node <- c(node, NODE) age.min <- c(age.min, AGE.MIN) age.max <- c(age.max, AGE.MAX) } s <- is.na(age.max) if (any(s)) age.max[s] <- age.min[s] } else { if (identical(node, "root")) node <- n + 1L } if (any(node <= n)) stop("node numbers should be greater than the number of tips") diff.age <- which(age.max < age.min) if (length(diff.age)) { msg <- "'old age' less than 'young age' for node" if (length(diff.age) > 1) msg <- paste(msg, "s", sep = "") stop(paste(msg, paste(node[diff.age], collapse = ", "))) } data.frame(node, age.min, age.max, soft.bounds = soft.bounds) } next.calib <- function(y, ini.time) # added by GL (2020-01-29) { times <- ini.time[y] runs.na <- rle(is.na(times)) next.calib.i <- cumsum(runs.na$lengths)[runs.na$values] + 1 ini.time[y[next.calib.i]] ##return(ncal) #if(length(ncal)){ncal}else{-1}) } chronos.control <- function(...) { dots <- list(...) x <- .chronos.ctrl if (length(dots)) { chk.nms <- names(dots) %in% names(x) if (any(!chk.nms)) { warning("some control parameter names do not match: they were ignored") dots <- dots[chk.nms] } x[names(dots)] <- dots } x } chronos <- function(phy, lambda = 1, model = "correlated", quiet = FALSE, calibration = makeChronosCalib(phy), control = chronos.control()) { model <- match.arg(tolower(model), c("correlated", "relaxed", "discrete", "clock")) if (model == "clock") { model <- "discrete" control$nb.rate.cat <- 1 } n <- Ntip(phy) ROOT <- n + 1L m <- phy$Nnode el <- phy$edge.length if (is.null(el)) stop("the tree has no branch lengths") if (any(el < 0)) stop("some branch lengths are negative") e1 <- phy$edge[, 1L] e2 <- phy$edge[, 2L] N <- length(e1) TIPS <- 1:n EDGES <- 1:N tol <- control$tol node <- calibration$node age.min <- calibration$age.min age.max <- calibration$age.max ## Starting points of node ages to *estimate*. Calibrated nodes can be NA. age.start <- # added by GL (2020-01-29) if (is.null(calibration$age.start)) rep(NA_real_, length(node)) else calibration$age.start if (model == "correlated") { ### `basal' contains the indices of the basal edges ### (ie, linked to the root): basal <- which(e1 == ROOT) Nbasal <- length(basal) ### 'ind1' contains the index of all nonbasal edges, and 'ind2' the ### index of the edges where these edges come from (ie, they contain ### pairs of contiguous edges), eg: ### ___b___ ind1 ind2 ### | | || | ### ___a___| | b || a | ### | | c || a | ### |___c___ | || | ind1 <- EDGES[-basal] ind2 <- match(e1[EDGES[-basal]], e2) } age <- numeric(n + m) lfactorial.el <- lfactorial(el) # Calculate the factorials here once (SC) ### This bit sets 'ini.time' and should result in no negative branch lengths if (!quiet) cat("\nSetting initial dates...\n") seq.nod <- .Call(seq_root2tip, phy$edge, n, phy$Nnode) ## 'fact.root' is used to approximate the age of the root if it is not given; ## it is multiplied by 1.5 every 100 tries of the initiation loop (see below) ## (added 2017-11-21) fact.root <- 3 ii <- 1L repeat { ini.time <- age ini.time[ROOT:(n + m)] <- NA ##ini.time[node] <- ## if (is.null(age.max)) age.min ## else runif(length(node), age.min, age.max) # (age.min + age.max) / 2 ## added by GL (2020-01-29): ini.time[node] <- ifelse(is.na(age.start), if (is.null(age.max)) age.min else runif(length(node), age.min, age.max), age.start) ## if no age given for the root, find one approximately: if (is.na(ini.time[ROOT])) ini.time[ROOT] <- fact.root * max(if (is.null(age.max)) age.min else age.max) ##ISnotNA.ALL <- unlist(lapply(seq.nod, function(x) sum(!is.na(ini.time[x])))) ##o <- order(ISnotNA.ALL, decreasing = TRUE) ## added by GL (2020-01-29): ## For each path to the leaves, return the calibrations following the last NA. calibs.after.NA <- lapply(seq.nod, next.calib, ini.time) ## This recycles shorter elements, but doesn't matter with the order() function L <- max(sapply(calibs.after.NA, length)) calibs.df <- as.data.frame(do.call(rbind, lapply(calibs.after.NA, function(r) c(r, rep(-1, L - length(r)))))) o <- do.call(order, c(calibs.df, decreasing = TRUE)) for (y in seq.nod[o]) { ISNA <- is.na(ini.time[y]) if (any(ISNA)) { i <- 2L # we know the 1st value is not NA, so we start at the 2nd one while (i <= length(y)) { if (ISNA[i]) { # we stop at the next NA j <- i + 1L while (ISNA[j]) j <- j + 1L # look for the next non-NA nb.val <- j - i by <- (ini.time[y[i - 1L]] - ini.time[y[j]]) / (nb.val + 1) ini.time[y[i:(j - 1L)]] <- ini.time[y[i - 1L]] - by * seq_len(nb.val) i <- j + 1L } else i <- i + 1L } } } if (all(ini.time[e1] - ini.time[e2] >= 0)) break ii <- ii + 1L if (ii > 1000) stop("cannot find reasonable starting dates after 1000 tries: maybe you need to adjust the calibration dates") if (!(ii %% 100)) fact.root <- fact.root * 1.5 } ### 'ini.time' set #ini.time[ROOT:(n+m)] <- branching.times(chr.dis) ## ini.time[ROOT:(n+m)] <- ini.time[ROOT:(n+m)] + rnorm(m, 0, 5) #print(ini.time) ### Setting 'ini.rate' ini.rate <- el/(ini.time[e1] - ini.time[e2]) if (model == "discrete") { Nb.rates <- control$nb.rate.cat if (Nb.rates > N) { Nb.rates <- N warning("'nb.rate.cat' > number of branches: used nb.rate.cat = # of branches instead", call. = FALSE) } minmax <- range(ini.rate) if (Nb.rates == 1) { ini.rate <- sum(minmax)/2 } else { ##inc <- diff(minmax)/Nb.rates ##ini.rate <- seq(minmax[1] + inc/2, minmax[2] - inc/2, inc) ini.rate <- quantile(ini.rate, seq(1/(2 * Nb.rates), by = 1/Nb.rates, length.out = Nb.rates)) names(ini.rate) <- NULL ini.freq <- rep(1/Nb.rates, Nb.rates - 1) lower.freq <- rep(0, Nb.rates - 1) upper.freq <- rep(1, Nb.rates - 1) } } else Nb.rates <- N ## 'ini.rate' set ### Setting bounds for the node ages ## `unknown.ages' will contain the index of the nodes of unknown age: unknown.ages <- 1:m + n ## initialize vectors for all nodes: lower.age <- rep(tol, m) upper.age <- rep(1/tol, m) lower.age[node - n] <- age.min upper.age[node - n] <- age.max ## find nodes known within an interval: ii <- which(is.na(age.min) | (age.min != age.max)) ## drop them from 'node' since they will be estimated: if (length(ii)) { node <- node[-ii] if (length(node)) age[node] <- age.min[-ii] # update 'age' } else age[node] <- age.min ## finally adjust the 3 vectors: if (length(node)) { unknown.ages <- unknown.ages[n - node] # 'n - node' is simplification for '-(node - n)' lower.age <- lower.age[n - node] upper.age <- upper.age[n - node] } ### Bounds for the node ages set ## 'known.ages' contains the index of all nodes ## (internal and terminal) of known age: known.ages <- c(TIPS, node) ## the bounds for the rates: lower.rate <- rep(tol, Nb.rates) upper.rate <- rep(1e5 - tol, Nb.rates) ### Gradient degree_node <- tabulate(phy$edge) eta_i <- degree_node[e1] eta_i[e2 <= n] <- 1L ## eta_i[i] is the number of contiguous branches for branch 'i' ## use of a list of indices is slightly faster than an incidence matrix ## and takes much less memory (60 Kb vs. 8 Mb for n = 500) X <- vector("list", N) for (i in EDGES) { j <- integer() if (e1[i] != ROOT) j <- c(j, which(e2 == e1[i])) if (e2[i] >= n) j <- c(j, which(e1 == e2[i])) X[[i]] <- j } ## X is a list whose i-th element gives the indices of the branches ## that are contiguous to branch 'i' ## D_ki and A_ki are defined in the SI of the paper D_ki <- match(unknown.ages, e2) A_ki <- lapply(unknown.ages, function(x) which(x == e1)) gradient.poisson <- function(rate, node.time) { age[unknown.ages] <- node.time real.edge.length <- age[e1] - age[e2] ## gradient for the rates: gr <- el/rate - real.edge.length ## gradient for the dates: tmp <- el/real.edge.length - rate tmp2 <- tmp[D_ki] tmp2[is.na(tmp2)] <- 0 gr.dates <- sapply(A_ki, function(x) sum(tmp[x])) - tmp2 c(gr, gr.dates) } ## gradient of the penalized lik (must be multiplied by -1 before calling nlminb) gradient <- switch(model, "correlated" = function(rate, node.time) { gr <- gradient.poisson(rate, node.time) #if (all(gr == 0)) return(gr) ## contribution of the penalty for the rates: gr[RATE] <- gr[RATE] - lambda * 2 * (eta_i * rate - sapply(X, function(x) sum(rate[x]))) ## the contribution of the root variance term: if (Nbasal == 1) { return(gr) } if (Nbasal == 2) { # the simpler formulae if there's a basal dichotomy i <- basal[1] j <- basal[2] gr[i] <- gr[i] - lambda * (rate[i] - rate[j]) gr[j] <- gr[j] - lambda * (rate[j] - rate[i]) return(gr) } ## Nbasal > 2 -- the general case for (i in 1:Nbasal) { j <- basal[i] gr[j] <- gr[j] - lambda*2*(rate[j]*(1 - 1/Nbasal) - sum(rate[basal[-i]])/Nbasal)/(Nbasal - 1) } gr }, "relaxed" = function(rate, node.time) { gr <- gradient.poisson(rate, node.time) #if (all(gr == 0)) return(gr) ## contribution of the penalty for the rates: mean.rate <- mean(rate) ## rank(rate)/Nb.rates is the same than ecdf(rate)(rate) but faster gr[RATE] <- gr[RATE] + lambda*2*dgamma(rate, mean.rate)*(rank(rate)/Nb.rates - pgamma(rate, mean.rate)) gr }, "discrete" = NULL) log.lik.poisson <- function(rate, node.time) { age[unknown.ages] <- node.time real.edge.length <- age[e1] - age[e2] if (isTRUE(any(real.edge.length < 0))) return(-1e100) B <- rate * real.edge.length sum(el * log(B) - B - lfactorial.el) } ## New function for incorporating multiple rate categories (by SC). ## This one calculates the conditional probability for each branch ## and rate regime, and then computes a weighted average (using the ## frequencies as weights) before summing logs across branches. log.lik.poisson.discrete <- function(rate, node.time, freq) { Freqs <- c(freq, 1 - sum(freq)) age[unknown.ages] <- node.time real.edge.length <- age[e1] - age[e2] if (any(real.edge.length < 0)) return(-1e+100) ## generate a matrix of branch length rates under each rate regime: B <- real.edge.length %*% t(rate) ## generate a matrix of likelihood values PPs <- exp(el * log(B) - B - lfactorial.el) ## matrix multiplication to obtain the weigthed sums for each ## branch (the average likelihoods), then sum the ## log-likelihoods to obtain the tree likelihood: sum(log(PPs %*% Freqs)) } ### penalized log-likelihood penal.loglik <- switch(model, "correlated" = function(rate, node.time) { loglik <- log.lik.poisson(rate, node.time) if (!is.finite(loglik)) return(-1e100) res <- loglik - lambda * sum((rate[ind1] - rate[ind2])^2) if (Nbasal > 1) res <- res + lambda * var(rate[basal]) res }, "relaxed" = function(rate, node.time) { loglik <- log.lik.poisson(rate, node.time) if (!is.finite(loglik)) return(-1e100) mu <- mean(rate) ## loglik - lambda * sum((1:N/N - pbeta(sort(rate), mu/(1 + mu), 1))^2) # avec loi beta ## loglik - lambda * sum((1:N/N - pcauchy(sort(rate)))^2) # avec loi Cauchy loglik - lambda * sum((1:N/N - pgamma(sort(rate), mean(rate)))^2) # avec loi Gamma }, "discrete" = if (Nb.rates == 1) function(rate, node.time) log.lik.poisson(rate, node.time) else function(rate, node.time, freq) { if (sum(freq) > 1) return(-1e100) ## rate.freq <- sum(c(freq, 1 - sum(freq)) * rate) ## log.lik.poisson(rate.freq, node.time) log.lik.poisson.discrete(rate, node.time, freq) # by SC }) opt.ctrl <- list(eval.max = control$eval.max, iter.max = control$iter.max) ## the following capitalized vectors give the indices of ## the parameters once they are concatenated in 'p' RATE <- 1:Nb.rates AGE <- Nb.rates + 1:length(unknown.ages) if (model == "discrete") { if (Nb.rates == 1) { start.para <- c(ini.rate, ini.time[unknown.ages]) f <- function(p) -penal.loglik(p[RATE], p[AGE]) g <- NULL LOW <- c(lower.rate, lower.age) UP <- c(upper.rate, upper.age) } else { FREQ <- length(RATE) + length(AGE) + 1:(Nb.rates - 1) start.para <- c(ini.rate, ini.time[unknown.ages], ini.freq) f <- function(p) -penal.loglik(p[RATE], p[AGE], p[FREQ]) g <- NULL LOW <- c(lower.rate, lower.age, lower.freq) UP <- c(upper.rate, upper.age, upper.freq) } } else { start.para <- c(ini.rate, ini.time[unknown.ages]) f <- function(p) -penal.loglik(p[RATE], p[AGE]) g <- function(p) -gradient(p[RATE], p[AGE]) LOW <- c(lower.rate, lower.age) UP <- c(upper.rate, upper.age) } k <- length(LOW) # number of free parameters if (!quiet) cat("Fitting in progress... get a first set of estimates\n") out <- nlminb(start.para, f, g, control = opt.ctrl, lower = LOW, upper = UP) if (model == "discrete") { if (Nb.rates == 1) { f.rates <- function(p) -penal.loglik(p, current.ages) f.ages <- function(p) -penal.loglik(current.rates, p) } else { f.rates <- function(p) -penal.loglik(p, current.ages, current.freqs) f.ages <- function(p) -penal.loglik(current.rates, p, current.freqs) f.freqs <- function(p) -penal.loglik(current.rates, current.ages, p) g.freqs <- NULL } g.rates <- NULL g.ages <- NULL } else { f.rates <- function(p) -penal.loglik(p, current.ages) g.rates <- function(p) -gradient(p, current.ages)[RATE] f.ages <- function(p) -penal.loglik(current.rates, p) g.ages <- function(p) -gradient(current.rates, p)[AGE] } current.ploglik <- -out$objective current.rates <- out$par[RATE] current.ages <- out$par[AGE] if (model == "discrete" && Nb.rates > 1) current.freqs <- out$par[FREQ] dual.iter.max <- control$dual.iter.max epsilon <- control$epsilon i <- 1L # was 0L (2020-05-08) if (!quiet) cat(" (Penalised) log-lik =", current.ploglik, "\n") repeat { if (dual.iter.max < 1) break if (i > dual.iter.max) { # added this break here (with a warning) instead of after optimizations (SC) warning("Maximum number of dual iterations reached.", call. = FALSE) break } if (!quiet) cat("Optimising rates...") out.rates <- nlminb(current.rates, f.rates, g.rates,# h.rates, control = list(eval.max = 1000, iter.max = 1000, step.min = 1e-8, step.max = .1), lower = lower.rate, upper = upper.rate) new.rates <- out.rates$par if (-out.rates$objective > current.ploglik) current.rates <- new.rates if (model == "discrete" && Nb.rates > 1) { if (!quiet) cat(" frequencies...") out.freqs <- nlminb(current.freqs, f.freqs, control = list(eval.max = 1000, iter.max = 1000, step.min = .001, step.max = .5), lower = lower.freq, upper = upper.freq) new.freqs <- out.freqs$par } if (!quiet) cat(" dates...") out.ages <- nlminb(current.ages, f.ages, g.ages,# h.ages, control = list(eval.max = 1000, iter.max = 1000, step.min = .001, step.max = 100), lower = lower.age, upper = upper.age) new.ploglik <- -out.ages$objective if (!quiet) cat("", current.ploglik, "\n") delta.ploglik <- new.ploglik - current.ploglik if (is.na(delta.ploglik)) break # fix by Daniel Lang if (delta.ploglik > epsilon) { current.ploglik <- new.ploglik current.rates <- new.rates current.ages <- out.ages$par if (model == "discrete" && Nb.rates > 1) current.freqs <- new.freqs out <- out.ages i <- i + 1L } else break } ## if (!quiet) cat("\nDone.\n") if (model == "discrete") { ## rate.freq <- logLik <- if (Nb.rates == 1) log.lik.poisson(current.rates, current.ages) else log.lik.poisson.discrete(current.rates, current.ages, current.freqs) ## else mean(c(current.freqs, 1 - sum(current.freqs)) * current.rates) ## logLik <- log.lik.poisson(rate.freq, current.ages) PHIIC <- list(logLik = logLik, k = k, PHIIC = -2 * logLik + 2 * k) } else { logLik <- log.lik.poisson(current.rates, current.ages) PHI <- switch(model, "correlated" = (current.rates[ind1] - current.rates[ind2])^2 + ifelse(Nbasal == 1, 0, var(current.rates[basal])), "relaxed" = (1:N/N - pgamma(sort(current.rates), mean(current.rates)))^2) # avec loi Gamma PHIIC <- list(logLik = logLik, k = k, lambda = lambda, PHIIC = -2 * logLik + 2 * k + lambda * svd(PHI)$d) } attr(phy, "call") <- match.call() attr(phy, "ploglik") <- -out$objective attr(phy, "rates") <- current.rates #out$par[EDGES] if (model == "discrete" && Nb.rates > 1) attr(phy, "frequencies") <- c(current.freqs, 1 - sum(current.freqs)) attr(phy, "convergence") <- if (out$convergence == 0) TRUE else FALSE attr(phy, "message") <- out$message attr(phy, "PHIIC") <- PHIIC attr(phy, "niter") <- i age[unknown.ages] <- current.ages #out$par[-EDGES] phy$edge.length <- age[e1] - age[e2] if(!attr(phy, "convergence")) warning(attr(phy, "message"), call. = FALSE) if (!quiet) cat("\nlog-Lik =", logLik, "\nPHIIC =", round(PHIIC$PHIIC, 2),"\n") class(phy) <- c("chronos", class(phy)) phy } print.chronos <- function(x, ...) { cat("\n Chronogram\n\n") cat("Call: ") print(attr(x, "call")) cat("\n") NextMethod("print") } ape/R/read.caic.R0000644000176200001440000000416114164530562013164 0ustar liggesusers## read.caic.R (2005-09-21) ## Read Tree File in CAIC Format ## Copyright 2005 Julien Dutheil ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. read.caic <- function(file, brlen=NULL, skip = 0, comment.char="#", ...) { text <- scan(file = file, what = character(), sep="\n", skip = skip, comment.char = comment.char, ...) # Parse the whole file: n <- length(text) / 2 nodes <- 1:n; leaf.names <- character(n) patterns <- character(n) lengths <- numeric(n) for(i in 1:n) { leaf.names[i] <- text[2*i] patterns[i] <- text[2*i-1] lengths[i] <- nchar(patterns[i]) } # Sort all patterns if not done: i <- order(patterns); leaf.names <- leaf.names[i] patterns <- patterns[i] lengths <- lengths[i] # This inner function compares two patterns: test.patterns <- function(p1, p2) { t1 <- strsplit(p1, split="")[[1]] t2 <- strsplit(p2, split="")[[1]] if(length(t1) == length(t2)) { l <- length(t1) if(l==1) return(TRUE) return(all(t1[1:(l-1)]==t2[1:(l-1)]) & t1[l] != t2[l]) } return(FALSE) } # The main loop: while(length(nodes) > 1) { # Recompute indexes: index <- logical(length(nodes)) maxi <- max(lengths) for(i in 1:length(nodes)) { index[i] <- lengths[i] == maxi } i <- 1 while(i <= length(nodes)) { if(index[i]) { p <- paste("(",nodes[i],sep="") c <- i+1 while(c <= length(nodes) && index[c] && test.patterns(patterns[i], patterns[c])) { p <- paste(p, nodes[c], sep=",") c <- c+1 } if(c-i < 2) stop("Unvalid format.") p <- paste(p, ")", sep="") nodes[i] <- p patterns[i]<- substr(patterns[i],1,nchar(patterns[i])-1) lengths[i] <- lengths[i]-1 nodes <- nodes [-((i+1):(c-1))] lengths <- lengths [-((i+1):(c-1))] patterns <- patterns[-((i+1):(c-1))] index <- index [-((i+1):(c-1))] } i <- i+1 } } # Create a 'phylo' object and return it: phy <- read.tree(text=paste(nodes[1],";", sep="")) phy$tip.label <- leaf.names; if(!is.null(brlen)) { br <- read.table(file=brlen) phy$edge.length <- br[,1] } return(phy) } ape/R/evonet.R0000644000176200001440000001727214164530562012662 0ustar liggesusers## evonet.R (2017-07-28) ## Evolutionary Networks ## Copyright 2011-2012 Emmanuel Paradis, 2017 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. evonet <- function(phy, from, to = NULL) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo".') if (!is.rooted(phy)) warning("the tree is unrooted") x <- phy if (is.null(to)) { if (is.data.frame(from)) from <- as.matrix(from) if (!is.matrix(from)) stop("'from' must be a matrix or a data frame if 'to' is not given") if (ncol(from) > 2) { warning("'from' has more than two columns: only the first two will be used.") ret <- from[, 1:2] } else if (ncol(from) < 2) { stop("'from' must have at least two columns") } else ret <- from } else { from <- as.vector(from) to <- as.vector(to) if (length(from) != length(to)) stop("'from' and 'to' not of the same length after coercing as vectors") ret <- cbind(from, to) } ## check that values are not out of range: storage.mode(ret) <- "integer" if (any(is.na(ret))) stop("some values are NA's after coercing as integers") if (any(ret < 0) || any(ret > Ntip(phy) + phy$Nnode)) stop("some values are out of range") x$reticulation <- ret class(x) <- c("evonet", "phylo") x } as.phylo.evonet <- function(x, ...) { x$reticulation <- NULL class(x) <- "phylo" x } plot.evonet <- function(x, col = "blue", lty = 1, lwd = 1, alpha = 0.5, arrows = 0, arrow.type = "classical", ...) { ## changed 5/24/17 by Klaus plot.phylo(x, ...) edges(x$reticulation[, 1], x$reticulation[, 2], col = rgb(t(col2rgb(col)), alpha = 255 * alpha, maxColorValue = 255), lty = lty, lwd = lwd, arrows = arrows, type = arrow.type) } as.networx.evonet <- function(x, weight = NA, ...) { if (any(x$reticulation <= Ntip(x))) stop("some tips are involved in reticulations: cannot convert to \"networx\"") x <- reorder(x, "postorder") ned <- Nedge(x) nrt <- nrow(x$reticulation) x$edge <- rbind(x$edge, x$reticulation) colnames(x$edge) <- c("oldNodes", "newNodes") x$reticulation <- NULL x$edge.length <- c(x$edge.length, rep(weight, length.out = nrt)) x$split <- c(1:ned, 1:nrt) class(x) <- c("networx", "phylo") x } as.network.evonet <- function(x, directed = TRUE, ...) { class(x) <- NULL x$edge <- rbind(x$edge, x$reticulation) as.network.phylo(x, directed = directed, ...) } as.igraph.evonet <- function(x, directed = TRUE, use.labels = TRUE, ...) { class(x) <- NULL x$edge <- rbind(x$edge, x$reticulation) ## added check by Klaus (2017-05-26) if (use.labels) { if (!is.null(x$node.label)){ tmp <- nchar(x$node.label) if (any(tmp == 0)){ newLabel <- paste0("number", 1:x$Nnode) x$node.label[tmp == 0] <- newLabel[tmp == 0] } } if (any(duplicated(c(x$tip.label, x$node.label)))) stop("Duplicated labels!") } as.igraph.phylo(x, directed = directed, use.labels = use.labels, ...) } print.evonet <- function(x, ...) { nr <- nrow(x$reticulation) cat("\n Evolutionary network with", nr, "reticulation") if (nr > 1) cat("s") cat("\n\n --- Base tree ---") print.phylo(as.phylo(x)) } ## new stuff by Klaus (2017-05-26) reorder.evonet <- function(x, order = "cladewise", index.only = FALSE, ...) { reticulation <- x$reticulation y <- reorder(as.phylo(x), order = order, index.only = index.only, ...) if (index.only) return(y) y$reticulation <- reticulation class(y) <- c("evonet", "phylo") y } ## requires topo_sort from igraph, behaviour different from phylo ## (postorder seems to work fine) ## if no singletons are in edge reorder.phylo could be used ## if (getRversion() >= "2.15.1") utils::globalVariables(c("topo_sort", "graph")) ## reorder.evonet <- function(x, order = "cladewise", index.only = FALSE, ...) ## { ## order <- match.arg(order, c("cladewise", "postorder")) ## if (!is.null(attr(x, "order"))) ## if (attr(x, "order") == order) return(x) ## g <- graph(t(x$edge)) ## neword <- if (order == "cladewise") topo_sort(g, "out") else topo_sort(g, "in") ## neworder <- order(match(x$edge[, 1], neword)) ## if (index.only) return(neworder) ## x$edge <- x$edge[neworder, ] ## if (!is.null(x$edge.length)) x$edge.length <- x$edge.length[neworder] ## attr(x, "order") <- order ## x ## } as.evonet <- function(x, ...) { if (inherits(x, "evonet")) return(x) UseMethod("as.evonet") } as.evonet.phylo <- function(x, ...) { pos <- grep("#", x$tip.label) ind <- match(pos, x$edge[, 2]) reticulation <- x$edge[ind, , drop = FALSE] edge <- x$edge[-ind, , drop = FALSE] nTips <- as.integer(length(x$tip.label)) reticulation[, 2] <- as.integer(match(x$tip.label[pos], x$node.label) + nTips) for (i in sort(pos, TRUE)) { edge[edge > i ] <- edge[edge > i] - 1L reticulation[reticulation > i] <- reticulation[reticulation > i] - 1L } x$tip.label <- x$tip.label[-pos] nTips <- as.integer(length(x$tip.label)) nn <- length(unique(edge[,1])) if(nn < x$Nnode){ ne <- as.integer( x$Nnode - nn ) edge[edge > nTips] <- edge[edge > nTips] + ne reticulation[reticulation > nTips] <- reticulation[reticulation > nTips] +ne z <- logical(max(edge)) z[edge[, 2]] <- TRUE z[seq_len(nTips)] <- FALSE z[edge[, 1]] <- FALSE pos2 <- which(z) k <- 1 for (i in sort(pos2, TRUE)) { nTips <- as.integer( nTips + 1L ) edge[edge==i] <- nTips reticulation[reticulation == i] <- nTips edge[edge > i] <- edge[edge > i] - 1L reticulation[reticulation > i] <- reticulation[reticulation > i] - 1L } x$Nnode <- nn x$node.label <- NULL x$tip.label <- c(x$tip.label , rep("", ne)) } x$edge <- edge x$reticulation <- reticulation if (!is.null(x$edge.length)) x$edge.length <- x$edge.length[-ind] class(x) <- c("evonet", "phylo") x } ## requires new version of clado.build and tree.build read.evonet <- function(file = "", text = NULL, comment.char = "", ...) { x <- read.tree(file = file, text = text, comment.char = comment.char, ...) as.evonet.phylo(x) } .evonet2phylo <- function(x) { nTips <- as.integer(length(x$tip.label)) if (!is.null(x$edge.length)) { nd <- node.depth.edgelength(x) x$edge.length <- c(x$edge.length, nd[x$reticulation[, 2]] - nd[x$reticulation[, 1]]) } if (!is.null(x$node.label)) x$tip.label <- c(x$tip.label, x$node.label[x$reticulation[, 2] - nTips]) else { newLabels <- paste0("#H", x$reticulation[, 2]) x$tip.label <- c(x$tip.label, newLabels) x$node.label <- rep("", x$Nnode) ind <- which((x$reticulation[, 2] > nTips) & !duplicated(x$reticulation[, 2])) x$node.label[x$reticulation[ind, 2] - nTips] <- newLabels[ind] } nrets <- as.integer(nrow(x$reticulation)) x$edge[x$edge > nTips] <- x$edge[x$edge > nTips] + nrets x$reticulation[, 1] <- x$reticulation[, 1] + nrets x$reticulation[, 2] <- nTips + (1L:nrets) x$edge <- rbind(x$edge, x$reticulation) x$reticulation <- NULL attr(x, "order") <- NULL class(x) <- "phylo" x } write.evonet <- function(x, file = "", ...) { x <- .evonet2phylo(x) write.tree(x, file = file, ...) } Nedge.evonet <- function(phy) dim(phy$edge)[1] + dim(phy$reticulation)[1] ape/R/subtrees.R0000644000176200001440000000207614164530562013212 0ustar liggesusers## subtrees.R (2008-04-14) ## All subtrees of a Phylogenetic Tree ## Copyright 2008 Damien de Vienne ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. subtrees<-function(tree, wait = FALSE) { N.tip<-Ntip (tree) N.node<-Nnode(tree) limit<-N.tip+N.node sub<-list(N.node) u<-0 for (k in (N.tip+1):limit) { u<-u+1 if (wait==TRUE) cat("wait... Node",u,"out of", N.node, "treated\n") fils<-NULL pere<-res <- k repeat { for (i in 1: length(pere)) fils<-c(fils, tree$edge[,2][tree$edge[,1]==pere[i]]) res<-c(res, fils) pere<-fils fils<-NULL if (length(pere)==0) break } len<-res[res>N.tip] if (u==1) { tree2<-tree len<-(N.tip+1):limit } else { len.tip<-res[res do we need to check the value(s) in 'tip'? ##if (any(tip > Ntip + phy$Nnode) || any(tip < 1)) ## stop("value(s) out of range in 'tip'") ## rootnd <- Ntip + 1L pars <- integer(phy$Nnode) # worst case assignment, usually far too long tnd <- if (is.character(tip)) match(tip, phy$tip.label) else tip done_v <- logical(Ntip + phy$Nnode) ## build a lookup table to get parents faster pvec <- integer(Ntip + phy$Nnode) pvec[phy$edge[, 2]] <- phy$edge[, 1] ## get entire lineage for first tip nd <- tnd[1] for (k in 1:phy$Nnode) { nd <- pvec[nd] pars[k] <- nd if (nd == rootnd) break } pars <- pars[1:k] # delete the rest mrcind <- integer(max(pars)) mrcind[pars] <- 1:k mrcand <- pars[1] ## traverse lineages for remaining tips, stop if hit common ancestor for (i in 2:length(tnd)) { cnd <- tnd[i] done <- done_v[cnd] while(!done){ done_v[cnd] <- TRUE cpar <- pvec[cnd] # get immediate parent done <- done_v[cpar] # early exit if TRUE if (cpar %in% pars) { if (cpar == rootnd) return(rootnd) # early exit if(mrcind[cpar] > mrcind[mrcand]) mrcand <- cpar done_v[cpar] <- TRUE done <- TRUE } cnd <- cpar # keep going! } } mrcand } which.edge <- function(phy, group) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') if (is.character(group)) group <- which(phy$tip.label %in% group) if (length(group) == 1) return(match(group, phy$edge[, 2])) n <- length(phy$tip.label) sn <- .Call(seq_root2tip, phy$edge, n, phy$Nnode)[group] i <- 2L repeat { x <- unique(unlist(lapply(sn, "[", i))) if (length(x) != 1) break i <- i + 1L } d <- -(1:(i - 1L)) x <- unique(unlist(lapply(sn, function(x) x[d]))) match(x, phy$edge[, 2L]) } ape/R/extract.popsize.R0000644000176200001440000000520014164530562014510 0ustar liggesusers## extract.popsize.R (2004-07-4) ## Extract table with population size in dependence of time ## from mcmc output generated by mcmc.popsize ## Copyright 2004 Rainer Opgen-Rhein and Korbinian Strimmer ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. extract.popsize<-function(mcmc.out, credible.interval=0.95, time.points=200, thinning=1, burn.in=0) { # construct a matrix with the positions of the jumps b<-burn.in+1 i<-1 k<-array(dim=ceiling((length(mcmc.out$pos)-burn.in)/thinning)) while(i<=length(k)) { k[i]<-length(mcmc.out$pos[[b]]); (i<-i+1); b<-b+thinning } o<-max(k) b<-burn.in+1 i<-1 pos.m<-matrix(nrow=length(k), ncol=o) while(i<=length(k)) { pos.m[i,]<-c(mcmc.out$pos[[b]], array(dim=o-length(mcmc.out$pos[[b]]))); i<-i+1; b<-b+thinning } # construct a matrix with the heights of the jumps b<-burn.in+1 i<-1 h.m<-matrix(nrow=length(k), ncol=o) while(i<=length(k)) { h.m[i,]<-c(mcmc.out$h[[b]], array(dim=o-length(mcmc.out$h[[b]]))); i<-i+1; b<-b+thinning } prep<-list("pos"=pos.m, "h"=h.m) #################### step <- (max(prep$pos, na.rm=TRUE)-min(prep$pos, na.rm=TRUE))/(time.points-1) nr <- time.points p<-min(prep$pos, na.rm=TRUE) i<-1 me<-matrix(nrow=nr, ncol=5) prep.l<-prep prep.l$pos<-cbind(prep$pos,prep$pos[,length(prep$pos[1,])]) prep.l$h<-cbind(prep$h,prep$h[,length(prep$h[1,])]) while (p<=max(prep$pos, na.rm=TRUE)) { #Vector with position of heights l.prep<-prep$pos<=p l.prep[is.na(l.prep)]<-FALSE pos.of.h<-l.prep%*% array(data=1, dim=dim(prep$pos)[2]) #Vector with heights z<-array(data=(1:dim(prep$pos)[1]), dim=dim(prep$pos)[1]) index.left<-cbind(z,pos.of.h) index.right<-cbind(z, pos.of.h+1) mixed.heights<-((((p-prep$pos[index.left])/(prep$pos[index.right]-prep$pos[index.left]))* (prep$h[index.right]-prep$h[index.left]))+prep$h[index.left]) me[i,2]<-mean(mixed.heights) #library(MASS) #me[i,2]<-huber(mixed.heights)$mu me[i,3]<-median(mixed.heights) me[i,4]<-quantile(mixed.heights, probs=(1-credible.interval)/2, na.rm=TRUE) me[i,5]<-quantile(mixed.heights, probs=(1+credible.interval)/2, na.rm=TRUE) me[i,1]<-p p<-p+step i<-i+1 } #av.jumps<-round((length(prep$pos)-sum(is.na(prep$pos)))/length(prep$pos[,1])-2,2) #print("average jumps") #print((length(prep$pos)-sum(is.na(prep$pos)))/length(prep$pos[,1])-2) colnames(me) <- c("time", "mean", "median", "lower CI", "upper CI") class(me) <- "popsize" return(me) } ape/R/def.R0000644000176200001440000000122314164530562012105 0ustar liggesusers## def.R (2014-10-24) ## Definition of Vectors for Plotting or Annotating ## Copyright 2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. def <- function(x, ..., default = NULL, regexp = FALSE) { dots <- list(...) if (is.null(default)) { if (is.numeric(dots[[1L]])) default <- 1 if (is.character(dots[[1L]])) default <- "black" } foo <- if (regexp) function(vec, y) grep(y, vec) else function(vec, y) which(vec == y) res <- rep(default, length(x)) nms <- names(dots) for (i in seq_along(nms)) res[foo(x, nms[i])] <- dots[[i]] res } ape/R/triangMtd.R0000644000176200001440000000244014164530562013302 0ustar liggesusers## treePop.R (2011-10-11) ## Tree Reconstruction With the Triangles Method ## Copyright 2011 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. triangMtd <- function(X) { if (is.matrix(X)) X <- as.dist(X) if (any(is.na(X))) stop("missing values are not allowed in the distance matrix") N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_triangMtd, as.double(X), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), NAOK = TRUE) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } triangMtds <- function(X) { if (is.matrix(X)) X <- as.dist(X) X[is.na(X)] <- -1 X[X < 0] <- -1 N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_triangMtds, as.double(X), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), NAOK = TRUE) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } ape/R/write.nexus.R0000644000176200001440000000434414164530562013651 0ustar liggesusers## write.nexus.R (2017-09-08) ## Write Tree File in Nexus Format ## Copyright 2003-2017 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. write.nexus <- function(..., file = "", translate = TRUE) { obj <- .getTreesFromDotdotdot(...) ntree <- length(obj) cat("#NEXUS\n", file = file) cat(paste("[R-package APE, ", date(), "]\n\n", sep = ""), file = file, append = TRUE) N <- length(obj[[1]]$tip.label) cat("BEGIN TAXA;\n", file = file, append = TRUE) cat(paste("\tDIMENSIONS NTAX = ", N, ";\n", sep = ""), file = file, append = TRUE) cat("\tTAXLABELS\n", file = file, append = TRUE) cat(paste("\t\t", obj[[1]]$tip.label, sep = ""), sep = "\n", file = file, append = TRUE) cat("\t;\n", file = file, append = TRUE) cat("END;\n", file = file, append = TRUE) cat("BEGIN TREES;\n", file = file, append = TRUE) if (translate) { cat("\tTRANSLATE\n", file = file, append = TRUE) obj <- .compressTipLabel(obj) X <- paste("\t\t", 1:N, "\t", attr(obj, "TipLabel"), ",", sep = "") ## We remove the last comma: X[length(X)] <- gsub(",", "", X[length(X)]) cat(X, file = file, append = TRUE, sep = "\n") cat("\t;\n", file = file, append = TRUE) class(obj) <- NULL for (i in 1:ntree) obj[[i]]$tip.label <- as.character(1:N) } else { if (is.null(attr(obj, "TipLabel"))) { for (i in 1:ntree) obj[[i]]$tip.label <- checkLabel(obj[[i]]$tip.label) } else { attr(obj, "TipLabel") <- checkLabel(attr(obj, "TipLabel")) obj <- .uncompressTipLabel(obj) } } title <- names(obj) if (is.null(title)) title <- rep("UNTITLED", ntree) else { if (any(s <- title == "")) title[s] <- "UNTITLED" } for (i in 1:ntree) { if (class(obj[[i]]) != "phylo") next root.tag <- if (is.rooted(obj[[i]])) "= [&R] " else "= [&U] " cat("\tTREE *", title[i], root.tag, file = file, append = TRUE) cat(write.tree(obj[[i]], file = ""), "\n", sep = "", file = file, append = TRUE) } cat("END;\n", file = file, append = TRUE) } ape/R/plot.phylo.R0000644000176200001440000010252314164530562013464 0ustar liggesusers## plot.phylo.R (2021-09-17) ## Plot Phylogenies ## Copyright 2002-2021 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, node.pos = NULL, show.tip.label = TRUE, show.node.label = FALSE, edge.color = NULL, edge.width = NULL, edge.lty = NULL, node.color = NULL, node.width = NULL, node.lty = NULL, font = 3, cex = par("cex"), adj = NULL, srt = 0, no.margin = FALSE, root.edge = FALSE, label.offset = 0, underscore = FALSE, x.lim = NULL, y.lim = NULL, direction = "rightwards", lab4ut = NULL, tip.color = par("col"), plot = TRUE, rotate.tree = 0, open.angle = 0, node.depth = 1, align.tip.label = FALSE, ...) { Ntip <- length(x$tip.label) if (Ntip < 2) { warning("found fewer than 2 tips in the tree") return(NULL) } .nodeHeight <- function(edge, Nedge, yy) .C(node_height, as.integer(edge[, 1]), as.integer(edge[, 2]), as.integer(Nedge), as.double(yy))[[4]] .nodeDepth <- function(Ntip, Nnode, edge, Nedge, node.depth) .C(node_depth, as.integer(Ntip), as.integer(edge[, 1]), as.integer(edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), as.integer(node.depth))[[5]] .nodeDepthEdgelength <- function(Ntip, Nnode, edge, Nedge, edge.length) .C(node_depth_edgelength, as.integer(edge[, 1]), as.integer(edge[, 2]), as.integer(Nedge), as.double(edge.length), double(Ntip + Nnode))[[5]] Nedge <- dim(x$edge)[1] Nnode <- x$Nnode if (any(x$edge < 1) || any(x$edge > Ntip + Nnode)) stop("tree badly conformed; cannot plot. Check the edge matrix.") ROOT <- Ntip + 1 type <- match.arg(type, c("phylogram", "cladogram", "fan", "unrooted", "radial")) direction <- match.arg(direction, c("rightwards", "leftwards", "upwards", "downwards")) if (is.null(x$edge.length)) { use.edge.length <- FALSE } else { if (use.edge.length && type != "radial") { tmp <- sum(is.na(x$edge.length)) if (tmp) { warning(paste(tmp, "branch length(s) NA(s): branch lengths ignored in the plot")) use.edge.length <- FALSE } } } if (is.numeric(align.tip.label)) { align.tip.label.lty <- align.tip.label align.tip.label <- TRUE } else { # assumes is.logical(align.tip.labels) == TRUE if (align.tip.label) align.tip.label.lty <- 3 } if (align.tip.label) { if (type %in% c("unrooted", "radial") || !use.edge.length || is.ultrametric(x)) align.tip.label <- FALSE } ## the order of the last two conditions is important: if (type %in% c("unrooted", "radial") || !use.edge.length || is.null(x$root.edge) || !x$root.edge) root.edge <- FALSE phyloORclado <- type %in% c("phylogram", "cladogram") horizontal <- direction %in% c("rightwards", "leftwards") xe <- x$edge # to save if (phyloORclado) { ## we first compute the y-coordinates of the tips. phyOrder <- attr(x, "order") ## make sure the tree is in cladewise order: if (is.null(phyOrder) || phyOrder != "cladewise") { x <- reorder(x) # fix from Klaus Schliep (2007-06-16) if (!identical(x$edge, xe)) { ## modified from Li-San Wang's fix (2007-01-23): ereorder <- match(x$edge[, 2], xe[, 2]) if (length(edge.color) > 1) { edge.color <- rep(edge.color, length.out = Nedge) edge.color <- edge.color[ereorder] } if (length(edge.width) > 1) { edge.width <- rep(edge.width, length.out = Nedge) edge.width <- edge.width[ereorder] } if (length(edge.lty) > 1) { edge.lty <- rep(edge.lty, length.out = Nedge) edge.lty <- edge.lty[ereorder] } } } ### By contrats to ape (< 2.4), the arguments edge.color, etc., are ### not elongated before being passed to segments(), except if needed ### to be reordered yy <- numeric(Ntip + Nnode) TIPS <- x$edge[x$edge[, 2] <= Ntip, 2] yy[TIPS] <- 1:Ntip } ## 'z' is the tree in postorder order used in calls to .C z <- reorder(x, order = "postorder") if (phyloORclado) { if (is.null(node.pos)) node.pos <- if (type == "cladogram" && !use.edge.length) 2 else 1 if (node.pos == 1) { yy <- .nodeHeight(z$edge, Nedge, yy) } else { ## node_height_clado requires the number of descendants ## for each node, so we compute `xx' at the same time ans <- .C(node_height_clado, as.integer(Ntip), as.integer(z$edge[, 1]), as.integer(z$edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), as.double(yy)) xx <- ans[[5]] - 1 yy <- ans[[6]] } if (!use.edge.length) { if (node.pos != 2) xx <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) - 1 xx <- max(xx) - xx } else { xx <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length) } } else { twopi <- 2 * pi rotate.tree <- twopi * rotate.tree/360 if (type != "unrooted") { # for "fan" and "radial" trees (open.angle) ## if the tips are not in the same order in tip.label ## and in edge[, 2], we must reorder the angles: we ## use `xx' to store temporarily the angles TIPS <- x$edge[which(x$edge[, 2] <= Ntip), 2] xx <- seq(0, twopi * (1 - 1/Ntip) - twopi * open.angle/360, length.out = Ntip) theta <- double(Ntip) theta[TIPS] <- xx theta <- c(theta, numeric(Nnode)) } switch(type, "fan" = { theta <- .nodeHeight(z$edge, Nedge, theta) if (use.edge.length) { r <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length) } else { r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) max_r <- max(r) r <- (max_r - r + 1) / max_r } theta <- theta + rotate.tree if (root.edge) r <- r + x$root.edge xx <- r * cos(theta) yy <- r * sin(theta) }, "unrooted" = { nb.sp <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) XY <- if (use.edge.length) unrooted.xy(Ntip, Nnode, z$edge, z$edge.length, nb.sp, rotate.tree) else unrooted.xy(Ntip, Nnode, z$edge, rep(1, Nedge), nb.sp, rotate.tree) ## rescale so that we have only positive values xx <- XY$M[, 1] - min(XY$M[, 1]) yy <- XY$M[, 2] - min(XY$M[, 2]) }, "radial" = { r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) r[r == 1] <- 0 r <- 1 - r/Ntip theta <- .nodeHeight(z$edge, Nedge, theta) + rotate.tree xx <- r * cos(theta) yy <- r * sin(theta) }) } if (phyloORclado) { if (!horizontal) { tmp <- yy yy <- xx xx <- tmp - min(tmp) + 1 } if (root.edge) { if (direction == "rightwards") xx <- xx + x$root.edge if (direction == "upwards") yy <- yy + x$root.edge } } if (no.margin) par(mai = rep(0, 4)) if (show.tip.label) nchar.tip.label <- nchar(x$tip.label) max.yy <- max(yy) ## Function to compute the axis limit ## x: vector of coordinates, must be positive (or at least the largest value) ## lab: vector of labels, length(x) == length(lab) ## sin: size of the device in inches getLimit <- function(x, lab, sin, cex) { s <- strwidth(lab, "inches", cex = cex) # width of the tip labels ## if at least one string is larger than the device, ## give 1/3 of the plot for the tip labels: if (any(s > sin)) return(1.5 * max(x)) Limit <- 0 while (any(x > Limit)) { i <- which.max(x) ## 'alp' is the conversion coeff from inches to user coordinates: alp <- x[i]/(sin - s[i]) Limit <- x[i] + alp*s[i] x <- x + alp*s } Limit } if (is.null(x.lim)) { if (phyloORclado) { if (horizontal) { ## 1.04 comes from that we are using a regular axis system ## with 4% on both sides of the range of x: ## REMOVED (2017-06-14) xx.tips <- xx[1:Ntip]# * 1.04 if (show.tip.label) { pin1 <- par("pin")[1] # width of the device in inches tmp <- getLimit(xx.tips, x$tip.label, pin1, cex) tmp <- tmp + label.offset } else tmp <- max(xx.tips) x.lim <- c(0, tmp) } else x.lim <- c(1, Ntip) } else switch(type, "fan" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.018 * max.yy * cex) x.lim <- range(xx) + c(-offset, offset) } else x.lim <- range(xx) }, "unrooted" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.018 * max.yy * cex) x.lim <- c(0 - offset, max(xx) + offset) } else x.lim <- c(0, max(xx)) }, "radial" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.03 * cex) x.lim <- c(-1 - offset, 1 + offset) } else x.lim <- c(-1, 1) }) } else if (length(x.lim) == 1) { x.lim <- c(0, x.lim) if (phyloORclado && !horizontal) x.lim[1] <- 1 if (type %in% c("fan", "unrooted") && show.tip.label) x.lim[1] <- -max(nchar.tip.label * 0.018 * max.yy * cex) if (type == "radial") x.lim[1] <- if (show.tip.label) -1 - max(nchar.tip.label * 0.03 * cex) else -1 } ## mirror the xx: if (phyloORclado && direction == "leftwards") xx <- x.lim[2] - xx if (is.null(y.lim)) { if (phyloORclado) { if (horizontal) y.lim <- c(1, Ntip) else { pin2 <- par("pin")[2] # height of the device in inches ## 1.04 comes from that we are using a regular axis system ## with 4% on both sides of the range of x: ## REMOVED (2017-06-14) yy.tips <- yy[1:Ntip]# * 1.04 if (show.tip.label) { tmp <- getLimit(yy.tips, x$tip.label, pin2, cex) tmp <- tmp + label.offset } else tmp <- max(yy.tips) y.lim <- c(0, tmp) } } else switch(type, "fan" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.018 * max.yy * cex) y.lim <- c(min(yy) - offset, max.yy + offset) } else y.lim <- c(min(yy), max.yy) }, "unrooted" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.018 * max.yy * cex) y.lim <- c(0 - offset, max.yy + offset) } else y.lim <- c(0, max.yy) }, "radial" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.03 * cex) y.lim <- c(-1 - offset, 1 + offset) } else y.lim <- c(-1, 1) }) } else if (length(y.lim) == 1) { y.lim <- c(0, y.lim) if (phyloORclado && horizontal) y.lim[1] <- 1 if (type %in% c("fan", "unrooted") && show.tip.label) y.lim[1] <- -max(nchar.tip.label * 0.018 * max.yy * cex) if (type == "radial") y.lim[1] <- if (show.tip.label) -1 - max(nchar.tip.label * 0.018 * max.yy * cex) else -1 } ## mirror the yy: if (phyloORclado && direction == "downwards") yy <- y.lim[2] - yy # fix by Klaus if (phyloORclado && root.edge) { if (direction == "leftwards") x.lim[2] <- x.lim[2] + x$root.edge if (direction == "downwards") y.lim[2] <- y.lim[2] + x$root.edge } asp <- if (type %in% c("fan", "radial", "unrooted")) 1 else NA # fixes by Klaus Schliep (2008-03-28 and 2010-08-12) plot.default(0, type = "n", xlim = x.lim, ylim = y.lim, xlab = "", ylab = "", axes = FALSE, asp = asp, ...) if (plot) { if (is.null(adj)) adj <- if (phyloORclado && direction == "leftwards") 1 else 0 if (phyloORclado && show.tip.label) { MAXSTRING <- max(strwidth(x$tip.label, cex = cex)) loy <- 0 if (direction == "rightwards") { lox <- label.offset + MAXSTRING * 1.05 * adj } if (direction == "leftwards") { lox <- -label.offset - MAXSTRING * 1.05 * (1 - adj) ##xx <- xx + MAXSTRING } if (!horizontal) { psr <- par("usr") MAXSTRING <- MAXSTRING * 1.09 * (psr[4] - psr[3])/(psr[2] - psr[1]) loy <- label.offset + MAXSTRING * 1.05 * adj lox <- 0 srt <- 90 + srt if (direction == "downwards") { loy <- -loy ##yy <- yy + MAXSTRING srt <- 180 + srt } } } if (type == "phylogram") { phylogram.plot(x$edge, Ntip, Nnode, xx, yy, horizontal, edge.color, edge.width, edge.lty, node.color, node.width, node.lty) } else { if (is.null(edge.color)) { edge.color <- par('fg') } if (is.null(edge.width)) { edge.width <- par('lwd') } if (is.null(edge.lty)) { edge.lty <- par('lty') } if (type == "fan") { ereorder <- match(z$edge[, 2], x$edge[, 2]) if (length(edge.color) > 1) { edge.color <- rep_len(edge.color, Nedge) edge.color <- edge.color[ereorder] } if (length(edge.width) > 1) { edge.width <- rep_len(edge.width, Nedge) edge.width <- edge.width[ereorder] } if (length(edge.lty) > 1) { edge.lty <- rep_len(edge.lty, Nedge) edge.lty <- edge.lty[ereorder] } circular.plot(z$edge, Ntip, Nnode, xx, yy, theta, r, edge.color, edge.width, edge.lty) } else cladogram.plot(x$edge, xx, yy, edge.color, edge.width, edge.lty) } if (root.edge) { rootcol <- if (length(edge.color) == 1) edge.color else par("fg") rootw <- if (length(edge.width) == 1) edge.width else par("lwd") rootlty <- if (length(edge.lty) == 1) edge.lty else par("lty") if (type == "fan") { tmp <- polar2rect(x$root.edge, theta[ROOT]) segments(0, 0, tmp$x, tmp$y, col = rootcol, lwd = rootw, lty = rootlty) } else { switch(direction, "rightwards" = segments(0, yy[ROOT], x$root.edge, yy[ROOT], col = rootcol, lwd = rootw, lty = rootlty), "leftwards" = segments(xx[ROOT], yy[ROOT], xx[ROOT] + x$root.edge, yy[ROOT], col = rootcol, lwd = rootw, lty = rootlty), "upwards" = segments(xx[ROOT], 0, xx[ROOT], x$root.edge, col = rootcol, lwd = rootw, lty = rootlty), "downwards" = segments(xx[ROOT], yy[ROOT], xx[ROOT], yy[ROOT] + x$root.edge, col = rootcol, lwd = rootw, lty = rootlty)) } } if (show.tip.label) { if (is.expression(x$tip.label)) underscore <- TRUE if (!underscore) x$tip.label <- gsub("_", " ", x$tip.label) if (phyloORclado) { if (align.tip.label) { xx.tmp <- switch(direction, "rightwards" = max(xx[1:Ntip]), "leftwards" = min(xx[1:Ntip]), "upwards" = xx[1:Ntip], "downwards" = xx[1:Ntip]) yy.tmp <- switch(direction, "rightwards" = yy[1:Ntip], "leftwards" = yy[1:Ntip], "upwards" = max(yy[1:Ntip]), "downwards" = min(yy[1:Ntip])) segments(xx[1:Ntip], yy[1:Ntip], xx.tmp, yy.tmp, lty = align.tip.label.lty) } else { xx.tmp <- xx[1:Ntip] yy.tmp <- yy[1:Ntip] } text(xx.tmp + lox, yy.tmp + loy, x$tip.label, adj = adj, font = font, srt = srt, cex = cex, col = tip.color) } else { angle <- if (type == "unrooted") XY$axe else atan2(yy[1:Ntip], xx[1:Ntip]) # in radians lab4ut <- if (is.null(lab4ut)) { if (type == "unrooted") "horizontal" else "axial" } else match.arg(lab4ut, c("horizontal", "axial")) xx.tips <- xx[1:Ntip] yy.tips <- yy[1:Ntip] if (label.offset) { xx.tips <- xx.tips + label.offset * cos(angle) yy.tips <- yy.tips + label.offset * sin(angle) } if (lab4ut == "horizontal") { y.adj <- x.adj <- numeric(Ntip) sel <- abs(angle) > 0.75 * pi x.adj[sel] <- -strwidth(x$tip.label)[sel] * 1.05 sel <- abs(angle) > pi/4 & abs(angle) < 0.75 * pi x.adj[sel] <- -strwidth(x$tip.label)[sel] * (2 * abs(angle)[sel] / pi - 0.5) sel <- angle > pi / 4 & angle < 0.75 * pi y.adj[sel] <- strheight(x$tip.label)[sel] / 2 sel <- angle < -pi / 4 & angle > -0.75 * pi y.adj[sel] <- -strheight(x$tip.label)[sel] * 0.75 text(xx.tips + x.adj * cex, yy.tips + y.adj * cex, x$tip.label, adj = c(adj, 0), font = font, srt = srt, cex = cex, col = tip.color) } else { # if lab4ut == "axial" if (align.tip.label) { POL <- rect2polar(xx.tips, yy.tips) POL$r[] <- max(POL$r) REC <- polar2rect(POL$r, POL$angle) xx.tips <- REC$x yy.tips <- REC$y segments(xx[1:Ntip], yy[1:Ntip], xx.tips, yy.tips, lty = align.tip.label.lty) } if (type == "unrooted") { adj <- abs(angle) > pi/2 angle <- angle * 180/pi # switch to degrees angle[adj] <- angle[adj] - 180 adj <- as.numeric(adj) } else { s <- xx.tips < 0 angle <- angle * 180/pi angle[s] <- angle[s] + 180 adj <- as.numeric(s) } ## `srt' takes only a single value, so can't vectorize this: ## (and need to 'elongate' these vectors:) font <- rep(font, length.out = Ntip) tip.color <- rep(tip.color, length.out = Ntip) cex <- rep(cex, length.out = Ntip) for (i in 1:Ntip) text(xx.tips[i], yy.tips[i], x$tip.label[i], font = font[i], cex = cex[i], srt = angle[i], adj = adj[i], col = tip.color[i]) } } } if (show.node.label) text(xx[ROOT:length(xx)] + label.offset, yy[ROOT:length(yy)], x$node.label, adj = adj, font = font, srt = srt, cex = cex) } L <- list(type = type, use.edge.length = use.edge.length, node.pos = node.pos, node.depth = node.depth, show.tip.label = show.tip.label, show.node.label = show.node.label, font = font, cex = cex, adj = adj, srt = srt, no.margin = no.margin, label.offset = label.offset, x.lim = x.lim, y.lim = y.lim, direction = direction, tip.color = tip.color, Ntip = Ntip, Nnode = Nnode, root.time = x$root.time, align.tip.label = align.tip.label) assign("last_plot.phylo", c(L, list(edge = xe, xx = xx, yy = yy)), envir = .PlotPhyloEnv) invisible(L) } phylogram.plot <- function(edge, Ntip, Nnode, xx, yy, horizontal, edge.color = NULL, edge.width = NULL, edge.lty = NULL, node.color = NULL, node.width = NULL, node.lty = NULL) { nodes <- Ntip + seq_len(Nnode) if (!horizontal) { tmp <- yy yy <- xx xx <- tmp } ## un trait vertical a chaque noeud... x0v <- xx[nodes] y0v <- y1v <- numeric(Nnode) e1 <- edge[, 1] e2 <- edge[, 2] Nedge <- length(e1) ## store the index of each node in the 1st column of edge: NodeInEdge1 <- lapply(Ntip + seq_len(Nnode), function (j) which(e1 == j)) edgeChildren <- lapply(NodeInEdge1, function (nie) e2[nie]) yv <- vapply(edgeChildren, function (i) range(yy[i]), double(2)) y0v <- yv[1, ] y1v <- yv[2, ] ## ... et un trait horizontal partant de chaque tip et chaque noeud ## vers la racine x0h <- xx[e1] x1h <- xx[e2] y0h <- yy[e2] # Node and edge styling .one.style <- function (style) { list(h = rep_len(style, Nedge), v = rep_len(style, Ntip + Nnode)) } .edge.style <- function (node.style) { node.style <- rep_len(node.style, Ntip + Nnode) sapply(seq_len(Nedge), function (e) node.style[e2[e]]) } .node.style <- function (edge.style, fallback) { edge.style <- rep_len(edge.style, Nedge) c(character(Ntip), sapply(Ntip + seq_len(Nnode), function (n) { pendant.styles <- edge.style[e1 == n] if (length(unique(pendant.styles)) == 1L) { pendant.styles[1] } else { fallback } })) } .style <- function (edge.style, node.style, stylePar) { if (missing(edge.style) || is.null(edge.style)) { if (missing(node.style) || is.null(node.style)) { return(.one.style(par(stylePar))) } else { if (length(node.style) == 1L) { return(.one.style(node.style)) } else { return(list(h = .edge.style(node.style), v = rep_len(node.style, Ntip + Nnode))) } } } else if (missing(node.style) || is.null(node.style)) { if (length(edge.style) == 1L) { return(.one.style(edge.style)) } else { return(list(h = rep_len(edge.style, Nedge), v = .node.style(edge.style, par(stylePar)))) } } else { return(list(h = rep_len(edge.style, Nedge), v = rep_len(node.style, Ntip + Nnode))) } } .LtyToStr <- function (x) { if (is.numeric(x)) { c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash")[x + 1L] } else { x } } colors <- .style(edge.color, node.color, 'fg') widths <- .style(edge.width, node.width, 'lwd') ltys <- .style(.LtyToStr(edge.lty), .LtyToStr(node.lty), 'lty') edge.color <- colors$h edge.width <- widths$h edge.lty <- ltys$h color.v <- colors$v[-seq_len(Ntip)] width.v <- widths$v[-seq_len(Ntip)] lty.v <- ltys$v[-seq_len(Ntip)] DF <- data.frame(edge.color, edge.width, edge.lty, stringsAsFactors = FALSE) DF <- DF[, c(is.null(node.color), is.null(node.width), is.null(node.lty)), drop = FALSE] for (i in seq_len(Nnode)) { br <- NodeInEdge1[[i]] if (length(br) == 2) { A <- br[1] B <- br[2] # We should draw a single line if at all possible, for the # appearance of dotted / dashed line styles. if (any(DF[A, ] != DF[B, ])) { ## add a new line: y0v <- c(y0v, y0v[i]) y1v <- c(y1v, yy[i + Ntip]) x0v <- c(x0v, x0v[i]) ## shorten the old line: y0v[i] <- yy[i + Ntip] if (is.null(node.color)) { # Half-lines may have different colours color.v[i] <- edge.color[B] color.v <- c(color.v, edge.color[A]) } else { # Use node colour for both half-lines color.v <- c(color.v, color.v[i]) } if (is.null(node.width)) { width.v[i] <- edge.width[B] width.v <- c(width.v, edge.width[A]) } else { width.v <- c(width.v, width.v[i]) } if (is.null(node.lty)) { lty.v[i] <- edge.lty[B] lty.v <- c(lty.v, edge.lty[A]) } else { lty.v <- c(lty.v, lty.v[i]) } } } } if (horizontal) { # draw horizontal lines segments(x0h, y0h, x1h, y0h, col = edge.color, lwd = edge.width, lty = edge.lty) # draw vertical lines segments(x0v, y0v, x0v, y1v, col = color.v, lwd = width.v, lty = lty.v) } else { # draws vertical lines segments(y0h, x0h, y0h, x1h, col = edge.color, lwd = edge.width, lty = edge.lty) # draws horizontal lines segments(y0v, x0v, y1v, x0v, col = color.v, lwd = width.v, lty = lty.v) } } cladogram.plot <- function(edge, xx, yy, edge.color, edge.width, edge.lty) segments(xx[edge[, 1]], yy[edge[, 1]], xx[edge[, 2]], yy[edge[, 2]], col = edge.color, lwd = edge.width, lty = edge.lty) circular.plot <- function(edge, Ntip, Nnode, xx, yy, theta, r, edge.color, edge.width, edge.lty) ### 'edge' must be in postorder order { r0 <- r[edge[, 1]] r1 <- r[edge[, 2]] theta0 <- theta[edge[, 2]] costheta0 <- cos(theta0) sintheta0 <- sin(theta0) x0 <- r0 * costheta0 y0 <- r0 * sintheta0 x1 <- r1 * costheta0 y1 <- r1 * sintheta0 segments(x0, y0, x1, y1, col = edge.color, lwd = edge.width, lty = edge.lty) tmp <- which(diff(edge[, 1]) != 0) start <- c(1, tmp + 1) Nedge <- dim(edge)[1] end <- c(tmp, Nedge) ## function dispatching the features to the arcs foo <- function(edge.feat, default) { if (length(edge.feat) == 1) return(as.list(rep(edge.feat, Nnode))) edge.feat <- rep(edge.feat, length.out = Nedge) feat.arc <- as.list(rep(default, Nnode)) for (k in 1:Nnode) { tmp <- edge.feat[start[k]] if (tmp == edge.feat[end[k]]) { # fix by Francois Michonneau (2015-07-24) feat.arc[[k]] <- tmp } else { if (nodedegree[k] == 2) feat.arc[[k]] <- rep(c(tmp, edge.feat[end[k]]), each = 50) } } feat.arc } nodedegree <- tabulate(edge[, 1L])[-seq_len(Ntip)] co <- foo(edge.color, par("fg")) lw <- foo(edge.width, par("lwd")) ly <- foo(edge.lty, par("lty")) for (k in 1:Nnode) { i <- start[k] j <- end[k] X <- rep(r[edge[i, 1]], 100) Y <- seq(theta[edge[i, 2]], theta[edge[j, 2]], length.out = 100) x <- X * cos(Y); y <- X * sin(Y) x0 <- x[-100]; y0 <- y[-100]; x1 <- x[-1]; y1 <- y[-1] segments(x0, y0, x1, y1, col = co[[k]], lwd = lw[[k]], lty = ly[[k]]) } } unrooted.xy <- function(Ntip, Nnode, edge, edge.length, nb.sp, rotate.tree) { foo <- function(node, ANGLE, AXIS) { ind <- which(edge[, 1] == node) sons <- edge[ind, 2] start <- AXIS - ANGLE/2 for (i in 1:length(sons)) { h <- edge.length[ind[i]] angle[sons[i]] <<- alpha <- ANGLE*nb.sp[sons[i]]/nb.sp[node] axis[sons[i]] <<- beta <- start + alpha/2 start <- start + alpha xx[sons[i]] <<- h*cos(beta) + xx[node] yy[sons[i]] <<- h*sin(beta) + yy[node] } for (i in sons) if (i > Ntip) foo(i, angle[i], axis[i]) } Nedge <- dim(edge)[1] yy <- xx <- numeric(Ntip + Nnode) ## `angle': the angle allocated to each node wrt their nb of tips ## `axis': the axis of each branch axis <- angle <- numeric(Ntip + Nnode) ## start with the root... foo(Ntip + 1L, 2*pi, 0 + rotate.tree) M <- cbind(xx, yy) axe <- axis[1:Ntip] # the axis of the terminal branches (for export) axeGTpi <- axe > pi ## make sure that the returned angles are in [-PI, +PI]: axe[axeGTpi] <- axe[axeGTpi] - 2*pi list(M = M, axe = axe) } node.depth <- function(phy, method = 1) { n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] phy <- reorder(phy, order = "postorder") .C(node_depth, as.integer(n), as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), as.integer(N), double(n + m), as.integer(method))[[5]] } node.depth.edgelength <- function(phy) { n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] phy <- reorder(phy, order = "postorder") .C(node_depth_edgelength, as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), as.integer(N), as.double(phy$edge.length), double(n + m))[[5]] } node.height <- function(phy, clado.style = FALSE) { n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] phy <- reorder(phy) yy <- numeric(n + m) e2 <- phy$edge[, 2] yy[e2[e2 <= n]] <- 1:n phy <- reorder(phy, order = "postorder") e1 <- phy$edge[, 1] e2 <- phy$edge[, 2] if (clado.style) .C(node_height_clado, as.integer(n), as.integer(e1), as.integer(e2), as.integer(N), double(n + m), as.double(yy))[[6]] else .C(node_height, as.integer(e1), as.integer(e2), as.integer(N), as.double(yy))[[4]] } plot.multiPhylo <- function(x, layout = 1, ...) { layout(matrix(1:layout, ceiling(sqrt(layout)), byrow = TRUE)) if (!devAskNewPage() && names(dev.cur()) %in% deviceIsInteractive()) { devAskNewPage(TRUE) on.exit(devAskNewPage(FALSE)) } for (i in seq_along(x)) plot(x[[i]], ...) } trex <- function(phy, title = TRUE, subbg = "lightyellow3", return.tree = FALSE, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) devmain <- dev.cur() # where the main tree is plotted restore <- function() { dev.set(devmain) assign("last_plot.phylo", lastPP, envir = .PlotPhyloEnv) } on.exit(restore()) NEW <- TRUE cat("Click close to a node. Right-click to exit.\n") repeat { x <- identify.phylo(phy, quiet = TRUE) if (is.null(x)) return(invisible(NULL)) else { x <- x$nodes if (is.null(x)) cat("Try again!\n") else { if (NEW) { dev.new() par(bg = subbg) devsub <- dev.cur() NEW <- FALSE } else dev.set(devsub) tr <- extract.clade(phy, x) plot(tr, ...) if (is.character(title)) title(title) else if (title) { tl <- if (is.null(phy$node.label)) paste("From node #", x, sep = "") else paste("From", phy$node.label[x - Ntip(phy)]) title(tl) } if (return.tree) return(tr) restore() } } } } kronoviz <- function(x, layout = length(x), horiz = TRUE, ...) { par(mar = rep(0.5, 4), oma = rep(2, 4)) rts <- sapply(x, function(x) branching.times(x)[1]) maxrts <- max(rts) lim <- cbind(rts - maxrts, rts) Ntree <- length(x) Ntips <- sapply(x, Ntip) if (horiz) { nrow <- layout w <- 1 h <- Ntips } else { nrow <- 1 w <- Ntips h <- 1 } layout(matrix(1:layout, nrow), widths = w, heights = h) if (layout < Ntree && !devAskNewPage() && interactive()) { devAskNewPage(TRUE) on.exit(devAskNewPage(FALSE)) } if (horiz) { for (i in 1:Ntree) plot(x[[i]], x.lim = lim[i, ], ...) } else { for (i in 1:Ntree) plot(x[[i]], y.lim = lim[i, ], direction = "u", ...) } axisPhylo(if (horiz) 1 else 4) # better if the deepest tree is last ;) } ape/R/speciesTree.R0000644000176200001440000000164714164530562013634 0ustar liggesusers## speciesTree.R (2013-08-12) ## Species Trees ## Copyright 2010-2013 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. speciesTree <- function(x, FUN = min) ### FUN = min => MAXTREE (Liu et al. 2010) ### FUN = sum => shallowest divergence (Maddison & Knowles 2006) { test.ultra <- which(!unlist(lapply(x, is.ultrametric))) if (length(test.ultra)) stop(paste("the following trees were not ultrametric:\n", paste(test.ultra, collapse = " "))) Ntree <- length(x) D <- lapply(x, cophenetic.phylo) nms <- rownames(D[[1]]) n <- length(nms) M <- matrix(0, n*(n - 1)/2, Ntree) for (i in 1:Ntree) M[, i] <- as.dist(D[[i]][nms, nms]) Y <- apply(M, 1, FUN) attributes(Y) <- list(Size = n, Labels = nms, Diag = FALSE, Upper = FALSE, class = "dist") as.phylo(hclust(Y, "single")) } ape/R/ladderize.R0000644000176200001440000000247714164530562013326 0ustar liggesusers## ladderize.R (2017-04-25) ## Ladderize a Tree ## Copyright 2007-2017 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. ladderize <- function(phy, right = TRUE) { foo <- function(node, END, where) { start <- which(phy$edge[, 1] == node) end <- c(start[-1] - 1, END) size <- end - start + 1 desc <- phy$edge[start, 2] Nclade <- length(desc) n <- N[desc] o <- order(n, decreasing = right) newpos <- c(0, cumsum(size[o][-Nclade])) + where desc <- desc[o] end <- end[o] start <- start[o] neworder[newpos] <<- start for (i in 1:Nclade) if (desc[i] > nb.tip) foo(desc[i], end[i], newpos[i] + 1) } phy <- reorder(phy) # fix by Klaus (2015-10-04) nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode nb.edge <- dim(phy$edge)[1] tmp <- reorder(phy, "postorder") N <- .C(node_depth, as.integer(nb.tip), as.integer(tmp$edge[, 1]), as.integer(tmp$edge[, 2]), as.integer(nb.edge), double(nb.tip + nb.node), 1L)[[5]] neworder <- integer(nb.edge) foo(nb.tip + 1, nb.edge, 1) phy$edge <- phy$edge[neworder, ] if (!is.null(phy$edge.length)) phy$edge.length <- phy$edge.length[neworder] phy } ape/R/as.phylo.formula.R0000644000176200001440000000363414164530562014560 0ustar liggesusers## as.phylo.formula.R (2018-09-17) ## Conversion from Taxonomy Variables to Phylogenetic Trees ## Copyright 2005-2018 Julien Dutheil, 2018 Eric Marcon ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. as.phylo.formula <- function(x, data = parent.frame(), collapse = TRUE, ...) { ## Testing formula syntax: err <- "Formula must be of the kind ~A1/A2/.../An." if (length(x) != 2) stop(err) if (x[[1]] != "~") stop(err) f <- x[[2]] taxo <- list() while (length(f) == 3) { if (f[[1]] != "/") stop(err) f3.txt <- deparse(f[[3]]) if (!is.factor(data[[f3.txt]])) stop(paste("Variable", f3.txt, "must be a factor")) taxo[[f3.txt]] <- data[[f3.txt]] if (length(f) > 1) f <- f[[2]] } f.txt <- deparse(f) if (!is.factor(data[[f.txt]])) stop(paste("Variable", f.txt, "must be a factor.")) taxo[[f.txt]] <- data[[f.txt]] taxo.data <- as.data.frame(taxo) leaves.names <- as.character(taxo.data[, 1]) taxo.data[, 1] <- 1:nrow(taxo.data) ## Now builds the phylogeny: f.rec <- function(subtaxo) { # Recurrent utility function u <- ncol(subtaxo) levels <- unique(subtaxo[,u]) if (u == 1) { if (length(levels) != nrow(subtaxo)) warning("leaves names are not unique.") return(as.character(subtaxo[, 1])) } t <- character(length(levels)) for (l in 1:length(levels)) { x <- f.rec(subtaxo[subtaxo[,u] == levels[l], ][1:(u - 1)]) t[l] <- paste0("(", paste(x, collapse=","), ")", as.character(levels[l])) } t } string <- paste0("(", paste(f.rec(taxo.data), collapse = ","), ");") phy <- read.tree(text = string) if (collapse) phy <- collapse.singles(phy) phy$tip.label <- leaves.names[as.numeric(phy$tip.label)] phy } ape/R/mcmc.popsize.R0000644000176200001440000003603614164530562013770 0ustar liggesusers## mcmc.popsize.R (2013-07-19) ## Run reversible jump MCMC to sample demographic histories ## Copyright 2004-2013 Rainer Opgen-Rhein and Korbinian Strimmer ## Portions of this function are adapted from rjMCMC code by ## Karl W Broman (see http://www.biostat.wisc.edu/~kbroman/) ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. # public function # run rjMCMC chain if (getRversion() >= "2.15.1") utils::globalVariables(c("loglik", "b.lin", "popsize")) mcmc.popsize <- function(tree, nstep, thinning = 1, burn.in = 0, progress.bar = TRUE, method.prior.changepoints = c("hierarchical", "fixed.lambda"), max.nodes = 30, lambda = 0.5, # "fixed.lambda" method.prior.changepoints gamma.shape = 0.5, gamma.scale = 2, # gamma distribution from which lambda is drawn (for "hierarchical" method) method.prior.heights = c("skyline", "constant", "custom"), prior.height.mean, prior.height.var) { method.prior.changepoints <- match.arg(method.prior.changepoints) method.prior.heights <- match.arg(method.prior.heights) ## Calculate skylineplot, coalescent intervals ## and estimated population sizes if (inherits(tree, "phylo")) { ci <- coalescent.intervals(tree) sk1 <- skyline(ci) } else if (class(tree) == "coalescentIntervals") { ci <- tree sk1 <- skyline(ci) } else stop("tree must be an object of class phylo or coalescentIntervals") ## consider possibility of more than one lineage ci$lineages <- ci$lineages[sk1$interval.length > 0] ci$interval.length <- ci$interval.length[sk1$interval.length > 0] data <- sk1$time <- sk1$time[sk1$interval.length > 0] sk1$population.size <- sk1$population.size[sk1$interval.length > 0] sk1$interval.length <- sk1$interval.length[sk1$interval.length > 0] ## constant prior for heights if (method.prior.heights == "constant") { prior.height.mean <- function(position) mean(sk1$population.size) prior.height.var <- function(position) (mean(sk1$population.size))^2 } ## skyline plot prior for heights if (method.prior.heights == "skyline") { TIME <- sk1$time numb.interv <- 10 prior.change.times <- abs((0:numb.interv) * max(TIME)/numb.interv) prior.height.mean.all <- prior.height.var.all <- vector(length = numb.interv) for (p.int in 1:(numb.interv)) { left <- p.int right <- p.int + 1 sample.pop <- sk1$population.size[sk1$time >= prior.change.times[left] & sk1$time <= prior.change.times[right]] while (length(sample.pop) < 10) { if (left > 1) left <- left - 1 if (right < length(prior.change.times)) right <- right + 1 sample.pop <- sk1$population.size[sk1$time >= prior.change.times[left] & sk1$time <= prior.change.times[right]] } prior.height.mean.all[p.int] <- sum(sample.pop)/length(sample.pop) prior.height.var.all[p.int] <- sum((sample.pop-prior.height.mean.all[p.int])^2)/(length(sample.pop) - 1) } prior.height.mean <- function(position) { j <- sum(prior.change.times <= position) if (j >= length(prior.height.mean.all)) j <- length(prior.height.mean.all) prior.mean <- prior.height.mean.all[j] prior.mean } prior.height.var <- function(position) { j <- sum(prior.change.times <= position) if (j >= length(prior.height.var.all)) j <- length(prior.height.var.all) prior.var <- prior.height.var.all[j] prior.var } } if (method.prior.heights == "custom") { if (missing(prior.height.mean) || missing(prior.height.var)) stop("custom priors not specified") } ## set prior prior <- vector(length = 4) prior[4] <- max.nodes ## set initial position of markov chain and likelihood pos <- c(0, max(data)) h <- c(rep(mean(sk1$population.size), 2)) b.lin <- choose(ci$lineages, 2) ## loglik <<- loglik.pop # modified by EP ## set lists for data count.it <- floor((nstep - burn.in)/thinning) save.pos <- save.h <- vector("list", count.it) save.loglik <- 1:count.it save.steptype <- 1:count.it save.accept <- 1:count.it ## calculate jump probabilities for given lambda of the prior if (method.prior.changepoints == "fixed.lambda") { prior[1] <- lambda jump.prob <- matrix(ncol = 4, nrow = prior[4] + 1) p <- dpois(0:prior[4], prior[1])/ppois(prior[4] + 1, prior[1]) bk <- c(p[-1]/p[-length(p)], 0) bk[bk > 1] <- 1 dk <- c(0, p[-length(p)]/p[-1]) dk[dk > 1] <- 1 mx <- max(bk + dk) bk <- bk/mx*0.9 dk <- dk/mx*0.9 bk[is.na(bk)] <- 0 # added dk[is.na(dk)] <- 0 # added jump.prob[, 3] <- bk jump.prob[, 4] <- dk jump.prob[1, 2] <- 0 jump.prob[1, 1] <- 1 - bk[1] - dk[1] jump.prob[-1, 1] <- jump.prob[-1, 2] <- (1 - jump.prob[-1, 3] - jump.prob[-1, 4])/2 } ## calculate starting loglik curloglik <- loglik.pop(data, pos, h, b.lin, sk1, ci) count.i <- 1 ## set progress bar if (progress.bar == TRUE) { dev.new(width = 3, height = 0.7) par(mar = c(0.5, 0.5, 2, 0.5)) plot(x = c(0, 0), y = c(0, 1), type = "l", xlim = c(0, 1), ylim = c(0, 1), main = "rjMCMC in progress", ylab = "", xlab = "", xaxs = "i", yaxs = "i", xaxt = "n", yaxt = "n") } ## BEGIN CALCULATION for (i in (1:nstep + 1)) { if (progress.bar == TRUE) { if (i %% 100 == 0) { z <- i/nstep zt <- (i - 100)/(nstep) polygon(c(zt, zt, z, z), c(1, 0, 0, 1), col = "black") } } ## calculate jump probabilities without given lamda if (method.prior.changepoints == "hierarchical") { prior[1] <- rgamma(1, shape = gamma.shape, scale = gamma.scale) jump.prob <- matrix(ncol = 4, nrow = prior[4] + 1) p <- dpois(0:prior[4], prior[1]) / ppois(prior[4] + 1, prior[1]) bk <- c(p[-1]/p[-length(p)], 0) bk[bk > 1] <- 1 dk <- c(0, p[-length(p)]/p[-1]) dk[dk > 1] <- 1 mx <- max(bk + dk) bk <- bk/mx*0.9 dk <- dk/mx*0.9 bk[is.na(bk)] <- 0 # added dk[is.na(dk)] <- 0 # added jump.prob[, 3] <- bk jump.prob[, 4] <- dk jump.prob[1, 2] <- 0 jump.prob[1, 1] <- 1 - bk[1] - dk[1] jump.prob[-1, 1] <- jump.prob[-1, 2] <- (1 - jump.prob[-1, 3] - jump.prob[-1, 4])/2 } ## determine what type of jump to make wh <- sample(1:4, 1, prob = jump.prob[length(h)-1, ]) if (i %% thinning == 0 & i > burn.in) save.steptype[[count.i]] <- wh if (wh == 1) { step <- ht.move(data, pos, h, curloglik, prior, b.lin, sk1, ci, prior.height.mean, prior.height.var) h <- step[[1]] curloglik <- step[[2]] if (i %% thinning == 0 & i > burn.in) { save.pos[[count.i]] <- pos save.h[[count.i]] <- h save.loglik[[count.i]] <- step[[2]] save.accept[[count.i]] <- step[[3]] } } else if (wh == 2) { step <- pos.move(data, pos, h, curloglik, b.lin, sk1, ci) pos <- step[[1]] curloglik <- step[[2]] if (i %% thinning == 0 & i > burn.in) { save.pos[[count.i]] <- pos save.h[[count.i]] <- h save.loglik[[count.i]] <- step[[2]] save.accept[[count.i]] <- step[[3]] } } else if (wh == 3) { step <- birth.step(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var) pos <- step[[1]] h <- step[[2]] curloglik <- step[[3]] if (i %% thinning == 0 & i > burn.in) { save.pos[[count.i]] <- pos save.h[[count.i]] <- h save.loglik[[count.i]] <- step[[3]] save.accept[[count.i]] <- step[[4]] } } else { step <- death.step(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var) pos <- step[[1]] h <- step[[2]] curloglik <- step[[3]] if (i %% thinning == 0 & i > burn.in) { save.pos[[count.i]] <- pos save.h[[count.i]] <- h save.loglik[[count.i]] <- step[[3]] save.accept[[count.i]] <- step[[4]] } } if (i %% thinning == 0 & i > burn.in) count.i <- count.i + 1 } if (progress.bar == TRUE) dev.off() list(pos = save.pos, h = save.h, loglik = save.loglik, steptype = save.steptype, accept = save.accept) } ## private functions ht.move <- function(data, pos, h, curloglik, prior, b.lin, sk1, ci, prior.height.mean, prior.height.var) { j <- sample(1:length(h), 1) prior.mean <- prior.height.mean(pos[j]) prior.var <- prior.height.var(pos[j]) prior[3] <- prior.mean/prior.var prior[2] <- (prior.mean^2)/prior.var newh <- h newh[j] <- h[j] * exp(runif(1, -0.5, 0.5)) newloglik <- loglik.pop(data, pos, newh, b.lin, sk1, ci) lr <- newloglik - curloglik ratio <- exp(lr + prior[2] * (log(newh[j]) - log(h[j])) - prior[3] * (newh[j] - h[j])) if (runif(1, 0, 1) < ratio) return(list(newh, newloglik, 1)) else return(list(h, curloglik, 0)) } pos.move <- function(data, pos, h, curloglik, b.lin, sk1, ci) { j <- if (length(pos) == 3) 2 else sample(2:(length(pos)-1), 1) newpos <- pos left <- pos[j - 1] right <- pos[j + 1] newpos[j] <- runif(1, left, right) newloglik <- loglik.pop(data, newpos, h, b.lin, sk1, ci) lr <- newloglik - curloglik ratio <- exp(lr) * (right - newpos[j])*(newpos[j]- left)/ (right - pos[j])/(pos[j] - left) if (runif(1, 0, 1) < ratio) return(list(newpos, newloglik, 1)) else return(list(pos, curloglik, 0)) } birth.step <- function(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var) { newpos <- runif(1, 0, pos[length(pos)]) j <- sum(pos < newpos) left <- pos[j] right <- pos[j + 1] prior.mean <- prior.height.mean(pos[j]) prior.var <- prior.height.var(pos[j]) prior[3] <- prior.mean/prior.var prior[2] <- (prior.mean^2)/prior.var u <- runif(1, -0.5, 0.5) oldh <- (((newpos - left)/(right - left))*(h[j + 1] - h[j]) + h[j]) newheight <- oldh*(1 + u) ## ratio ## recall that prior = (lambda, alpha, beta, maxk) k <- length(pos) - 2 L <- max(pos) prior.logratio <- log(prior[1]) - log(k+1) + log((2*k + 3)*(2*k + 2)) - 2*log(L) + log(newpos - left) + log(right - newpos) - log(right - left) + prior[2]*log(prior[3]) - lgamma(prior[2]) + (prior[2] - 1) * log(newheight) + prior[3]*(newheight) proposal.ratio <- jump.prob[k + 2, 4]*L/jump.prob[k + 1, 3]/(k + 1) jacobian <- (((newpos - left)/(right - left))*(h[j + 1] - h[j])) + h[j] ## form new parameters newpos <- sort(c(pos, newpos)) newh <- c(h[1:j], newheight, h[(j + 1):length(h)]) newloglik <- loglik.pop(data, newpos, newh, b.lin, sk1, ci) lr <- newloglik - curloglik ratio <- exp(lr + prior.logratio) * proposal.ratio * jacobian if (runif(1, 0, 1) < ratio) return(list(newpos, newh, newloglik, 1)) else return(list(pos, h, curloglik, 0)) } death.step <- function(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var) { ## position to drop if (length(pos) == 3) j <- 2 else j <- sample(2:(length(pos) - 1), 1) left <- pos[j - 1] right <- pos[j + 1] prior.mean <- prior.height.mean(pos[j]) prior.var <- prior.height.var(pos[j]) prior[3] <- prior.mean/prior.var prior[2] <- (prior.mean^2)/prior.var ## get new height h.left <- h[j - 1] h.right <- h[j + 1] newheight <- (((pos[j] - left)/(right - left))*(h.right - h.left) + h.left) ## ratio ## recall that prior = (lambda, alpha, beta, maxk) k <- length(pos) - 3 L <- max(pos) prior.logratio <- log(k+1) - log(prior[1]) - log(2*(k + 1)*(2*k + 3)) + 2*log(L) - log(pos[j] - left) - log(right - pos[j]) + log(right - left) - prior[2]*log(prior[3]) + lgamma(prior[2]) - (prior[2]-1) * log(newheight) - prior[3]*(newheight) proposal.ratio <- (k + 1)*jump.prob[k + 1, 3]/jump.prob[k + 2, 4]/L jacobian <- ((pos[j] - left)/(right - left))*(h[j + 1] - h[j - 1]) + h[j - 1] ## form new parameters newpos <- pos[-j] newh <- h[-j] newloglik <- loglik.pop(data, newpos, newh, b.lin, sk1, ci) lr <- newloglik - curloglik ratio <- exp(lr + prior.logratio) * proposal.ratio * (jacobian^(-1)) if (runif(1, 0, 1) < ratio) return(list(newpos, newh, newloglik, 1)) else return(list(pos, h, curloglik, 0)) } # calculate the log likelihood for a set of data loglik.pop <- function(time = sk1$time, pos = c(0, max(sk1$time)), h = mean(sk1$population.size), b = b.lin, sk1, ci) { data.time <- c(0, time) leftside <- 0 i <- 1 h1 <- c(h, h[length(h)]) pos1 <- c(pos, pos[length(pos)]) while (i < length(time)) { left.pos <- sum(data.time[i + 1] >= pos) right.pos <- left.pos + 1 h.mix <- (((data.time[i + 1] - pos[left.pos])/(pos[right.pos] - pos[left.pos]))*(h[right.pos] - h[left.pos])) + h[left.pos] leftside <- leftside + log(b[i]/h.mix) i <- i + 1 } rightside <- 0 time1 <- c(0, time) time.count <- 1 ## heigths of jumps jumps <- sort(c(time1, pos)) h.jumps <- jumps while (time.count <= length(jumps)) { left.pos <- sum(jumps[time.count] >= pos) right.pos <- left.pos + 1 h.jumps[time.count] <- (((jumps[time.count] - pos[left.pos])/(pos[right.pos] - pos[left.pos]))*(h[right.pos] - h[left.pos])) + h[left.pos] if (is.na(h.jumps[time.count])) h.jumps[time.count] <- h[left.pos] time.count <- time.count + 1 } ## Vector for lineages i <- 1 lineages.jumps <- jumps while (i <= length(jumps)) { lineages.jumps[i] <- sum(jumps[i] >= time) if (lineages.jumps[i] == 0) lineages.jumps[i] <- 1 i <- i + 1 } lineage <- ci$lineages[lineages.jumps] b1 <- choose(lineage, 2) ## Integral a <- (h.jumps[-1] - h.jumps[-length(h.jumps)])/(jumps[-1] - jumps[-length(jumps)]) c <- h.jumps[-1] - jumps[-1] * a area <- (1/a) * log(a*jumps[-1] + c) - (1/a)*log(a * jumps[-length(jumps)] + c) stepfunction <- (jumps[-1] - jumps[-length(jumps)])/h.jumps[-1] area[is.na(area)] <- stepfunction[is.na(area)] rightside <- sum(area * b1[-1]) loglik <- leftside - rightside loglik } ape/R/as.bitsplits.R0000644000176200001440000000644014164530562013774 0ustar liggesusers## as.bitsplits.R (2021-12-27) ## Conversion Among Split Classes ## Copyright 2011-2021 Emmanuel Paradis, 2019 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. as.bitsplits <- function(x) UseMethod("as.bitsplits") as.bitsplits.prop.part <- function(x) { foo <- function(vect, RAWVECT) { res <- RAWVECT for (y in vect) { i <- ceiling(y/8) res[i] <- res[i] | as.raw(2^(8 - ((y - 1) %% 8) - 1)) } res } N <- length(x) # number of splits n <- length(x[[1]]) # number of tips nr <- ceiling(n/8) mat <- raw(N * nr) dim(mat) <- c(nr, N) RAWVECT <- raw(nr) for (i in 1:N) mat[, i] <- foo(x[[i]], RAWVECT) ## add the n trivial splits of size 1... : mat.bis <- raw(n * nr) dim(mat.bis) <- c(nr, n) for (i in 1:n) mat.bis[, i] <- foo(i, RAWVECT) ## ... drop the trivial split of size n... : mat <- cbind(mat.bis, mat[, -1, drop = FALSE]) ## ... update the split frequencies... : freq <- attr(x, "number") freq <- c(rep(freq[1L], n), freq[-1L]) ## ... and numbers: N <- N + n - 1L structure(list(matsplit = mat, labels = attr(x, "labels"), freq = freq), class = "bitsplits") } print.bitsplits <- function(x, ...) { n <- length(x$freq) cat("Object of class \"bitsplits\"\n") cat(" ", length(x$labels), "tips\n") cat(" ", n, "partition") if (n > 1) cat("s") cat("\n") } sort.bitsplits <- function(x, decreasing = FALSE, ...) { o <- order(x$freq, decreasing = decreasing) x$matsplit <- x$matsplit[, o] x$freq <- x$freq[o] x } as.prop.part <- function(x, ...) UseMethod("as.prop.part") as.prop.part.bitsplits <- function(x, include.trivial = FALSE, ...) { decodeBitsplits <- function(x) { f <- function(y) rev(rawToBits(y)) == as.raw(1) which(unlist(lapply(x, f))) } N <- ncol(x$matsplit) # nb of splits n <- length(x$labels) # nb of tips Nres <- if (include.trivial) N + 1L else N res <- vector("list", Nres) if (include.trivial) res[[1]] <- 1:n j <- if (include.trivial) 2L else 1L for (i in 1:N) { res[[j]] <- decodeBitsplits(x$matsplit[, i]) j <- j + 1L } attr(res, "number") <- if (include.trivial) c(N, x$freq) else x$freq attr(res, "labels") <- x$labels class(res) <- "prop.part" res } bitsplits <- function(x) { if (inherits(x, "phylo")) { x <- list(x) class(x) <- "multiPhylo" } else { if (!inherits(x, "multiPhylo")) stop('x is not of class "phylo" or "multiPhylo"') } if (any(is.rooted(x))) stop("bitsplits() accepts only unrooted trees") x <- .compressTipLabel(x) labs <- attr(x, "TipLabel") n <- length(labs) nr <- ceiling(n/8) ans <- .Call(bitsplits_multiPhylo, x, n, nr) nc <- ans[[3]] if (nc) { o <- ans[[1]][1:(nr * nc)] freq <- ans[[2]][1:nc] } else { o <- raw() freq <- integer() } dim(o) <- c(nr, nc) structure(list(matsplit = o, labels = labs, freq = freq), class = "bitsplits") } countBipartitions <- function(phy, X) { split <- bitsplits(phy) SPLIT <- bitsplits(X) .Call("CountBipartitionsFromSplits", split, SPLIT) } ape/R/pcoa.R0000644000176200001440000001510014164530562012270 0ustar liggesuserspcoa <- function(D, correction="none", rn=NULL) # # Principal coordinate analysis (PCoA) of a square distance matrix D # with correction for negative eigenvalues. # # References: # Gower, J. C. 1966. Some distance properties of latent root and vector methods # used in multivariate analysis. Biometrika. 53: 325-338. # Gower, J. C. and P. Legendre. 1986. Metric and Euclidean properties of # dissimilarity coefficients. J. Classif. 3: 5-48. # Legendre, P. and L. Legendre. 1998. Numerical ecology, 2nd English edition. # Elsevier Science BV, Amsterdam. [PCoA: Section 9.2] # # Pierre Legendre, October 2007 { centre <- function(D,n) # Centre a square matrix D by matrix algebra # mat.cen = (I - 11'/n) D (I - 11'/n) { One <- matrix(1,n,n) mat <- diag(n) - One/n mat.cen <- mat %*% D %*% mat lowtri <- lower.tri(mat.cen) mat.cen[lowtri] <- t(mat.cen)[lowtri] mat.cen } bstick.def <- function (n, tot.var = 1, ...) # 'bstick.default' from vegan { res <- rev(cumsum(tot.var/n:1)/n) names(res) <- paste("Stick", seq(len = n), sep = "") return(res) } # ===== The PCoA function begins here ===== # Preliminary actions D <- as.matrix(D) n <- nrow(D) epsilon <- sqrt(.Machine$double.eps) if(length(rn)!=0) { names <- rn } else { names <- rownames(D) } CORRECTIONS <- c("none","lingoes","cailliez") correct <- pmatch(correction, CORRECTIONS) if(is.na(correct)) stop("Invalid correction method") # cat("Correction method =",correct,'\n') # Gower centring of matrix D # delta1 = (I - 11'/n) [-0.5 d^2] (I - 11'/n) delta1 <- centre((-0.5*D^2),n) trace <- sum(diag(delta1)) # Eigenvalue decomposition D.eig <- eigen(delta1) # Negative eigenvalues? min.eig <- min(D.eig$values) zero.eig <- which(abs(D.eig$values) < epsilon) D.eig$values[zero.eig] <- 0 # No negative eigenvalue if(min.eig > -epsilon) { # Curly 1 correct <- 1 eig <- D.eig$values k <- length(which(eig > epsilon)) rel.eig <- eig[1:k]/trace cum.eig <- cumsum(rel.eig) vectors <- sweep(D.eig$vectors[,1:k, drop = FALSE], 2, sqrt(eig[1:k]), FUN="*") bs <- bstick.def(k) cum.bs <- cumsum(bs) res <- data.frame(eig[1:k], rel.eig, bs, cum.eig, cum.bs) colnames(res) <- c("Eigenvalues","Relative_eig","Broken_stick","Cumul_eig","Cumul_br_stick") rownames(res) <- 1:nrow(res) rownames(vectors) <- names colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.") note <- paste("There were no negative eigenvalues. No correction was applied") out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace)) # Negative eigenvalues present } else { # Curly 1 k <- n eig <- D.eig$values rel.eig <- eig/trace rel.eig.cor <- (eig - min.eig)/(trace - (n-1)*min.eig) # Eq. 9.27 for a single dimension if (length(zero.eig)) # by Jesse Connell rel.eig.cor <- c(rel.eig.cor[-zero.eig[1]], 0) ## the previous line replaces: ## rel.eig.cor = c(rel.eig.cor[1:(zero.eig[1]-1)], rel.eig.cor[(zero.eig[1]+1):n], 0) cum.eig.cor <- cumsum(rel.eig.cor) k2 <- length(which(eig > epsilon)) k3 <- length(which(rel.eig.cor > epsilon)) vectors <- sweep(D.eig$vectors[, 1:k2, drop = FALSE], 2, sqrt(eig[1:k2]), FUN="*") # Only the eigenvectors with positive eigenvalues are shown # Negative eigenvalues: three ways of handling the situation if((correct==2) | (correct==3)) { # Curly 2 if(correct == 2) { # Curly 3 # Lingoes correction: compute c1, then the corrected D c1 <- -min.eig note <- paste("Lingoes correction applied to negative eigenvalues: D' = -0.5*D^2 -",c1,", except diagonal elements") D <- -0.5*(D^2 + 2*c1) # Cailliez correction: compute c2, then the corrected D } else if(correct == 3) { delta2 <- centre((-0.5*D),n) upper <- cbind(matrix(0,n,n), 2*delta1) lower <- cbind(-diag(n), -4*delta2) sp.matrix <- rbind(upper, lower) c2 <- max(Re(eigen(sp.matrix, symmetric=FALSE, only.values=TRUE)$values)) note <- paste("Cailliez correction applied to negative eigenvalues: D' = -0.5*(D +",c2,")^2, except diagonal elements") D <- -0.5*(D + c2)^2 } # End curly 3 diag(D) <- 0 mat.cor <- centre(D,n) toto.cor <- eigen(mat.cor) trace.cor <- sum(diag(mat.cor)) # Negative eigenvalues present? min.eig.cor <- min(toto.cor$values) zero.eig.cor <- which((toto.cor$values < epsilon) & (toto.cor$values > -epsilon)) toto.cor$values[zero.eig.cor] <- 0 # No negative eigenvalue after correction: result OK if(min.eig.cor > -epsilon) { # Curly 4 eig.cor <- toto.cor$values rel.eig.cor <- eig.cor[1:k]/trace.cor cum.eig.cor <- cumsum(rel.eig.cor) k2 <- length(which(eig.cor > epsilon)) vectors.cor <- sweep(toto.cor$vectors[, 1:k2, drop = FALSE], 2, sqrt(eig.cor[1:k2]), FUN="*") rownames(vectors.cor) <- names colnames(vectors.cor) <- colnames(vectors.cor, do.NULL = FALSE, prefix = "Axis.") # bs <- broken.stick(k2)[,2] bs <- bstick.def(k2) bs <- c(bs, rep(0,(k-k2))) cum.bs <- cumsum(bs) # Negative eigenvalues still present after correction: incorrect result } else { if(correct == 2) cat("Problem! Negative eigenvalues are still present after Lingoes",'\n') if(correct == 3) cat("Problem! Negative eigenvalues are still present after Cailliez",'\n') rel.eig.cor <- cum.eig.cor <- bs <- cum.bs <- rep(NA,n) vectors.cor <- matrix(NA,n,2) rownames(vectors.cor) <- names colnames(vectors.cor) <- colnames(vectors.cor, do.NULL = FALSE, prefix = "Axis.") } # End curly 4 res <- data.frame(eig[1:k], eig.cor[1:k], rel.eig.cor, bs, cum.eig.cor, cum.bs) colnames(res) <- c("Eigenvalues", "Corr_eig", "Rel_corr_eig", "Broken_stick", "Cum_corr_eig", "Cum_br_stick") rownames(res) <- 1:nrow(res) rownames(vectors) <- names colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.") out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace, vectors.cor=vectors.cor, trace.cor=trace.cor)) } else { # Curly 2 note <- "No correction was applied to the negative eigenvalues" bs <- bstick.def(k3) bs <- c(bs, rep(0,(k-k3))) cum.bs <- cumsum(bs) res <- data.frame(eig[1:k], rel.eig, rel.eig.cor, bs, cum.eig.cor, cum.bs) colnames(res) <- c("Eigenvalues","Relative_eig","Rel_corr_eig","Broken_stick","Cum_corr_eig","Cumul_br_stick") rownames(res) <- 1:nrow(res) rownames(vectors) <- names colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.") out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace)) } # End curly 2: three ways of handling the situation } # End curly 1 class(out) <- "pcoa" out } # End of PCoA ape/R/chronoMPL.R0000644000176200001440000000313614164530562013215 0ustar liggesusers## chronoMPL.R (2017-04-25) ## Molecular Dating with Mean Path Lengths ## Copyright 2007-2017 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. chronoMPL <- function(phy, se = TRUE, test = TRUE) { if (!is.binary.phylo(phy)) stop("the tree is not dichotomous.") n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] obj <- reorder(phy, "postorder") ndesc <- .C(node_depth, as.integer(n), as.integer(obj$edge[, 1]), as.integer(obj$edge[, 2]), as.integer(N), double(n + m), 1L)[[5]] s <- numeric(n + m) # sum of path lengths if (se) ss <- s if (test) Pval <- numeric(m) for (i in seq(1, N - 1, 2)) { j <- i + 1 a <- obj$edge[i, 2] b <- obj$edge[j, 2] o <- obj$edge[i, 1] A <- s[a] + ndesc[a]*obj$edge.length[i] B <- s[b] + ndesc[b]*obj$edge.length[j] s[o] <- A + B if (se) ss[o] <- ss[a] + ndesc[a]^2 * obj$edge.length[i] + ss[b] + ndesc[b]^2 * obj$edge.length[j] if (test) { z <- abs(A/ndesc[a] - B/ndesc[b]) tmp <- (ss[a] + ndesc[a]^2 * obj$edge.length[i])/ndesc[a]^2 tmp <- tmp + (ss[b] + ndesc[b]^2 * obj$edge.length[j])/ndesc[b]^2 z <- z/sqrt(tmp) Pval[o - n] <- 2*pnorm(z, lower.tail = FALSE) } } node.age <- s/ndesc phy$edge.length <- node.age[phy$edge[, 1]] - node.age[phy$edge[, 2]] if (se) attr(phy, "stderr") <- sqrt(ss[-(1:n)]/ndesc[-(1:n)]^2) if (test) attr(phy, "Pval") <- Pval phy } ape/R/collapse.singles.R0000644000176200001440000000410414164530562014615 0ustar liggesusers## collapse.singles.R (2017-07-27) ## Collapse "Single" Nodes ## Copyright 2015 Emmanuel Paradis, 2017 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. has.singles <- function(tree) { fun <- function(x) { tab <- tabulate(x$edge[, 1]) if (any(tab == 1L)) return(TRUE) FALSE } if (inherits(tree, "phylo")) return(fun(tree)) if (inherits(tree, "multiPhylo")) return(sapply(tree, fun)) } collapse.singles <- function(tree, root.edge = FALSE) { n <- length(tree$tip.label) tree <- reorder(tree) # this works now e1 <- tree$edge[, 1] e2 <- tree$edge[, 2] tab <- tabulate(e1) if (all(tab[-c(1:n)] > 1)) return(tree) # tips are zero if (is.null(tree$edge.length)) { root.edge <- FALSE wbl <- FALSE } else { wbl <- TRUE el <- tree$edge.length } if (root.edge) ROOTEDGE <- 0 ## start with the root node: ROOT <- n + 1L while (tab[ROOT] == 1) { i <- which(e1 == ROOT) ROOT <- e2[i] if (wbl) { if (root.edge) ROOTEDGE <- ROOTEDGE + el[i] el <- el[-i] } e1 <- e1[-i] e2 <- e2[-i] } singles <- which(tabulate(e1) == 1) if (length(singles) > 0) { ii <- sort(match(singles, e1), decreasing = TRUE) jj <- match(e1[ii], e2) for (i in 1:length(singles)) { e2[jj[i]] <- e2[ii[i]] if (wbl) el[jj[i]] <- el[jj[i]] + el[ii[i]] } e1 <- e1[-ii] e2 <- e2[-ii] if (wbl) el <- el[-ii] } Nnode <- length(e1) - n + 1L oldnodes <- unique(e1) if (!is.null(tree$node.label)) tree$node.label <- tree$node.label[oldnodes - n] newNb <- integer(max(oldnodes)) newNb[ROOT] <- n + 1L sndcol <- e2 > n e2[sndcol] <- newNb[e2[sndcol]] <- n + 2:Nnode e1 <- newNb[e1] tree$edge <- cbind(e1, e2, deparse.level = 0) tree$Nnode <- Nnode if (wbl) { if (root.edge) tree$root.edge <- ROOTEDGE tree$edge.length <- el } tree } ape/R/DNA.R0000644000176200001440000012542314164530562011762 0ustar liggesusers## DNA.R (2021-12-16) ## Manipulations and Comparisons of DNA and AA Sequences ## Copyright 2002-2021 Emmanuel Paradis, 2015 Klaus Schliep, 2017 Franz Krah ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. DNAbin2indel <- function(x) { if (is.list(x)) x <- as.matrix(x) d <- dim(x) s <- as.integer(d[2]) n <- as.integer(d[1]) if (s * n > 2^31 - 1) stop("DNAbin2indel() cannot handle more than 2^31 - 1 bases") res <- .C(DNAbin2indelblock, x, n, s, integer(n*s), NAOK = TRUE)[[4]] dim(res) <- d rownames(res) <- rownames(x) res } labels.DNAbin <- function(object, ...) { if (is.list(object)) return(names(object)) if (is.matrix(object)) return(rownames(object)) NULL } del.gaps <- function(x) { deleteGaps <- function(x) { i <- which(x == 4) if (length(i)) x[-i] else x } if (!inherits(x, "DNAbin")) x <- as.DNAbin(x) if (is.matrix(x)) { n <- dim(x)[1] y <- vector("list", n) for (i in 1:n) y[[i]] <- x[i, ] names(y) <- rownames(x) x <- y rm(y) } if (!is.list(x)) return(deleteGaps(x)) x <- lapply(x, deleteGaps) class(x) <- "DNAbin" x } del.rowgapsonly <- function(x, threshold = 1, freq.only = FALSE) { if (!inherits(x, "DNAbin")) x <- as.DNAbin(x) if (!is.matrix(x)) stop("DNA sequences not in a matrix") foo <- function(x) sum(x == 4) g <- apply(x, 1, foo) if (freq.only) return(g) i <- which(g / ncol(x) >= threshold) if (length(i)) x <- x[-i, ] x } del.colgapsonly <- function(x, threshold = 1, freq.only = FALSE) { if (!inherits(x, "DNAbin")) x <- as.DNAbin(x) if (!is.matrix(x)) stop("DNA sequences not in a matrix") foo <- function(x) sum(x == 4) g <- apply(x, 2, foo) if (freq.only) return(g) i <- which(g / nrow(x) >= threshold) if (length(i)) x <- x[, -i] x } as.alignment <- function(x) { if (is.list(x)) n <- length(x) if (is.matrix(x)) n <- dim(x)[1] seq <- character(n) if (is.list(x)) { nam <- names(x) for (i in 1:n) seq[i] <- paste(x[[i]], collapse = "") } if (is.matrix(x)) { nam <- dimnames(x)[[1]] for (i in 1:n) seq[i] <- paste(x[i, ], collapse = "") } obj <- list(nb = n, seq = seq, nam = nam, com = NA) class(obj) <- "alignment" obj } "[.DNAbin" <- function(x, i, j, drop = FALSE) { ans <- NextMethod("[", drop = drop) class(ans) <- "DNAbin" ans } as.matrix.DNAbin <- function(x, ...) { if (is.matrix(x)) return(x) if (!is.list(x)) { # vector dim(x) <- c(1, length(x)) return(x) } s <- unique(lengths(x, use.names = FALSE)) if (length(s) != 1) stop("DNA sequences in list not of the same length.") n <- length(x) y <- matrix(raw(), n, s) for (i in seq_len(n)) y[i, ] <- x[[i]] rownames(y) <- names(x) class(y) <- "DNAbin" y } as.list.DNAbin <- function(x, ...) { if (is.list(x)) return(x) if (is.null(dim(x))) obj <- list(x) # cause is.vector() doesn't work else { # matrix class(x) <- NULL n <- nrow(x) obj <- vector("list", n) for (i in seq_len(n)) obj[[i]] <- x[i, , drop = TRUE] names(obj) <- rownames(x) } class(obj) <- "DNAbin" obj } rbind.DNAbin <- function(...) { obj <- list(...) n <- length(obj) if (n == 1) return(obj[[1]]) for (i in 1:n) if (!is.matrix(obj[[1]])) stop("the 'rbind' method for \"DNAbin\" accepts only matrices") NC <- unlist(lapply(obj, ncol)) if (length(unique(NC)) > 1) stop("matrices do not have the same number of columns.") for (i in 1:n) class(obj[[i]]) <- NULL # safe but maybe not really needed structure(do.call(rbind, obj), class = "DNAbin") } cbind.DNAbin <- function(..., check.names = TRUE, fill.with.gaps = FALSE, quiet = FALSE) { obj <- list(...) n <- length(obj) if (n == 1) return(obj[[1]]) for (i in 1:n) if (!is.matrix(obj[[1]])) stop("the 'cbind' method for \"DNAbin\" accepts only matrices") NR <- unlist(lapply(obj, nrow)) for (i in 1:n) class(obj[[i]]) <- NULL if (check.names) { NMS <- lapply(obj, rownames) for (i in 1:n) if (anyDuplicated(NMS[[i]])) stop("Duplicated rownames in matrix ", i, ": see ?cbind.DNAbin") nms <- unlist(NMS) if (fill.with.gaps) { NC <- unlist(lapply(obj, ncol)) nms <- unique(nms) ans <- matrix(as.raw(4), length(nms), sum(NC)) rownames(ans) <- nms from <- 1 for (i in 1:n) { to <- from + NC[i] - 1 k <- match(NMS[[i]], nms) ans[k, from:to] <- obj[[i]] from <- to + 1 } } else { tab <- table(nms) ubi <- tab == n nms <- names(tab)[which(ubi)] ans <- obj[[1]][nms, , drop = FALSE] for (i in 2:n) ans <- cbind(ans, obj[[i]][nms, , drop = FALSE]) if (!quiet && !all(ubi)) warning("some rows were dropped.") } } else { if (length(unique(NR)) > 1) stop("matrices do not have the same number of rows.") ans <- matrix(unlist(obj), NR) rownames(ans) <- rownames(obj[[1]]) } class(ans) <- "DNAbin" ans } c.DNAbin <- function(..., recursive = FALSE) { if (!all(unlist(lapply(list(...), is.list)))) stop("the 'c' method for \"DNAbin\" accepts only lists") structure(NextMethod("c"), class = "DNAbin") } print.DNAbin <- function(x, printlen = 6, digits = 3, ...) { if (is.list(x)) { n <- length(x) nms <- names(x) if (n == 1) { cat("1 DNA sequence in binary format stored in a list.\n\n") nTot <- length(x[[1]]) cat("Sequence length:", nTot, "\n") } else { cat(n, "DNA sequences in binary format stored in a list.\n\n") tmp <- lengths(x, use.names = FALSE) nTot <- sum(as.numeric(tmp)) mini <- min(tmp) maxi <- max(tmp) if (mini == maxi) cat("All sequences of same length:", maxi, "\n") else { cat("Mean sequence length:", round(mean(tmp), 3), "\n") cat(" Shortest sequence:", mini, "\n") cat(" Longest sequence:", maxi, "\n") } } } else { nTot <- length(x) if (is.matrix(x)) { nd <- dim(x) n <- nd[1] nms <- rownames(x) if (n == 1) { cat("1 DNA sequence in binary format stored in a matrix.\n\n") cat("Sequence length:", nd[2], "\n") } else { cat(n, "DNA sequences in binary format stored in a matrix.\n\n") cat("All sequences of same length:", nd[2], "\n") } } else { cat("1 DNA sequence in binary format stored in a vector.\n\n") cat("Sequence length:", nTot, "\n\n") } } if (exists("nms")) { HEAD <- if (n == 1) "\nLabel:" else "\nLabels:" TAIL <- "" if (printlen < n) { nms <- nms[1:printlen] TAIL <- "...\n" } if (any(longs <- nchar(nms) > 60)) nms[longs] <- paste0(substr(nms[longs], 1, 60), "...") cat(HEAD, nms, TAIL, sep = "\n") } if (nTot <= 1e7) { cat("Base composition:\n") print(round(base.freq(x), digits)) } else { cat("More than 10 million bases: not printing base composition.\n") } if (nTot > 1) { k <- floor(log(nTot, 1000)) units <- c("bases", "kb", "Mb", "Gb", "Tb", "Pb", "Eb") cat("(Total: ", round(nTot/1000^k, 2), " ", units[k + 1], ")\n", sep = "") } } as.DNAbin <- function(x, ...) UseMethod("as.DNAbin") ._cs_ <- c("a", "g", "c", "t", "r", "m", "w", "s", "k", "y", "v", "h", "d", "b", "n", "-", "?") ._bs_ <- c(136, 72, 40, 24, 192, 160, 144, 96, 80, 48, 224, 176, 208, 112, 240, 4, 2) ## by Klaus: as.DNAbin.character <- function(x, ...) { ans <- as.raw(._bs_)[match(tolower(x), ._cs_)] if (is.matrix(x)) { dim(ans) <- dim(x) dimnames(ans) <- dimnames(x) } class(ans) <- "DNAbin" ans } as.DNAbin.alignment <- function(x, ...) { n <- x$nb x$seq <- tolower(x$seq) ans <- matrix("", n, nchar(x$seq[1])) for (i in 1:n) ans[i, ] <- strsplit(x$seq[i], "")[[1]] rownames(ans) <- gsub(" +$", "", gsub("^ +", "", x$nam)) as.DNAbin.character(ans) } as.DNAbin.list <- function(x, ...) { obj <- lapply(x, as.DNAbin) class(obj) <- "DNAbin" obj } as.character.DNAbin <- function(x, ...) { f <- function(xx) { ans <- ._cs_[match(as.numeric(xx), ._bs_)] if (is.matrix(xx)) { dim(ans) <- dim(xx) dimnames(ans) <- dimnames(xx) } ans } if (is.list(x)) lapply(x, f) else f(x) } base.freq <- function(x, freq = FALSE, all = FALSE) { if (!inherits(x, "DNAbin")) stop('base.freq requires an object of class "DNAbin"') f <- function(x) .Call(BaseProportion, x) if (is.list(x)) { BF <- rowSums(sapply(x, f)) n <- sum(as.double(lengths(x, use.names = FALSE))) } else { n <- length(x) BF <- f(x) } names(BF) <- c("a", "c", "g", "t", "r", "m", "w", "s", "k", "y", "v", "h", "d", "b", "n", "-", "?") if (all) { if (!freq) BF <- BF / n } else { BF <- BF[1:4] if (!freq) BF <- BF / sum(BF) } BF } Ftab <- function(x, y = NULL) { if (is.null(y)) { if (is.list(x)) { y <- x[[2]] x <- x[[1]] if (length(x) != length(y)) stop("'x' and 'y' not of the same length") } else { # 'x' is a matrix y <- x[2, , drop = TRUE] x <- x[1, , drop = TRUE] } } else { x <- as.vector(x) y <- as.vector(y) if (length(x) != length(y)) stop("'x' and 'y' not of the same length") } out <- matrix(0, 4, 4) k <- c(136, 40, 72, 24) for (i in 1:4) { a <- x == k[i] for (j in 1:4) { b <- y == k[j] out[i, j] <- sum(a & b) } } dimnames(out)[1:2] <- list(c("a", "c", "g", "t")) out } GC.content <- function(x) sum(base.freq(x)[2:3]) seg.sites <- function(x, strict = FALSE, trailingGapsAsN = TRUE) { if (is.list(x)) x <- as.matrix(x) ## is.vector() returns FALSE because of the class, ## so we use a different test dx <- dim(x) if (is.null(dx)) return(integer()) if (dx[1] == 1) return(integer()) if (trailingGapsAsN) x <- latag2n(x) ans <- .Call(SegSites, x, strict) which(as.logical(ans)) } dist.dna <- function(x, model = "K80", variance = FALSE, gamma = FALSE, pairwise.deletion = FALSE, base.freq = NULL, as.matrix = FALSE) { MODELS <- c("RAW", "JC69", "K80", "F81", "K81", "F84", "T92", "TN93", "GG95", "LOGDET", "BH87", "PARALIN", "N", "TS", "TV", "INDEL", "INDELBLOCK") imod <- pmatch(toupper(model), MODELS) if (is.na(imod)) stop(paste("'model' must be one of:", paste("\"", MODELS, "\"", sep = "", collapse = " "))) if (imod == 11 && variance) { warning("computing variance not available for model BH87") variance <- FALSE } if (gamma && imod %in% c(1, 5:7, 9:17)) { warning(paste("gamma-correction not available for model", model)) gamma <- FALSE } if (is.list(x)) x <- as.matrix(x) nms <- dimnames(x)[[1]] n <- dim(x)[1] # in case nms is NULL if (imod %in% c(4, 6:8)) { BF <- if (is.null(base.freq)) base.freq(x) else base.freq } else BF <- 0 if (imod %in% 16:17) pairwise.deletion <- TRUE if (!pairwise.deletion) { keep <- .Call(GlobalDeletionDNA, x) x <- x[, as.logical(keep)] } if (!gamma) { alpha <- 0 } else { alpha <- gamma gamma <- 1L } d <- .Call(dist_dna, x, imod, BF, as.integer(pairwise.deletion), as.integer(variance), as.integer(gamma), alpha) if (variance) { var <- d[[2]] d <- d[[1]] } if (imod == 11) { dim(d) <- c(n, n) dimnames(d) <- list(nms, nms) } else { attr(d, "Size") <- n attr(d, "Labels") <- nms attr(d, "Diag") <- attr(d, "Upper") <- FALSE attr(d, "call") <- match.call() attr(d, "method") <- model class(d) <- "dist" if (as.matrix) d <- as.matrix(d) } if (variance) attr(d, "variance") <- var d } image.DNAbin <- function(x, what, col, bg = "white", xlab = "", ylab = "", show.labels = TRUE, cex.lab = 1, legend = TRUE, grid = FALSE, show.bases = FALSE, base.cex = 1, base.font = 1, base.col = "black", ...) { what <- if (missing(what)) c("a", "g", "c", "t", "n", "-") else tolower(what) if (missing(col)) col <- c("red", "yellow", "green", "blue", "grey", "black") x <- as.matrix(x) # tests if all sequences have the same length n <- (dx <- dim(x))[1] # number of sequences s <- dx[2] # number of sites y <- integer(N <- length(x)) ncl <- length(what) col <- rep(col, length.out = ncl) brks <- 0.5:(ncl + 0.5) sm <- 0L for (i in ncl:1) { k <- ._bs_[._cs_ == what[i]] sel <- which(x == k) if (L <- length(sel)) { y[sel] <- i sm <- sm + L } else { what <- what[-i] col <- col[-i] brks <- brks[-i] } } dim(y) <- dx ## if there's no 0 in y, must drop 'bg' from the cols passed to image: if (sm == N) { leg.co <- co <- col leg.txt <- toupper(what) } else { co <- c(bg, col) leg.txt <- c(toupper(what), "others") leg.co <- c(col, bg) brks <- c(-0.5, brks) } yaxt <- if (show.labels) "n" else "s" image.default(1:s, 1:n, t(y[n:1, , drop = FALSE]), col = co, xlab = xlab, ylab = ylab, yaxt = yaxt, breaks = brks, ...) if (show.labels) mtext(rownames(x), side = 2, line = 0.1, at = n:1, cex = cex.lab, adj = 1, las = 1) if (legend) { psr <- par("usr") xx <- psr[2]/2 yy <- psr[4] * (0.5 + 0.5/par("plt")[4]) legend(xx, yy, legend = leg.txt, pch = 22, pt.bg = leg.co, pt.cex = 2, bty = "n", xjust = 0.5, yjust = 0.5, horiz = TRUE, xpd = TRUE) } if (grid) { if (is.logical(grid)) grid <- 3L if (grid %in% 2:3) abline(v = seq(1.5, s - 0.5, 1), lwd = 0.33, xpd = FALSE) if (grid %in% c(1, 3)) abline(h = seq(1.5, n - 0.5, 1), lwd = 0.33, xpd = FALSE) } if (show.bases) { x <- toupper(as.character(x)) xx <- rep(1:s, each = n) yy <- rep(n:1, s) text(xx, yy, x, cex = base.cex, font = base.font, col = base.col) } } alview <- function(x, file = "", uppercase = TRUE, showpos = TRUE) { if (is.list(x)) x <- as.matrix(x) taxa <- formatC(labels(x), width = -1) x <- as.character(x) s <- ncol(x) if (nrow(x) > 1) { for (j in seq_len(s)) { q <- which(x[-1L, j] == x[1L, j]) + 1L x[q, j] <- "." } } x <- apply(x, 1L, paste, collapse = "") if (uppercase) x <- toupper(x) res <- paste(taxa, x) if ((is.logical(showpos) && showpos) || is.numeric(showpos)) { if (is.logical(showpos)) { pos <- 1:s digits <- floor(log10(s)) + 1 } else { pos <- showpos digits <- floor(log10(max(pos))) + 1 } hdr <- sprintf(paste0("%0", digits, "d"), pos) hdr <- unlist(strsplit(hdr, "")) dim(hdr) <- c(digits, length(pos)) hdr <- apply(hdr, 1, paste, collapse = "") hdr <- formatC(hdr, width = nchar(res[1])) cat(hdr, file = file, sep = "\n") } cat(res, file = file, sep = "\n", append = TRUE) } where <- function(x, pattern) { pat <- strsplit(pattern, NULL)[[1]] if (inherits(x, "DNAbin")) { pat <- as.DNAbin(pat) } else { if (inherits(x, "AAbin")) { pat <- as.AAbin(toupper(pat)) } else { stop("'x' should inherit class \"DNAbin\" or \"AAbin\"") } } p <- length(pat) f <- function(x, pat, p) { if (length(x) < p) { warning("sequence shorter than the pattern: returning NULL") return(NULL) } .Call(C_where, x, pat) } if (is.list(x)) return(lapply(x, f, pat = pat, p = p)) if (is.matrix(x)) { n <- nrow(x) res <- vector("list", n) for (i in seq_len(n)) res[[i]] <- f(x[i, , drop = TRUE], pat, p) names(res) <- rownames(x) return(res) } f(x, pat, p) # if x is a vector } ## conversions from BioConductor: ## DNA: .DNAString2DNAbin <- function(from) .Call("charVectorToDNAbinVector", as.character(from)) as.DNAbin.DNAString <- function(x, ...) { res <- list(.DNAString2DNAbin(x)) class(res) <- "DNAbin" res } as.DNAbin.DNAStringSet <- function(x, ...) { res <- lapply(x, .DNAString2DNAbin) class(res) <- "DNAbin" res } as.DNAbin.DNAMultipleAlignment <- function(x, ...) as.matrix(as.DNAbin.DNAStringSet(as(x, "DNAStringSet"))) as.DNAbin.PairwiseAlignmentsSingleSubject <- function(x, ...) as.DNAbin.DNAMultipleAlignment(x) ## AA: .AAString2AAbin <- function(from) charToRaw(as.character(from)) as.AAbin.AAString <- function(x, ...) { res <- list(.AAString2AAbin(x)) class(res) <- "AAbin" res } as.AAbin.AAStringSet <- function(x, ...) { res <- lapply(x, .AAString2AAbin) class(res) <- "AAbin" res } as.AAbin.AAMultipleAlignment <- function(x, ...) as.matrix(as.AAbin.AAStringSet(as(x, "AAStringSet"))) complement <- function(x) { f <- function(x) { ## reorder the vector of raws to match the complement: comp <- as.raw(._bs_[c(4:1, 10:9, 7:8, 6:5, 14:11, 15:17)]) ans <- comp[match(as.integer(x), ._bs_)] rev(ans) # reverse before returning } if (is.matrix(x)) { for (i in 1:nrow(x)) x[i, ] <- f(x[i, ]) return(x) } else if (is.list(x)) { x <- lapply(x, f) } else x <- f(x) class(x) <- "DNAbin" x } trans <- function(x, code = 1, codonstart = 1) { f <- function(x, s, code) .C(trans_DNA2AA, x, as.integer(s), raw(s/3), as.integer(code), NAOK = TRUE)[[3]] if (code > 6) stop("only the genetic codes 1--6 are available for now") if (codonstart > 1) { del <- -(1:(codonstart - 1)) if (is.list(x)) { for (i in seq_along(x)) x[[i]] <- x[[i]][del] } else { x <- if (is.matrix(x)) x[, del] else x[del] } } if (is.list(x)) { res <- lapply(x, trans, code = code) } else { s <- if (is.matrix(x)) ncol(x) else length(x) rest <- s %% 3 if (rest != 0) { s <- s - rest x <- if (is.matrix(x)) x[, 1:s] else x[1:s] msg <- paste("sequence length not a multiple of 3:", rest, "nucleotide") if (rest == 2) msg <- paste0(msg, "s") warning(paste(msg, "dropped")) } if (is.matrix(x)) { res <- t(apply(x, 1, f, s = s, code = code)) if (s == 3) { res <- t(res) rownames(res) <- rownames(x) } } else { res <- f(x, s, code) } } class(res) <- "AAbin" res } print.AAbin <- function(x, ...) { if (is.list(x)) { n <- length(x) cat(n, "amino acid sequence") if (n > 1) cat("s") cat(" in a list\n\n") tmp <- lengths(x, use.names = FALSE) maxi <- max(tmp) mini <- min(tmp) if (mini == maxi) cat("All sequences of the same length:", maxi, "\n") else { cat("Mean sequence length:", round(mean(tmp), 3), "\n Shortest sequence:", mini, "\n Longest sequence:", maxi, "\n") } } else if (is.matrix(x)) { n <- nrow(x) cat(n, "amino acid sequence") if (n > 1) cat("s") cat(" in a matrix\n") if (n == 1) cat("Sequence length: ") else cat("All sequences of the same length: ") cat(ncol(x), "\n") } else { cat("1 amino acid sequence in a vector:\n\n", rawToChar(x)) } cat("\n") } "[.AAbin" <- function (x, i, j, drop = FALSE) { ans <- NextMethod("[", drop = drop) class(ans) <- "AAbin" ans } as.character.AAbin <- function(x, ...) { f <- function(xx) { ans <- strsplit(rawToChar(xx), "")[[1]] if (is.matrix(xx)) { dim(ans) <- dim(xx) dimnames(ans) <- dimnames(xx) } ans } if (is.list(x)) lapply(x, f) else f(x) } as.AAbin <- function(x, ...) UseMethod("as.AAbin") as.AAbin.character <- function(x, ...) { f <- function(x) charToRaw(paste(x, collapse = "")) res <- if (is.vector(x)) f(x) else t(apply(x, 1, f)) class(res) <- "AAbin" res } labels.AAbin <- function(object, ...) labels.DNAbin(object, ...) ## TO BE MOVED TO phangorn LATER if (getRversion() >= "2.15.1") utils::globalVariables("phyDat") as.phyDat.AAbin <- function(x, ...) phyDat(as.character(x), type = "AA") ## \alias{as.phyDat.AAbin} ## \method{as.phyDat}{AAbin}(x, \dots) dist.aa <- function(x, pairwise.deletion = FALSE, scaled = FALSE) { n <- nrow(x) d <- numeric(n*(n - 1)/2) X <- charToRaw("X") k <- 0L if (!pairwise.deletion) { del <- apply(x, 2, function(y) any(y == X)) if (any(del)) x <- x[, !del] for (i in 1:(n - 1)) { for (j in (i + 1):n) { k <- k + 1L d[k] <- sum(x[i, ] != x[j, ]) } } if (scaled) d <- d/ncol(x) } else { for (i in 1:(n - 1)) { a <- x[i, ] for (j in (i + 1):n) { b <- x[j, ] del <- a == X | b == X p <- length(b <- b[!del]) tmp <- sum(a[!del] != b) k <- k + 1L d[k] <- if (scaled) tmp/p else tmp } } } attr(d, "Size") <- n attr(d, "Labels") <- rownames(x) attr(d, "Diag") <- attr(d, "Upper") <- FALSE attr(d, "call") <- match.call() class(d) <- "dist" d } AAsubst <- function(x) { X <- charToRaw("X") f <- function(y) length(unique.default(y[y != X])) which(apply(x, 2, f) > 1) } .AA_3letter <- c("Ala", "Cys", "Asp", "Glu", "Phe", "Gly", "His", "Ile", "Lys", "Leu", "Met", "Asn", "Pro", "Gln", "Arg", "Ser", "Thr", "Val", "Trp", "Tyr", "Xaa", "Stp") .AA_1letter <- c("A", "C", "D", "E", "F", "G", "H", "I", "K", "L", "M", "N", "P", "Q", "R", "S", "T", "V", "W", "Y", "X", "*") .AA_raw <- sapply(.AA_1letter, charToRaw) .AA_3cat <- list(Hydrophobic = .AA_raw[c("V", "I", "L", "F", "W", "Y", "M")], Small = .AA_raw[c("P", "G", "A", "C")], Hydrophilic = .AA_raw[c("S", "T", "H", "N", "Q", "D", "E", "K", "R")]) image.AAbin <- function(x, what, col, bg = "white", xlab = "", ylab = "", show.labels = TRUE, cex.lab = 1, legend = TRUE, grid = FALSE, show.aa = FALSE, aa.cex = 1, aa.font = 1, aa.col = "black", ...) { if (missing(what)) what <- c("Hydrophobic", "Small", "Hydrophilic") if (missing(col)) col <- c("red", "yellow", "blue") n <- (dx <- dim(x))[1] s <- dx[2] y <- integer(N <- length(x)) ncl <- length(what) col <- rep(col, length.out = ncl) brks <- 0.5:(ncl + 0.5) sm <- 0L for (i in ncl:1) { k <- .AA_3cat[[i]] sel <- which(x %in% k) if (L <- length(sel)) { y[sel] <- i sm <- sm + L } else { what <- what[-i] col <- col[-i] brks <- brks[-i] } } dim(y) <- dx if (sm == N) { leg.co <- co <- col leg.txt <- what } else { co <- c(bg, col) leg.txt <- c(what, "Unknown") leg.co <- c(col, bg) brks <- c(-0.5, brks) } yaxt <- if (show.labels) "n" else "s" image.default(1:s, 1:n, t(y[n:1, ]), col = co, xlab = xlab, ylab = ylab, yaxt = yaxt, breaks = brks, ...) if (length(poly <- AAsubst(x))) { rect(poly - 0.5, n + 0.5, poly + 0.5, n + 0.5 + yinch(0.2), col = "slategrey", border = NA, xpd = TRUE) ##rect(0.5, n + 0.5, s + 0.5, n + 0.5 + yinch(0.2), lwd = 0.5) } if (show.labels) mtext(rownames(x), side = 2, line = 0.1, at = n:1, cex = cex.lab, adj = 1, las = 1) if (legend) { psr <- par("usr") xx <- psr[2]/2 yy <- psr[4] * (0.5 + 0.5/par("plt")[4]) legend(xx, yy, legend = leg.txt, pch = 22, pt.bg = leg.co, pt.cex = 2, bty = "n", xjust = 0.5, yjust = 0.5, horiz = TRUE, xpd = TRUE) } if (grid) { if (is.logical(grid)) grid <- 3L if (grid %in% 2:3) abline(v = seq(1.5, s - 0.5, 1), lwd = 0.33, xpd = FALSE) if (grid %in% c(1, 3)) abline(h = seq(1.5, n - 0.5, 1), lwd = 0.33, xpd = FALSE) } if (show.aa) { x <- toupper(as.character(x)) xx <- rep(1:s, each = n) yy <- rep(n:1, s) text(xx, yy, x, cex = aa.cex, font = aa.font, col = aa.col) } } checkAlignment <- function(x, check.gaps = TRUE, plot = TRUE, what = 1:4) { cat("\nNumber of sequences:", n <- nrow(x), "\nNumber of sites:", s <- ncol(x), "\n") if (check.gaps) { cat("\n") y <- DNAbin2indel(x) gap.length <- sort(unique.default(y))[-1] if (!length(gap.length)) cat("No gap in alignment.\n") else { rest <- gap.length %% 3 if (any(cond <- rest > 0)) { cat("Some gap lengths are not multiple of 3:", gap.length[cond]) } else cat("All gap lengths are multiple of 3.") tab <- tabulate(y, gap.length[length(gap.length)]) tab <- tab[gap.length] cat("\n\nFrequencies of gap lengths:\n") names(tab) <- gap.length print(tab) ## find gaps on the borders: col1 <- unique(y[, 1]) if (!col1[1]) col1 <- col1[-1] if (length(col1)) cat(" => length of gaps on the left border of the alignment:", unique(col1), "\n") else cat(" => no gap on the left border of the alignment\n") i <- which(y != 0, useNames = FALSE) jcol <- i %/% nrow(y) + 1 yi <- y[i] j <- yi == s - jcol + 1 if (any(j)) cat(" => length of gaps on the right border of the alignment:", yi[j], "\n") else cat(" => no gap on the right border of the alignment\n") ## find base segments: A <- B <- numeric() for (i in seq_len(n)) { j <- which(y[i, ] != 0) # j: start of each gap in the i-th sequence if (!length(j)) next k <- j + y[i, j] # k: start of each base segment in the i-th sequence if (j[1] != 1) k <- c(1, k) else j <- j[-1] if (k[length(k)] > s) k <- k[-length(k)] else j <- c(j, s + 1) A <- c(A, j) B <- c(B, k) } AB <- unique(cbind(A, B)) not.multiple.of.3 <- (AB[, 1] - AB[, 2]) %% 3 != 0 left.border <- AB[, 2] == 1 right.border <- AB[, 1] == s + 1 Nnot.mult3 <- sum(not.multiple.of.3) cat("\nNumber of unique contiguous base segments defined by gaps:", nrow(AB), "\n") if (!Nnot.mult3) cat("All segment lengths multiple of 3.\n") else { Nleft <- sum(not.multiple.of.3 & left.border) Nright <- sum(not.multiple.of.3 & right.border) cat("Number of segment lengths not multiple of 3:", Nnot.mult3, "\n", " => on the left border of the alignement:", Nleft, "\n", " => on the right border :", Nright, "\n") if (Nright + Nleft < Nnot.mult3) { cat(" => positions of these segments inside the alignment: ") sel <- not.multiple.of.3 & !left.border & !right.border cat(paste(AB[sel, 2], AB[sel, 1] - 1, sep = ".."), "\n") } } } } else gap.length <- numeric() ss <- seg.sites(x) cat("\nNumber of segregating sites (including gaps):", length(ss)) BF.col <- matrix(NA_real_, length(ss), 4) for (i in seq_along(ss)) BF.col[i, ] <- base.freq(x[, ss[i]])#, freq = TRUE) tmp <- apply(BF.col, 1, function(x) sum(x > 0)) cat("\nNumber of sites with at least one substitution:", sum(tmp > 1)) cat("\nNumber of sites with 1, 2, 3 or 4 observed bases:\n") tab2 <- tabulate(tmp, 4L) tab2[1] <- s - sum(tab2) names(tab2) <- 1:4 print(tab2) cat("\n") H <- numeric(s) H[ss] <- apply(BF.col, 1, function(x) {x <- x[x > 0]; -sum(x * log(x))}) G <- rep(1, s) G[ss] <- tmp if (plot) { if (length(what) == 4) { mat <- if (length(gap.length)) 1:4 else c(1, 0, 2, 3) layout(matrix(mat, 2, 2)) } else { if (length(what) != 1) { what <- what[1] warning("argument 'what' has length > 1: the first value is taken") } } if (1 %in% what) image(x) if (2 %in% what && length(gap.length)) barplot(tab, xlab = "Gap length") if (3 %in% what) plot(1:s, H, "h", xlab = "Sequence position", ylab = "Shannon index (H)") if (4 %in% what) plot(1:s, G, "h", xlab = "Sequence position", ylab = "Number of observed bases") } } all.equal.DNAbin <- function(target, current, plot = FALSE, ...) { if (identical(target, current)) return(TRUE) name.target <- deparse(substitute(target)) name.current <- deparse(substitute(current)) st1 <- "convert list as matrix for further comparison." # st2 <- "" st3 <- "Subset your data for further comparison." isali1 <- is.matrix(target) isali2 <- is.matrix(current) if (isali1 && !isali2) return(c("1st object is a matrix, 2nd object is a list:", st1)) if (!isali1 && isali2) return(c("1st object is a list, 2nd object is a matrix:", st1)) if (!isali1 && !isali2) return(c("Both objects are lists:", "convert them as matrices for further comparison.")) # n1 <- if (isali1) nrow(target) else length(target) # n2 <- if (isali2) nrow(current) else length(current) if (ncol(target) != ncol(current)) return("Numbers of columns different: comparison stopped here.") foo <- function(n) ifelse(n == 1, "sequence", "sequences") doComparison <- function(target, current) which(target != current, arr.ind = TRUE, useNames = FALSE) n1 <- nrow(target) n2 <- nrow(current) labs1 <- labels(target) labs2 <- labels(current) if (identical(labs1, labs2)) { res <- "Labels in both objects identical." res <- list(messages = res, different.sites = doComparison(target, current)) } else { in12 <- labs1 %in% labs2 in21 <- labs2 %in% labs1 if (n1 != n2) { res <- c("Number of sequences different:", paste(n1, foo(n1), "in 1st object;", n2, foo(n2), "in 2nd object."), st3) plot <- FALSE } else { # n1 == n2 if (any(!in12)) { res <- c("X: 1st object (target), Y: 2nd object (current).", paste("labels in X not in Y:", paste(labs1[!in12], collapse = ", ")), paste("labels in X not in Y:", paste(labs2[!in21], collapse = ", ")), st3) plot <- FALSE } else { res <- c("Labels in both objects identical but not in the same order.", "Comparing sequences after reordering rows of the second matrix.") current <- current[labs1, ] if (identical(target, current)) { res <- c(res, "Sequences are identical.") plot <- FALSE } else { res <- list(messages = res, different.sites = doComparison(target, current)) } } } } if (plot) { cols <- unique(res$different.sites[, 2]) diff.cols <- diff(cols) j <- which(diff.cols != 1) end <- c(cols[j], cols[length(cols)]) start <- c(cols[1], cols[j + 1]) v <- cumsum(end - start + 1) + 0.5 f <- function(lab) { axis(2, at = seq_len(n1), labels = FALSE) axis(1, at = seq_along(cols), labels = cols) mtext(lab, line = 1, adj = 0, font = 2) } layout(matrix(1:2, 2)) par(xpd = TRUE) image(target[, cols], show.labels = FALSE, axes = FALSE, ...) f(name.target) xx <- c(0.5, v) segments(xx, 0.5, xx, n1, lty = 2, col = "white", lwd = 2) segments(xx, 0.5, xx, -1e5, lty = 2, lwd = 2) image(current[, cols], show.labels = FALSE, axes = FALSE, ...) f(name.current) segments(xx, 0.5, xx, n2, lty = 2, col = "white", lwd = 2) segments(xx, 1e5, xx, n2, lty = 2, lwd = 2) #segments(0.5, -5, length(cols) + 0.5, -5, lwd = 5, col = "grey") #rect(0.5, -4, length(cols) + 0.5, -3, col = "grey") #segments(0.5, 0.5, 10, -3) } res } ## From Franz Krah : ## estensions of the AAbin class to complement the DNAbin class funcitons c.AAbin <- function(..., recursive = FALSE) { if (!all(unlist(lapply(list(...), is.list)))) stop("the 'c' method for \"AAbin\" accepts only lists") structure(NextMethod("c"), class = "AAbin") } rbind.AAbin <- function(...) { obj <- list(...) n <- length(obj) if (n == 1) return(obj[[1]]) for (i in 1:n) if (!is.matrix(obj[[1]])) stop("the 'rbind' method for \"AAbin\" accepts only matrices") NC <- unlist(lapply(obj, ncol)) if (length(unique(NC)) > 1) stop("matrices do not have the same number of columns.") for (i in 1:n) class(obj[[i]]) <- NULL # safe but maybe not really needed structure(do.call(rbind, obj), class = "AAbin") } cbind.AAbin <- function(..., check.names = TRUE, fill.with.Xs = FALSE, quiet = FALSE) { obj <- list(...) n <- length(obj) if (n == 1) return(obj[[1]]) for (i in 1:n) if (!is.matrix(obj[[1]])) stop("the 'cbind' method for \"AAbin\" accepts only matrices") NR <- unlist(lapply(obj, nrow)) for (i in 1:n) class(obj[[i]]) <- NULL if (check.names) { NMS <- lapply(obj, rownames) for (i in 1:n) if (anyDuplicated(NMS[[i]])) stop("Duplicated rownames in matrix ", i, ": see ?cbind.AAbin") nms <- unlist(NMS) if (fill.with.Xs) { NC <- unlist(lapply(obj, ncol)) nms <- unique(nms) ans <- matrix(charToRaw("X"), length(nms), sum(NC)) rownames(ans) <- nms from <- 1 for (i in 1:n) { to <- from + NC[i] - 1 k <- match(NMS[[i]], nms) ans[k, from:to] <- obj[[i]] from <- to + 1 } } else { tab <- table(nms) ubi <- tab == n nms <- names(tab)[which(ubi)] ans <- obj[[1]][nms, , drop = FALSE] for (i in 2:n) ans <- cbind(ans, obj[[i]][nms, , drop = FALSE]) if (!quiet && !all(ubi)) warning("some rows were dropped.") } } else { if (length(unique(NR)) > 1) stop("matrices do not have the same number of rows.") ans <- matrix(unlist(obj), NR) rownames(ans) <- rownames(obj[[1]]) } class(ans) <- "AAbin" ans } as.AAbin.list <- function(x, ...) { obj <- lapply(x, as.AAbin) class(obj) <- "AAbin" obj } as.list.AAbin <- function(x, ...) { if (is.list(x)) return(x) if (is.null(dim(x))) obj <- list(x) # cause is.vector() doesn't work else { # matrix n <- nrow(x) obj <- vector("list", n) for (i in seq_len(n)) obj[[i]] <- x[i, , drop = TRUE] names(obj) <- rownames(x) } class(obj) <- "AAbin" obj } as.matrix.AAbin <- function(x, ...) { if (is.matrix(x)) return(x) if (!is.list(x)) { # vector dim(x) <- c(1, length(x)) return(x) } s <- unique(lengths(x, use.names = FALSE)) if (length(s) != 1) stop("AA sequences in list not of the same length.") n <- length(x) y <- matrix(raw(), n, s) for (i in seq_len(n)) y[i, ] <- x[[i]] rownames(y) <- names(x) class(y) <- "AAbin" y } rDNAbin <- function(n, nrow, ncol, base.freq = rep(0.25, 4), prefix = "Ind_") { foo <- function(n, prob) { vec <- as.raw(._bs_[1:4]) vec[sample.int(4L, n, TRUE, prob, FALSE)] } base.freq <- if (all(base.freq == 0.25)) NULL else base.freq[c(1, 3, 2, 4)] if (missing(n)) { if (missing(nrow) && missing(ncol)) stop("nrow and ncol should be given if n is missing") res <- foo(nrow * ncol, base.freq) dim(res) <- c(nrow, ncol) rownames(res) <- paste0(prefix, 1:nrow) } else { res <- lapply(n, foo, prob = base.freq) names(res) <- paste0(prefix, seq_along(n)) } class(res) <- "DNAbin" res } dnds <- function(x, code = 1, codonstart = 1, quiet = FALSE, details = FALSE, return.categories = FALSE) { if (code > 6) stop("only the genetic codes 1--6 are available for now") if (is.list(x)) x <- as.matrix(x) n <- nrow(x) if (nrow(unique.matrix(x)) != n) stop("sequences are not unique") ### if (any(base.freq(x, TRUE, TRUE)[-(1:4)] > 0)) stop("ambiguous bases are not permitted") if (codonstart > 1) { del <- -(1:(codonstart - 1)) x <- x[, del] } p <- ncol(x) rest <- p %% 3 if (rest) { p <- p - rest x <- x[, 1:p] msg <- sprintf("sequence length not a multiple of 3: %d %s dropped", rest, ngettext(rest, "base", "bases")) warning(msg) } degMat <- .buildDegeneracyMatrix(code) Lcat <- matrix(0L, n, p) V1 <- V2 <- V3 <- integer(136) i <- c(136L, 72L, 40L, 24L) V1[i] <- c(1L, 17L, 33L, 49L) V2[i] <- c(0L, 4L, 8L, 12L) V3[i] <- 0:3 class(x) <- NULL z <- as.integer(x) N <- length(x) SHIFT <- c(0L, n, 2L * n) p <- 1L + SHIFT while (p[3] <= N) { for (i in 1:n) { codon <- z[p] ii <- V1[codon[1]] + V2[codon[2]] + V3[codon[3]] if (!is.na(ii)) Lcat[p] <- degMat[ii, ] p <- p + 1L } p <- p[3] + SHIFT } if (return.categories) return(Lcat) if (details) quiet <- TRUE deg <- c(0, 2, 4) # the 3 levels of degeneracy nout <- n*(n - 1)/2 res <- numeric(nout) k <- 1L for (i in 1:(n - 1)) { for (j in (i + 1):n) { if (!quiet) cat("\r", round(100*k/nout), "%") z <- x[c(i, j), ] Lavg <- (Lcat[i, ] + Lcat[j, ])/2 Lavg[Lavg == 1] <- 2 Lavg[Lavg == 3] <- 4 ii <- lapply(deg, function(x) which(x == Lavg)) L <- lengths(ii) S <- lapply(ii, function(id) dist.dna(z[, id, drop = FALSE], "TS")) V <- lapply(ii, function(id) dist.dna(z[, id, drop = FALSE], "TV")) S <- unlist(S, use.names = FALSE) V <- unlist(V, use.names = FALSE) if (details) { cat(sprintf("\nComparing sequences %d and %d:\n", i, j)) tmp <- rbind(S, V) dimnames(tmp) <- list(c("Transitions", "Transversions"), c("Nondegenerate", "Twofold", "Fourfold")) print(tmp) } P <- S/L Q <- V/L a <- 1/(1 - 2*P - Q) b <- 1/(1 - 2*Q) c <- (a - b)/2 A <- log(a)/2 - log(b)/4 B <- log(b)/2 dS <- (L[2]*A[2] + L[3]*A[3])/sum(L[2:3]) + B[3] dN <- A[1] + (L[1]*B[1] + L[2]*B[2])/sum(L[1:2]) res[k] <- dN/dS k <- k + 1L } } if (!quiet) cat("... done\n") attr(res, "Size") <- n attr(res, "Labels") <- rownames(x) attr(res, "Diag") <- attr(res, "Upper") <- FALSE attr(res, "call") <- match.call() attr(res, "method") <- "dNdS (Li 1993)" class(res) <- "dist" res } .buildDegeneracyMatrix <- function(code) { b <- as.raw(._bs_[1:4]) CODONS <- cbind(rep(b, each = 16), rep(rep(b, each = 4), 4), rep(b, 16)) AA <- trans(CODONS, code = code) degeneracyMatrix <- matrix(0L, 64L, 3L) deg <- c(4L, 2L, 2L, 0L) ## 1/ find the bases at 3rd positions that are twofold/fourfold degenerate s <- 1:4 while (s[4L] <= 64) { degeneracyMatrix[s, 3L] <- deg[length(unique(AA[s]))] s <- s + 4L } ## 2/ all bases at 2nd positions are nondegenerate: no need to do anything ## 3/ are some bases at 1st positions twofold degenerate? s <- c(1L, 17L, 33L, 49L) while (s[1L] < 17) { degeneracyMatrix[s, 1L] <- deg[length(unique(AA[s]))] s <- s + 1L } degeneracyMatrix } latag2n <- function(x) { if (is.list(x)) x <- as.matrix(x) dx <- dim(x) clx <- class(x) res <- .Call(leading_trailing_gaps_to_N, x) class(res) <- clx dim(res) <- dx res } solveAmbiguousBases <- function(x, method = "columnwise", random = TRUE) { if (method == "columnwise") { if (is.list(x)) x <- as.matrix(x) p <- ncol(x) for (j in 1:p) { BF <- base.freq(x[, j], TRUE, TRUE) ambi <- BF[5:15] K <- which(ambi > 0) if (length(K)) { agct <- BF[c(1, 3, 2, 4)] for (b in K) { base <- as.DNAbin(names(ambi[b])) sel <- agct[rev(rawToBits(base))[1:4] == 1] if (!sum(sel)) sel[] <- 1L i <- which(x[, j] == base) tmp <- if (random) sample(names(sel), length(i), TRUE, sel) else names(sel)[which.max(sel)] x[i, j] <- as.DNAbin(tmp) } } } } x } ##distK80 <- function(x, pairwise.deletion = FALSE) ##{ ## nms <- dimnames(x)[[1]] ## n <- length(nms) ## if (!pairwise.deletion) { ## keep <- .Call(GlobalDeletionDNA, x) ## x <- x[, as.logical(keep)] ## d <- .Call(dist_dna_K80_short, x) ## } else { ## d <- .Call(dist_dna_K80_short_pairdel, x) ## } ## attr(d, "Size") <- n ## attr(d, "Labels") <- nms ## attr(d, "Diag") <- attr(d, "Upper") <- FALSE ## attr(d, "call") <- match.call() ## attr(d, "method") <- "K80" ## class(d) <- "dist" ## d ##} ape/R/identify.phylo.R0000644000176200001440000000253514164530562014323 0ustar liggesusers## identify.phylo.R (2011-03-23) ## Graphical Identification of Nodes and Tips ## Copyright 2008-2011 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. identify.phylo <- function(x, nodes = TRUE, tips = FALSE, labels = FALSE, quiet = FALSE, ...) { if (!quiet) cat("Click close to a node of the tree...\n") xy <- locator(1) if (is.null(xy)) return(NULL) lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) ## rescale the coordinates (especially if the x- and ## y-scales are very different): pin <- par("pin") rescaleX <- pin[1]/max(lastPP$xx) xx <- rescaleX * lastPP$xx rescaleY <- pin[2]/max(lastPP$yy) yy <- rescaleY * lastPP$yy xy$x <- rescaleX * xy$x xy$y <- rescaleY * xy$y ## end of rescaling d <- (xy$x - xx)^2 + (xy$y - yy)^2 # no need to sqrt() NODE <- which.min(d) res <- list() if (NODE <= lastPP$Ntip) { res$tips <- if (labels) x$tip.label[NODE] else NODE return(res) } if (tips) { TIPS <- prop.part(x)[[NODE - lastPP$Ntip]] res$tips <- if (labels) x$tip.label[TIPS] else TIPS } if (nodes) { if (is.null(x$node.label)) labels <- FALSE res$nodes <- if (labels) x$node.label[NODE - lastPP$Ntip] else NODE } res } ape/R/reorder.phylo.R0000644000176200001440000000605214164530562014150 0ustar liggesusers## reorder.phylo.R (2017-07-28) ## Internal Reordering of Trees ## Copyright 2006-2017 Emmanuel Paradis, 2017 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .reorder_ape <- function(x, order, index.only, nb.tip, io) { nb.edge <- dim(x$edge)[1] if (!is.null(attr(x, "order"))) if (attr(x, "order") == order) if (index.only) return(1:nb.edge) else return(x) nb.node <- x$Nnode if (nb.node == 1) if (index.only) return(1:nb.edge) else return(x) if (io == 3) { x <- reorder(x) neworder <- .C(neworder_pruningwise, as.integer(nb.tip), as.integer(nb.node), as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), as.integer(nb.edge), integer(nb.edge))[[6]] } else { neworder <- reorderRcpp(x$edge, as.integer(nb.tip), as.integer(nb.tip + 1L), io) } if (index.only) return(neworder) x$edge <- x$edge[neworder, ] if (!is.null(x$edge.length)) x$edge.length <- x$edge.length[neworder] attr(x, "order") <- order x } reorder.phylo <- function(x, order = "cladewise", index.only = FALSE, ...) { ORDER <- c("cladewise", "postorder", "pruningwise") io <- pmatch(order, ORDER) if (is.na(io)) stop("ambiguous order") order <- ORDER[io] .reorder_ape(x, order, index.only, length(x$tip.label), io) } reorder.multiPhylo <- function(x, order = "cladewise", ...) { ORDER <- c("cladewise", "postorder", "pruningwise") io <- pmatch(order, ORDER) if (is.na(io)) stop("ambiguous order") order <- ORDER[io] oc <- oldClass(x) class(x) <- NULL labs <- attr(x, "TipLabel") x <- if (is.null(labs)) lapply(x, reorder.phylo, order = order) else lapply(x, .reorder_ape, order = order, index.only = FALSE, nb.tip = length(labs), io = io) if (!is.null(labs)) attr(x, "TipLabel") <- labs class(x) <- oc x } cladewise <- function(x) reorder(x, "cladewise", index.only = TRUE) postorder <- function(x) reorder(x, "postorder", index.only = TRUE) rotateConstr <- function(phy, constraint) { D <- match(phy$tip.label, constraint) n <- Ntip(phy) P <- c(as.list(1:n), prop.part(phy)) e1 <- phy$edge[, 1L] e2 <- phy$edge[, 2L] foo <- function(node) { i <- which(e1 == node) # the edges where 'node' is ancestral desc <- e2[i] # the descendants of 'node' ## below, min() seems to work better than median() which ## seems to work better than mean() which seems to work ## better than sum() o <- order(sapply(desc, function(x) min(D[P[[x]]]))) for (k in o) { j <<- j + 1L neworder[j] <<- i[k] if ((dk <- desc[k]) > n) foo(dk) } } neworder <- integer(Nedge(phy)) j <- 0L foo(n + 1L) phy$edge <- phy$edge[neworder, ] if (!is.null(phy$edge.length)) phy$edge.length <- phy$edge.length[neworder] attr(phy, "order") <- "cladewise" phy } ape/MD50000644000176200001440000004640314166047412011343 0ustar liggesuserseb723b61539feef013de476e68b5c50a *COPYING dff69373806a64c60b9c6aa57de887e5 *DESCRIPTION bd467ef100a8f3bc5ad57975c8c1c9e3 *NAMESPACE 854a025cb7e5da3e4fe230c0be950d08 *NEWS 4dc75ff83940a80aafe96f6a67eefebf *R/CADM.global.R 4f3a09f6a829d788f273399faaf40285 *R/CADM.post.R f38d9588eb70af94b2d3d1dc7a02d373 *R/CDF.birth.death.R fdb9cfa0cbda82bda982b290693e44e3 *R/Cheverud.R 0d70725d781e9997eb280ce7b42fa5a4 *R/DNA.R 2187a1289b767066d1efe1ebbe7c3b0c *R/MPR.R 74b40c31934a023c64485898b0bd42bb *R/MoranI.R f2017aff2323d76d3727a09516681380 *R/PGLS.R 30b1f0782318dc8ec3212edb4f03c89a *R/RcppExports.R 6be0924b9f043abaee0968de5cf62aa6 *R/SDM.R 315ae41ee77b323b07e63ff861359ae2 *R/SlowinskiGuyer.R 7f3550908532c64ec4968ba5b9ea6b73 *R/ace.R 4ce79cf3f3ff49bef989454d86d0c891 *R/additive.R 1d76af894213570636d36c5a671192b3 *R/alex.R 9fe874382f024a98f62a0ccfcd6d09ac *R/all.equal.phylo.R 2210c4621d33663e9cc786669edef03e *R/apetools.R 4516aef866a59ce7eda91d73364eb046 *R/as.bitsplits.R c94018d5e792c72e20ce84085b2df9e7 *R/as.matching.R 95c7e4a4f49bf7f953d6ebf47ac8efc0 *R/as.phylo.R 2a23cd78c653d6c2fdee0839a14bc642 *R/as.phylo.formula.R 844a38494dd34adbe916bb9116cd0bc2 *R/balance.R 607d7d6bc0ec5559ce1de5b1d1aab0c1 *R/binaryPGLMM.R dca39eb98aad1da417a695d1888e8178 *R/bind.tree.R 62af6b44a6b901ffdea315613dbebe0a *R/biplot.pcoa.R 6cf598c4697ef935c0ef506f3b00565d *R/birthdeath.R 6211edae4ef6683dd741b77f50cf5e27 *R/branching.times.R 9a60d5b6ab2075653649ea2a75fcab04 *R/checkValidPhylo.R e43b5dec7eae6d4bf9371e50117bf6ed *R/cherry.R 56491406d404355aefeb79db3d6f52cd *R/chronoMPL.R 74e1019810b06458e808a447bb099a91 *R/chronopl.R 66297b92d2a53e8aff81ce935aae6711 *R/chronos.R ae04ae67a369579a4685581374a38a79 *R/clustal.R dedf66f0595977a11a7dbc2b0d2f56bb *R/coalescent.intervals.R 5ca572331b7e701c933c1ad9cc56650d *R/collapse.singles.R 338accc0accb8e67f31db5a90c033d2f *R/collapsed.intervals.R 01e979242ba4667e48a80fd32c03f254 *R/compar.gee.R 89ce53eb1bb8c0fb36e95810cf7cd769 *R/compar.lynch.R 207154a3a9b9ebbe5d7c29995565dc82 *R/compar.ou.R 60ff62d4e5ee70e81bfac7120b934c3a *R/comparePhylo.R 8d7c71929156744fd0e4fac370bf9456 *R/compute.brtime.R 98b46d40929780e4b610085c385bc57e *R/cophenetic.phylo.R 13f2dac84d7b8a1da3df0e0c11b4ab1c *R/cophyloplot.R 06659617efcc61ee6ac817c326be0449 *R/corphylo.R 1c3460b48ed1e772c40e5993cd663d43 *R/dbd.R 3822f0bb0a9ed4c8c19654e86ef34359 *R/def.R 93480a5b64e0d37f5450891629557615 *R/delta.plot.R dfd5bb35f1cb1fd9154d023e0e4cfc2b *R/dist.gene.R 54f833f6446b9c39fc153e260634a4c3 *R/dist.topo.R b28ced504fedeb7f991f7eba10ad06df *R/diversi.gof.R 8b2ec4004022afdc7e2cb42f2657b628 *R/diversi.time.R 7014fbfc738cde3c1072cc315f2deb30 *R/drop.tip.R 688534ea02b3ef7e0403081a12f150fb *R/evonet.R fceafc86fae624fd9037403ad301d35a *R/ewLasso.R aa09abeb90ef891384128f978ffce843 *R/extract.popsize.R 5c29d3ee785da587f4ad5288ec36b76a *R/gammaStat.R 2319b283f703eb1bbef58007f92cc31a *R/howmanytrees.R 68d848281455c4c91e9b91f16170e2f7 *R/identify.phylo.R 53ef536bafe7d9ee6b55bc26dad9b256 *R/is.binary.tree.R 36ca87fc7b670608c51146b1d9cc5050 *R/is.compatible.R 96bf9829407fda513d5cd018f27bba48 *R/is.monophyletic.R a7bd37de10eb3f5c02096dfb9a492307 *R/is.ultrametric.R 0e1155005d48770be5ee2507fd7c5d59 *R/ladderize.R c6536c739750042a7c3b6bf34b6fef71 *R/lmorigin.R 8b04202ee3e37522317935a9aa18b875 *R/ltt.plot.R b4f6a07ce62b4ce96bf969874ec7f4c0 *R/makeLabel.R 34069210fd7b12dda0979c45822e4d3a *R/makeNodeLabel.R ddb96055d6308eb4d656f815aac13a02 *R/mantel.test.R d2c16632492bfafd2ee18f2fe3d3d64a *R/matexpo.R 566ed17c837a32977cb1546880d253b0 *R/mcmc.popsize.R 9379468b9db1f4a1ed8a71f9908c3c5f *R/me.R 9f58cc8e04d340f201ed3ab729a1e647 *R/mrca.R eac60117b8225071d992999cf64965d1 *R/mst.R 68dbc2f78a22c00a5a4f3f1d22ffb8a0 *R/multi2di.R 0850fdd19c01d37ac632fc308632a463 *R/mvr.R ffc4b4e4586d6ffde3a995e4852b65ef *R/nj.R e3f22d0f260c43be87a17b0ab091e2bb *R/njs.R a624319e300721fe97e9ec1e8ae6dbe6 *R/node.dating.R 56aaf273455f4c52d123326d3689c923 *R/nodelabels.R ae2aeb0e8aef7f8d4b19939ca61b3482 *R/nodepath.R d9fd8e402e6fce6939a05332823a9390 *R/parafit.R dd95923aac8ab849dd128104355529ce *R/pcoa.R c2357dbf0ca7198c58d97e08ad3d16c4 *R/phydataplot.R e71db002c66c277bfb57f6914ca143d4 *R/phymltest.R 615818acb88bc5c6d232b8b052506176 *R/pic.R 35a6c9bcdbb5d64b64a064953bbdca91 *R/plot.phylo.R 6c744c311f1bc32ff85d639b75ec958f *R/plot.phyloExtra.R 5c12c911fc422f8f8d8e160ef79f312d *R/plot.popsize.R dd009da9120a99c30ca4169b61e5d195 *R/plotPhyloCoor.R 020684fdb44028c4858bb0d2eb5d3848 *R/print.lmorigin.R d0e8bd41d5acc217fdee3578adcf635b *R/print.parafit.R 756e90b3b32ddc0b07b2ad8dbe43d5aa *R/rTrait.R fa870a41e2422747ce4232896723a7bb *R/read.GenBank.R b13dfb8f455b1c9e74a364085f72dbce *R/read.caic.R 0a94085734afd8c8144969745e63e9a2 *R/read.dna.R 23f0c2804b21bc58ca30284f1c920bae *R/read.gff.R 91fba3c1855093faeaf868ec907bc8e2 *R/read.nexus.R f32f0efa7f1831327407314d5551223d *R/read.nexus.data.R 50ca28afa7dcdc76b1ebb372707e6163 *R/read.tree.R df2ac5d3de7185c7e26fc95b35192a40 *R/reconstruct.R d7486ab8ac6d584f04bf1f75ca7f6be3 *R/reorder.phylo.R 9e19dd1ffa47aa5432b7b34d69258dc9 *R/root.R f584366b32e7414c669714ba5b84951b *R/rotate.R d5abeb2b5165f3d9613392d0c8f03802 *R/rtree.R be352a2ab62b61eaf8186a7f9b682798 *R/rtt.R 7d97fe87a4c5abac659d4a9abaf152e6 *R/scales.R d2e06f8288af941a00c46248b586225a *R/skyline.R 1f82059f740388b7430b2359e54a147f *R/skylineplot.R 9c7b02a4625099f715700fb868226b0f *R/speciesTree.R 97c4c3d7cb1606fe6d5519d817156bde *R/subtreeplot.R bcc8f1fc8363728caba82129412d9e31 *R/subtrees.R 9f3b6e9b03e4e76a3ffa1dd93284c108 *R/summary.phylo.R 8fbd1589f5d98d76b1154cffb8d4d1f5 *R/treePop.R b5081fca8758fe4458183c3e25e3e661 *R/triangMtd.R aca0e4f1c8aae416e5941adaaf47ba64 *R/unique.multiPhylo.R 2937379ad9e91e263b7956c264926466 *R/varcomp.R a40ae9ad30c221d4ed14b90e8b406f93 *R/vcv.phylo.R 31b3bb1feed474692f07fcebe3a61ac7 *R/vcv2phylo.R c9adce0f3d0120434ca22f2bb2a0b0c8 *R/which.edge.R a091953ea941768033d85494e6457691 *R/write.dna.R 2a9393fed275f1b214c0f4fb264f574a *R/write.nexus.R a6d3d8d0fb844c0670d5674a1def2bd0 *R/write.nexus.data.R 56e42817fb5ecb97e114290a655d152b *R/write.tree.R 774ce72875903259aade5344f9a70aa4 *R/yule.R c8d3aa3fe64e75e61af07a1b11c74f3f *R/yule.time.R 1eb44ff9e5a036eb845faa1598ce5009 *R/zoom.R 3387c0d0c1f913f8471e1bb34bd2e516 *R/zzz.R 76745d369c54bcccef80b27be05d4602 *README.md 2308b347ab713b59005a8f1a0fc9bf88 *build/partial.rdb 9dba3c68c5bae2b18007a3726426e7c6 *build/vignette.rds db9083e8750aff839d5ebf3ed982f1f1 *data/HP.links.rda 9d9f9232839665422709ded1e541d038 *data/bird.families.rda a14a6df0f3a735ebc056065077788c90 *data/bird.orders.rda f74f9ed80c04756021cc093d40ca9ff9 *data/carnivora.csv.gz 4eaf8cbaefa2e8f8d395a9b482ee9967 *data/chiroptera.rda 1c74c3b99d08b0e17eea3ec1065c12d2 *data/cynipids.rda 7fe760c2f3b4deba0554aae6138cb602 *data/gopher.D.rda a50de1a68c246297839c26d592191504 *data/hivtree.newick.rda 8d14f95319d0a5cdc8faa60a1d0085ce *data/hivtree.table.txt.gz 31be81fe3faca11f98d3e74c090bc59e *data/lice.D.rda 38edbd84a0a067322c40db8d71fb1289 *data/lmorigin.ex1.rda e3ce9e3444182fea2e65df2e150ea0db *data/lmorigin.ex2.rda ce7a56faebdf286fdf5ba6c8c3699a79 *data/mat3.RData e2d1339025ed901009bfed58dc6505ff *data/mat5M3ID.RData 101d0ab2e981b0987cde704a2dee1d8d *data/mat5Mrand.RData 39e4fece2bdc527d7a9d4d83d023a947 *data/woodmouse.rda a8ae5eb66e5a3936afee2d1a3671761a *inst/CITATION 44e0e7e0eb4c9edcdbe731d15ad245d1 *inst/doc/DrawingPhylogenies.R fe9b452b3978a7379c50f5294b94badc *inst/doc/DrawingPhylogenies.Rnw 80b3af4f4ae79161ef0913bb34a707f1 *inst/doc/DrawingPhylogenies.pdf ae58e3a830ca118636ac7f12cee14cdd *inst/doc/MoranI.R dcd55bda01ae5c227823285f250a5adf *inst/doc/MoranI.Rnw 63de45278ab947cd683d92b41155c48d *inst/doc/MoranI.pdf 6db8a8dd3ff8d7bb64ecb15b3d7e4ac3 *inst/doc/RandomTopologies.R d53cbb2223d381dbda1c8f0117e1655c *inst/doc/RandomTopologies.Rnw 1d36ba539425815e5ba7d268e9fb718e *inst/doc/RandomTopologies.pdf 5c133fd944233aaf92d4317149e5c2ea *man/AAbin.Rd 7f7b284190c3b52358bd330ea58cdf8e *man/CADM.global.Rd 1abe36a10c34884230d6779d1c6058dd *man/DNAbin.Rd d94f358593695b1713840df5a8c000ba *man/DNAbin2indel.Rd 45e47a857e1cba34b898ddd6e846510d *man/Initialize.corPhyl.Rd ab4685ee7e884b03d622fcf841f5da08 *man/LTT.Rd ab69dfa02f245501d05550e64e6a90a5 *man/MPR.Rd 1c59c53b21d33352ff2d45c97af02e1b *man/MoranI.Rd c7866d0fc32be91d9cfb6ab3e3fc1e1a *man/SDM.Rd 934495a152949cd56a805aaa6aa85b1d *man/ace.Rd 1e45e292cea5a4f0154ffeafd67fd832 *man/add.scale.bar.Rd 78bc6e463d7708061f49312b6e412886 *man/additive.Rd 25a2859708b9a281a0d682e4376f3f53 *man/alex.Rd 2ff5d30c6fb1c5458643f1b3c09e76da *man/all.equal.DNAbin.Rd d69fcc8e2e02aff7cdd0decbbd892e40 *man/all.equal.phylo.Rd b9e6f622b239d6ef2614285f3a343ee3 *man/alview.Rd 939b7b612a00127a0cde328f619c82fb *man/ape-internal.Rd 35f531f89254780beb7be3e4ef632ad1 *man/ape-package.Rd f52b5e2d34295171a6da2359738c99d5 *man/apetools.Rd 5bba4ae4bfc66b613855cfc182d9b1bc *man/as.alignment.Rd d087bf5c0b9206e276a03a62b72a2252 *man/as.bitsplits.Rd 4f014cf2923e2eab6188acd48e8096fa *man/as.matching.Rd 84b636fd9928b77de91504121216da61 *man/as.phylo.Rd 697944c0dca01d11817401e1a57049d2 *man/as.phylo.formula.Rd c1bb2b36369966cc61f802daa27921a2 *man/axisPhylo.Rd ad514b163e70bfbc11dfd34a450799f8 *man/balance.Rd 1f7aab487d391940a07950332696915e *man/base.freq.Rd 524a1163eac56d1fc7f65bcd6c74a8d0 *man/bd.ext.Rd 5f1e61abe5908708f503cb2626a1b5e6 *man/bd.time.Rd f929bc1b6391c57a6b0099c4561fd7be *man/binaryPGLMM.Rd bfbc3c952d7af7214fb060076b4c079e *man/bind.tree.Rd 822558d4f7ee04257b2c903c53ec4344 *man/bionj.Rd 923169087dca05f046cebcac8946e136 *man/bird.families.Rd 0e41770e1e6d0b8d90c4cf51049213cb *man/bird.orders.Rd ef1c15d5d93410c21179997431112209 *man/birthdeath.Rd ad8fb2e5cdb596adbe5b90bc5c45ce12 *man/boot.phylo.Rd 5a64b90d3a6c7a8204946b00f45f4cfc *man/branching.times.Rd 99ffa532ab4397c374eaddd0f2ff8469 *man/c.phylo.Rd 6ddcfd41f33b85334a04f2c252a2f561 *man/carnivora.Rd a35edcfb2299e68b6378961c0755c4ea *man/checkAlignment.Rd c3f19bb492f50bfb1b4f1928a4671abd *man/checkLabel.Rd 5ff8c7e8fad519d978f166948c03059c *man/checkValidPhylo.Rd 64c3996ca6bcc97d0d2e2cf3361f8f71 *man/cherry.Rd 8745774298f92d8415b508c990976fa2 *man/chiroptera.Rd c68be7ff5a08664691df3e2813468490 *man/chronoMPL.Rd c1f01c6200b2f1e2901d45d40daae404 *man/chronopl.Rd 729046ab372c57773441d466b2f2bd6a *man/chronos.Rd fb080356b866855ea47948168e7d927c *man/clustal.Rd 866af6e8d769b3d6972ef8e1ac849a12 *man/coalescent.intervals.Rd b114a09e0cb474323d5398ec4ee83d3c *man/collapse.singles.Rd bff5a7826f5a39767601e32ceb776247 *man/collapsed.intervals.Rd 683bf7d71e50f4ec5cd921073291eddd *man/compar.cheverud.Rd 4d8ee141d7b6b323ef5ee9446000ae32 *man/compar.gee.Rd 8b7388332d96b234b274fd3433e0da1f *man/compar.lynch.Rd 8b079bc165c375f823c40074ad9106c6 *man/compar.ou.Rd a49d26747890cef3b75bcc46b0b8b40b *man/comparePhylo.Rd a1d0980f32039aa2ca0a0b1b7a5591f8 *man/compute.brlen.Rd dbb4b5b1d5136bd32660699d9d4cc197 *man/compute.brtime.Rd 6b1a39560c6fab87b6f6265d38a005f5 *man/consensus.Rd 1e5b635a08fe0e1242801ff0caec9d0d *man/cophenetic.phylo.Rd 1ca9ec0cb824468adc03884c940c7aa3 *man/cophyloplot.Rd 643275d7997dfcd82b1ff08057b3f1a7 *man/corBlomberg.Rd acc4baf0e83e68ea4416a793c92a2b7c *man/corBrownian.Rd 8d4d9c49195cee8868e21a5f00b0ed62 *man/corClasses.Rd dfff1f03f7cc26a06b49284bf223aae1 *man/corGrafen.Rd c07362b1c46059f78e603af68add6165 *man/corMartins.Rd 10242491bb412743df6756d544399c4c *man/corPagel.Rd e259ee771509883d3afe8eafd41e9cb1 *man/corphylo.Rd 0a61099bc0490d00f6622d049c54f6d7 *man/correlogram.formula.Rd c199605f9d353b303acad4896f9b39a5 *man/cynipids.Rd 34164e368efd0d5d961fe62e9ede75e8 *man/dbd.Rd c0763a70c4965a6b03df3e5be68e450d *man/def.Rd 207a7b94141275474c4b2f5e51c09511 *man/degree.Rd 95621da51b61fe6a551369222015192f *man/del.gaps.Rd fbcd1d4bcf74e21fc93c195c7af3db98 *man/delta.plot.Rd 9892ec82164c751b1ef5605d64bd5731 *man/dist.dna.Rd 38011e81d28a120d88eead09e62c154a *man/dist.gene.Rd 4ed71ddf83307cac83ffe567c3b1c5ac *man/dist.topo.Rd c7cc398115be066740ca4fb037394727 *man/diversi.gof.Rd d646ea0343999bd0e38e86dcf6c12018 *man/diversi.time.Rd da8898476bb15b627b34ee1093b9aeb4 *man/diversity.contrast.test.Rd 25100a091b190cfc0cc4bac7b209143e *man/dnds.Rd 7e604b3dee6fc7b073d02654080dd4d1 *man/drop.tip.Rd 6ae02a689abea279f7e6650678aa7ae2 *man/edges.Rd 3eb82a23c0ece8a095c8f472736f33a1 *man/evonet.Rd 9697317017dd41a68961522fb26b6222 *man/ewLasso.Rd b81094916d0dda1483e31da6681f3bc2 *man/fastme.Rd eea313e8ee32597b4cec120d23113642 *man/gammaStat.Rd 3684afa97b61c1e07f02327a7f2b9acd *man/getAnnotationsGenBank.Rd ccf012737965d0de0b4ca2dd9367d9a6 *man/hivtree.Rd 4c2fee931d4a7b8242250197b4cd7ca9 *man/howmanytrees.Rd 86c49d080fdffd614d8056021e91cc55 *man/identify.phylo.Rd b8ba66426802e3dfe44def33f8ebef03 *man/image.DNAbin.Rd 0ede757d7bed82216980d3c4fd592cb6 *man/is.binary.tree.Rd 18329c0c629c76de2bd4823aefecdfb5 *man/is.compatible.Rd d2de8fd9549ef01a1dddeb726dd77fcf *man/is.monophyletic.Rd ad9e7316219c3238b44b02d55c44b4d3 *man/is.ultrametric.Rd 3f6ff8340b6c9770a1f4d2fed72a295d *man/kronoviz.Rd 4d8fee8d142528834332038e49bd2e65 *man/label2table.Rd 2afa6305e48e4c47a7d94d46401f85a3 *man/ladderize.Rd 472dc874a45f046c8f6ac7b394b6552f *man/latag2n.Rd 4b86460e4e5d993abf13c99b9744dbd6 *man/lmorigin.Rd e511f2fff7d9cf6dda5598255f9fd356 *man/ltt.plot.Rd 50eb320c835587c23f5a4a871f9fd8a9 *man/makeLabel.Rd ec208cd17d935768077844d8322db135 *man/makeNodeLabel.Rd 12e661774a33b431717195cf652ebe4c *man/mantel.test.Rd 97cf5ddb9352b0545ed225d16d750ffb *man/mat3.Rd f56f6f49c89c6bc850a7aee1bce5e0bd *man/mat5M3ID.Rd 0d8eb60696c80de3cc9cc85ba66373a5 *man/mat5Mrand.Rd 69ae0cb181240bb8ec168e69f1ba44bb *man/matexpo.Rd 63b52766bbe7ad0bd31aa5f04026b21a *man/mcconwaysims.test.Rd 58c13c9bb88f6d36eafeb62619cd970e *man/mcmc.popsize.Rd 5c5b3f307a46d0739d3979693ebb8db5 *man/mixedFontLabel.Rd ab32c16c1290a7a5057d743951f041b0 *man/mrca.Rd e43c99975336bdf600dcdf0bc93cf4e9 *man/mst.Rd 4eb505aab5154fc9bf729a058ec08a72 *man/multi2di.Rd 029b04adeafe89ea5edf9a1ab00cd154 *man/multiphylo.Rd 24113582bd3f1363a2910778b0f0056c *man/mvr.Rd 3df9e16b8a09df3f1dba5c4327a635fc *man/nj.Rd b1db2e34c13cc343e4ecdd7ae2ca31aa *man/njs.Rd 66ab55c2ecf8de706b585863a9f20d74 *man/node.dating.Rd a589b4cc04505185dc9ef1817c7ae304 *man/node.depth.Rd 856927a8a59da8bffc5b7c71b0246cdc *man/nodelabels.Rd 447ae03684ff56a4a24932aec182acf3 *man/nodepath.Rd c2e2f35f4e233265c86b7967ec2d0630 *man/parafit.Rd 2912b4bd180c08a4aecb95536d5786ad *man/pcoa.Rd 0089077e3be11d37650331437e4a8a48 *man/phydataplot.Rd 6dfa52711bab351bbcfe2624690eb730 *man/phymltest.Rd 468e1d9163304629213d4f2ae5294f4b *man/pic.Rd 0363aa3fa3e86160934e2359c8ac5323 *man/pic.ortho.Rd 265527313d479d3625df7680c7479cd1 *man/plot.correlogram.Rd d20a070f92d9035e4d6bc7feea0e2e3d *man/plot.phylo.Rd 896198fa3a0ce916346c8b507bf707bf *man/plot.phyloExtra.Rd d39058b543c60b3f2a2c22cd88325bb6 *man/plot.varcomp.Rd c6ff668831b791540e543df87d952ad8 *man/plotTreeTime.Rd b24438c42cea969302ec6ba61002426e *man/print.phylo.Rd 33969ca9cf96574407bb764b3c7c5c10 *man/rDNAbin.Rd cd98ef01fc72ff6a66cf6d24a5197259 *man/rTraitCont.Rd 59e81eaae91dc77b4275c9a5b2910dda *man/rTraitDisc.Rd 81f756fdf2ec4c968095595dece8338f *man/rTraitMult.Rd a540f8a85f14d4c4ece1d1a19cb15a6f *man/read.GenBank.Rd 0b7b51b8947b4ea23ed5d6afd48fbc23 *man/read.caic.Rd 0dc0899b49abbdd8c8ffbb51328586ec *man/read.dna.Rd 4bd8a114f7ab4b9ffffd7fd4d1799b36 *man/read.gff.Rd fdc2393e70328ae27034c54bf8a847c7 *man/read.nexus.Rd 9c1d50a3701690f505a8d702bb5d7d24 *man/read.nexus.data.Rd 80aaced77530e1d5faf459f8695baea2 *man/read.tree.Rd 9224f164351fea4be9f7ce9d827f8e58 *man/reconstruct.Rd 29fd18c1d0729228307b82dc3ef70ede *man/reorder.phylo.Rd 23cb928f62f9c7103244fbd752ff9a81 *man/richness.yule.test.Rd 272d66917985780ed4ba250087765d7d *man/rlineage.Rd 18fde0cf7945e9386f51e6a3182f25af *man/root.Rd 6b97ea2fd96bf948fca764deab3a6e76 *man/rotate.Rd 5d5f04688b95ccfa0f6c611f19c701d6 *man/rtree.Rd 2d8fe8b90578d7f9070a70032acf44b9 *man/rtt.Rd 2e343e95a46c16a34fe7a80fe0b6df7f *man/seg.sites.Rd f125fe172ee83b8bb4adaede4b4d3b43 *man/skyline.Rd bf851aa61b6310afa2ae1358c189dad7 *man/skylineplot.Rd e19ab3b2473f70bd47533b321bed84fa *man/slowinskiguyer.test.Rd 3e324bedd9f05850b904bf9dc66cbc24 *man/solveAmbiguousBases.Rd 201f06e5f36495dda446d523dbabf354 *man/speciesTree.Rd 8fc51ff26614e7c713be2570d9af47b6 *man/stree.Rd 1f1309e2ec6327974952d546241a6024 *man/subtreeplot.Rd ef8aa9721275f20ddd38612cddf8300c *man/subtrees.Rd d684cc640acf041c6f1124e08426c8c8 *man/summary.phylo.Rd 587737eccd2f0e06192977e079d11645 *man/trans.Rd b6c871959a20eb198c02267c9ce7c74e *man/treePop.Rd 7749863f505076f2288c106eb465805e *man/trex.Rd 8d5cf8c4cc27211d87bbed954ca50bbb *man/triangMtd.Rd 9e7d047e16ff821f3b7254b92d027bf0 *man/unique.multiPhylo.Rd e0367dac321ec52f8c962416fb57305d *man/updateLabel.Rd 3fc83bd5ac2be01f581d0aa5a1038b80 *man/varCompPhylip.Rd 8be1d0b6dd12f066000dc70d31c9d831 *man/varcomp.Rd 5c459720196654a10cfff0390bffc14f *man/vcv.phylo.Rd f7ce7760e913c10f1cb7be05315b39fc *man/vcv2phylo.Rd a5d3cbf19df84d0f1e4e3a4650945cbf *man/weight.taxo.Rd f4f11cb67f304e5de80d4768508dd765 *man/where.Rd ef9658f5343bdcbfc3673c7f936934f5 *man/which.edge.Rd 9b83a148295dcfcb3994fdb6eaab0174 *man/woodmouse.Rd a0f59b5f53c0e8f5d45380cbaf71fb58 *man/write.dna.Rd df8657f468307a02b8cde93ff4758f1c *man/write.nexus.Rd 9813a7c7a95bf532ffa1297d8369457c *man/write.nexus.data.Rd 06fcd0c13156f7ccc187595adc414d78 *man/write.tree.Rd 2568c6529e40fae7effe88b6c73998a1 *man/yule.Rd 7df89ac6996c82b52c4c9b3734807de1 *man/yule.cov.Rd 8612123f3617699a8e29ddf0541dc9ee *man/yule.time.Rd a00006ae345bb9379312e81694de3885 *man/zoom.Rd 225b45505001f9311e1d76f3a880cd70 *src/BIONJ.c 2a6f9e9e044a78154d3cfda5936d6f48 *src/Makevars c948a9234ab872e4c076390eda80c465 *src/NNI.c e3213d06c9d8cfe2deec76bc43d7eace *src/RcppExports.cpp 122ba51b574f7f7acd5ea4b6256cea5f *src/SPR.c 9733c82cd67c4bd41aea44981f4ac8b8 *src/additive.c dd6795fab58ce72bc7905726d911a441 *src/ape.c 7eaffd3d85df9a1e4460905e9ca5eced *src/ape.h 19b564aab62c464c092cdf2f0d5cf447 *src/bNNI.c 8e092de02c58cce3c85dc944665f1f03 *src/bionjs.c 1873b242cd0926effe77daca9a8e9a63 *src/bipartition.c cc02d4de52a7d231ab8582ed6273befc *src/bitsplits.c 81e4ad60b418966cdd09e608e074bb28 *src/delta_plot.c 58a032e97a56e4c41fb9717484d23df5 *src/dist_dna.c 2a6a59a3a220eb855a3c48bc73dc54ba *src/dist_nodes.c 005ab69356525fbbc1b69950341308c2 *src/ewLasso.c afa27403972145d083d7f7f8b2536b98 *src/heap.c a284dc0d46dd1b091f725aa7c5fe0bf1 *src/mat_expo.c 8690aa3b907ed3f407d2d7b8f2205700 *src/me.c 52c31d588a767b637b5a852fceeeb154 *src/me.h cc4c695b4b001305b83658df8075850e *src/me_balanced.c cf2bdcf9eda24eb6b572584c0ab79fb4 *src/me_ols.c 8f25a7d4686c85b25862941c023e5974 *src/mvr.c f9e2d2d972065aa012820f7e191fa97d *src/mvrs.c 8a84e0559891b05e00c52cf5337c2ead *src/nj.c c027ccb515c9f76c10ae390e60039a40 *src/njs.c 72e310102d7db22ae9b6794d153889ac *src/pic.c 9643db2c211ee54a978ac50f3909cd43 *src/plot_phylo.c 505bade4a05aa07561d67180a6e020ba *src/prop_part.cpp aa8d9966da3b7e970879a49a40c05a07 *src/rTrait.c cea461f86f87000ed51808282d799600 *src/read_dna.c f30c6b59e86ad6e7c357d6f054e12f92 *src/reorder_Rcpp.cpp 77c49127a8c5b23efcfe90a0b29bd7ba *src/reorder_phylo.c c73f78b21f3cada4ebb5035ac866d0f3 *src/treePop.c 9d523dc0a364b0ff40400451829a7433 *src/tree_build.c 42c108c79f26d1940f94b98fcbe271e1 *src/tree_phylo.c b6b0929c7faa1b76a8898f12907aabd5 *src/triangMtd.c cca4da03778dfa7c87fa6bfb97aac13c *src/triangMtds.c 72e04107c752568641219bf57b5731a8 *src/ultrametric.c fe9b452b3978a7379c50f5294b94badc *vignettes/DrawingPhylogenies.Rnw dcd55bda01ae5c227823285f250a5adf *vignettes/MoranI.Rnw d53cbb2223d381dbda1c8f0117e1655c *vignettes/RandomTopologies.Rnw 4fce0bc02d12ec1600c49de9c27d85ba *vignettes/ape.bib 31968dd62224a9e5ac7f9969af87f9f0 *vignettes/ape.sty ape/inst/0000755000176200001440000000000014164530667012010 5ustar liggesusersape/inst/doc/0000755000176200001440000000000014164530667012555 5ustar liggesusersape/inst/doc/DrawingPhylogenies.Rnw0000644000176200001440000012244714164530562017053 0ustar liggesusers\documentclass[a4paper]{article} %\VignetteIndexEntry{Drawing Phylogenies} %\VignettePackage{ape} \usepackage{ape} \author{Emmanuel Paradis} \title{Drawing Phylogenies in \R: Basic and Advanced Features With \pkg{ape}} \begin{document} \DefineVerbatimEnvironment{Sinput}{Verbatim}{formatcom=\color{darkblue}} \DefineVerbatimEnvironment{Soutput}{Verbatim}{formatcom=\color{black}\vspace{-1.5em}} \maketitle \tableofcontents\vspace*{1pc}\hrule <>= options(width = 80, prompt = "> ") @ \vspace{1cm} \section{Introduction} Graphical functions have been present in \ape\ since its first version (0.1, released in August 2002). Over the years, these tools have been improved to become quite sophisticated although complicated to use efficiently. This document gives an overview of these functionalities. Section~\ref{sec:basic} explains the basic concepts and tools behind graphics in \ape. A figure made with \ape\ usually starts by calling the function \code{plot.phylo} which is detailed in Section~\ref{sec:plotphylo}, and further graphical annotations can be done with functions covered in Section~\ref{sec:annot}. Section~\ref{sec:spec} shows some specialized functions available in \ape, and finally, Sections~\ref{sec:geom} and \ref{sec:build} give an overview of some ideas to help making complicated figures. \section{Basic Concepts}\label{sec:basic} The core of \ape's graphical tools is the \code{plot} method for the class \code{"phylo"}, the function \code{plot.phylo}. This function is studied in details in Section~\ref{sec:plotphylo}, but first we see the basic ideas behind it and other functions mentioned in this document. \subsection{Graphical Model} The graphical functions in \ape\ use the package \pkg{graphics}. Overall, the conventions of this package are followed quite closely (see Murrell's book \cite{Murrell2006}), so users familiar with graphics in \R\ are expected to find their way relatively easily when plotting phylogenies with \ape. \ape\ has several functions to perform computations before drawing a tree, so that they may be used to implement the same graphical functionalities with other graphical engines such as the \pkg{grid} package. These functions are detailed in the next section. To start simply, we build a small tree with three genera of primates which we will use in several examples in this document: <<>>= library(ape) mytr <- read.tree(text = "((Pan:5,Homo:5):2,Gorilla:7);") @ \noindent Now let's build a small function to show the frame around the plot with dots, and the $x$- and $y$-axes in green: <<>>= foo <- function() { col <- "green" for (i in 1:2) axis(i, col = col, col.ticks = col, col.axis = col, las = 1) box(lty = "19") } @ \noindent We then plot the tree in four different ways (see below for explanations about the options) and call for each of them the previous small function: <>= layout(matrix(1:4, 2, 2, byrow = TRUE)) plot(mytr); foo() plot(mytr, "c", FALSE); foo() plot(mytr, "u"); foo() par(xpd = TRUE) plot(mytr, "f"); foo() box("outer") @ \noindent The last command (\code{box("outer")}) makes visible the most outer frame of the figure showing more clearly the margins around each tree (more on this in Sect.~\ref{sec:geom}). We note also the command \code{par(xpd = TRUE)}: by default this parameter is \code{FALSE} so that graphical elements (points, lines, text, \dots) outside the plotting region (i.e., in the margins or beyond) are cut (clipped).\footnote{\code{par(xpd = TRUE)} is used in several examples in this document mainly because of the small size of the trees drawn here. However, in practice, this is rarely needed.} These small figures illustrate the way trees are drawn with \ape. This can be summarised with the following (pseudo-)algorithm: \bigskip\hrule height 1pt\relax %\renewcommand{\theenumi}{\alph{enumi}} \renewcommand{\labelenumi}{\textbf{\theenumi.}} \begin{enumerate}\small \item Compute the node coordinates depending on the type of tree plot, the branch lengths, and other parameters. \item Evaluate the space required for printing the tip labels. \item Depending on the options, do some rotations and/or translations. \item Set the limits of the $x$- and $y$-axes. \item Open a graphical device (or reset it if already open) and draw an empty plot with the limits found at the previous step. \item Call \code{segments()} to draw the branches. \item Call \code{text()} to draw the labels. \end{enumerate} \hrule height 1pt\relax\bigskip There are a lot of ways to control these steps. The main variations along these steps are given below. \textbf{Step 1. } The option \code{type} specifies the shape of the tree plot: five values are possible, \code{"phylogram"}, \code{"cladogram"}, \code{"fan"}, \code{"unrooted"}, and \code{"radial"} (the last one is not considered in this document). The first three types are valid representations for rooted trees, while the fourth one should be selected for unrooted trees. The node coordinates depend also on whether the tree has branch lengths or not, and on the options \code{node.pos} and \code{node.depth}. This is illustrated below using a tree with eight tips and all branch length equal to one (these options have little effect if the tree has only three tips): <<>>= tr <- compute.brlen(stree(8, "l"), 0.1) tr$tip.label[] <- "" @ \noindent We now draw this tree using the option \code{type = "phylogram"} (first column of plots) or \code{type = "cladogram"} (second column) and different options: <>= foo <- function() { col <- "green" axis(1, col = col, col.ticks = col, col.axis = col) axis(2, col = col, col.ticks = col, col.axis = col, at = 1:Ntip(tr), las = 1) box(lty = "19") } @ <<>>= @ <>= layout(matrix(1:12, 6, 2)) par(mar = c(2, 2, 0.3, 0)) for (type in c("p", "c")) { plot(tr, type); foo() plot(tr, type, node.pos = 2); foo() plot(tr, type, FALSE); foo() plot(tr, type, FALSE, node.pos = 1, node.depth = 2); foo() plot(tr, type, FALSE, node.pos = 2); foo() plot(tr, type, FALSE, node.pos = 2, node.depth = 2); foo() } @ \noindent Some combinations of options may result in the same tree shape as shown by the last two rows of trees. For unrooted and circular trees, only the option \code{use.edge.length} has an effect on the layout and/or the scales of the axes: <>= foo <- function() { col <- "green" for (i in 1:2) axis(i, col = col, col.ticks = col, col.axis = col, las = 1) box(lty = "19") } @ <>= layout(matrix(1:4, 2, 2)) par(las = 1) plot(tr, "u"); foo() plot(tr, "u", FALSE); foo() plot(tr, "f"); foo() plot(tr, "f", FALSE); foo() @ \textbf{Step 2.} In the \pkg{graphics} package, text are printed with a fixed size, which means that whether you draw a small tree or a large tree, on a small or large device, the labels will have the same size. However, before anything is plotted or drawn on the device it is difficult to find the correspondence between this size (in inches) and the user coordinates used for the node coordinates. Therefore, the following steps are implemented to determine the limits on the $x$-axis: \renewcommand{\labelenumi}{\theenumi.} \begin{enumerate} \item Find the width of the device in inches (see Sect.~\ref{sec:overlay}). \item Find the widths of all labels in inches: if at least one of them is wider than the device, assign two thirds of the device for the branches and one third to the tip labels. (This makes sure that by default the tree is visible in the case there are very long tip labels.) \item Otherwise, the space allocated to the tip labels is increased incrementally until all labels are visible on the device. \end{enumerate} The limits on the $y$-axis are easier to determine since it depends only on the number of branches in the tree. The limits on both axes can be changed manually with the options \code{x.lim} and \code{y.lim} which take one or two values: if only one value is given this will set the rightmost or uppermost limit, respectively; if two values are given these will set both limits on the respecive axis.\footnote{These two options differ from their standard counterparts \code{xlim} and \code{ylim} which always require two values.} By default, there is no space between the tip labels and the tips of the terminal branches; however, text strings are printed with a bounding box around them making sure there is actually a small space (besides, the default font is italics making this space more visible). The option \code{label.offset} (which is 0 by default) makes possible to add an explicit space between them (this must be in user coordinates). \textbf{Step 3.} For rooted trees, only 90\textdegree\ rotations are supported using the option \code{direction}.\footnote{To have full control of the tree rotation, the option `rotate' in \LaTeX\ does the job very well.} For unrooted (\code{type = "u"}) and circular (\code{type = "fan"}) trees, full rotation is supported with the option \code{rotate.tree}. If these options are used, the tip labels are not rotated. Label rotation is controlled by other options: \code{srt}\footnote{\code{srt} is for \textit{string rotation}, not to be confused with the function \code{str} to print the \textit{structure} of an object.} for all trees, and \code{lab4ut} for unrooted trees. \textbf{Step 4.} These can be fully controlled with the options \code{x.lim} and \code{y.lim}. Note that the options \code{xlim} and \code{ylim} \emph{cannot} be used from \code{plot.phylo}. \textbf{Step 5.} If the options \code{plot = FALSE} is used, then steps 6 and 7 are not performed. \subsection{Computations}\label{sec:comput} As we can see from the previous section, a lot of computations are done before a tree is plotted. Some of these computations are performed by special functions accessible to all users, particularly the three functions used to calculate the node coordinates. First, two functions calculate ``node depths'' which are the coordinates of the nodes on the $x$-axis for rooted trees: <<>>= args(node.depth.edgelength) args(node.depth) @ \noindent Here, \code{phy} is an object of class \code{"phylo"}. The first function uses edge lengths to calculate these coordinates, while the second one calculates these coordinates proportional to the number of tips descending from each node (if \code{method = 1}), or evenly spaced (if \code{method = 2}). The third function is \code{node.height} and is used to calculate ``node heights'', the coordinates of the nodes on the $y$-axis: <<>>= args(node.height) @ \noindent If \code{clado.style = TRUE}, the node heights are calculated for a ``triangular cladogram'' (see figure above). Otherwise, by default they are calculated to fall in the middle of the vertical segments with the default \code{type = "phylogram"}.\footnote{It may be good to remind here than these segments, vertical since \code{direction = "rightwards"} is the default, are not part of the edges of the tree.} For unrooted trees, the node coordinates are calculated with the ``equal angle'' algorithm described by Felsenstein \cite{Felsenstein2004}. This is done by an internal function which arguments are: <<>>= args(unrooted.xy) @ \noindent There are three other internal functions used to plot the segments of the tree after the above calculations have been performed (steps 1--4 in the previous section): <<>>= args(phylogram.plot) args(cladogram.plot) args(circular.plot) @ \noindent Although these four functions are not formally documented, they are anyway exported because they are used by several packages outside \ape. \section{The \code{plot.phylo} Function}\label{sec:plotphylo} The \code{plot} method for \code{"phylo"} objects follows quite closely the \R\ standard practice. It has a relatively large number of arguments: the first one (\code{x}) is mandatory and is the tree to be drawn. It is thus not required to name it, so in practice the tree \code{tr} can be plotted with the command \code{plot(tr)}. All other arguments have default values: <<>>= args(plot.phylo) @ \noindent The second and third arguments are the two commonly used in practice, so they can be modified without explicitly naming them like in the above examples. Besides, \code{"cladogram"} can be abbreviated with \code{"c"}, \code{"unrooted"} with \code{"u"}, and so on. For the other arguments, it is better to name them if they are used or modified (e.g., \code{lab4ut = "a"}). \subsection{Overview on the Options} The logic of this long list of options is double: the user can modify the aspect of the tree plot, and/or use some of these options to display some data in association with the tree. Therefore, the table below group these options into three categories. The following two sections show how data can be displayed in connection to the tips or to the branches of the tree. \begin{center} \begin{tabular}{lll} \toprule Aspect of the tree & Attributes of the labels & Attributes of the edges\\ \midrule \code{type} & \code{show.tip.label} & \code{edge.color}\\ \code{use.edge.length} & \code{show.node.label} & \code{edge.width}\\ \code{node.pos} & \code{font} & \code{edge.lty}\\ \code{x.lim} & \code{tip.color}\\ \code{y.lim} & \code{cex}\\ \code{direction} & \code{adj}\\ \code{no.margin} & \code{underscore}\\ \code{root.edge} & \code{srt}\\ \code{rotate.tree} & \code{lab4ut}\\ \code{open.angle} & \code{label.offset}\\ \code{node.depth} & \code{align.tip.label}\\ \bottomrule \end{tabular} \end{center} \subsection{Connecting Data to the Tips} It is common that some data are associated with the tips of a tree: body mass, population, treatment, \dots\ The options \code{font}, \code{tip.color}, and \code{cex} make possible to show this kind of information by changing the font (normal, bold, italics, or bold-italics), the colour, or the size of the tip labels, or any combination of these. These three arguments work in the usual \R\ way: they can a vector of any length whose values are eventually recycled if this length is less than the number of tips. This makes possible to change all tips if a single value is given. For instance, consider the small primate tree where we want to show the geographic distributions stored in a factor: <<>>= geo <- factor(c("Africa", "World", "Africa")) @ \noindent We can define a color for each region and use the above factor as a numeric index vector and pass it to \code{tip.color}: \begin{center} \setkeys{Gin}{width=.5\textwidth} <>= (mycol <- c("blue", "red")[geo]) plot(mytr, tip.color = mycol) @ \end{center} The values must be in the same order than in the vector of tip labels, here \code{mytr\$tip.label}. Reordering can be done in the usual \R\ way (e.g., with \code{names} or with \code{row.names} if the data are in a data frame). This can be combined with another argument, for instance to show (relative) body size: \begin{center} \setkeys{Gin}{width=.5\textwidth} <>= par(xpd = TRUE) plot(mytr, tip.color = mycol, cex = c(1, 1, 1.5)) @ \end{center} The function \code{def} gives another way to define the above arguments given a vector of labels (\code{x}): <<>>= args(def) @ \noindent The `\code{...}' are arguments separated by commas of the form \code{\textsl{