/archive/source.archive/bm.and.ou/trait.rjmcmc.09132010a.R

http://github.com/eastman/auteur · R · 604 lines · 506 code · 58 blank · 40 comment · 119 complexity · 29f6a773a7d5b89b79c35b1ddb254c9f MD5 · raw file

  1. ## Written by LJ HARMON & AH: 2008
  2. ## Modified by JM EASTMAN: 09.2010
  3. rjMCMC.trait<-function (phy, data, ngen=1000, sampleFreq=100, model=c("OU","BM"), probAlpha=0.05, probRegimes=0.10, probMergeSplit=0.05, probRoot=0.1, heat=1, fileBase="result")
  4. {
  5. if(length(model)>1)stop(paste("Please specify either ", sQuote("OU"), " or ", sQuote("BM")))
  6. require(ouch)
  7. require(geiger)
  8. ### prepare objects for rjMCMC
  9. currModel <- model # initialize family of models explored
  10. dataList <- prepare.ouchdata(phy, data) # check tree and data; convert into S4
  11. ape.tre <- currTree <- dataList$ape.tre # S3 phylogeny
  12. orig.dat <- dataList$orig.dat # S3 data
  13. ouch.tre <- dataList$ouch.tre # S4 OUCH phylogeny
  14. ouch.dat <- dataList$ouch.dat # S4 OUCH data
  15. nn <- Ntip(ape.tre) # max number of rates (one per branch)
  16. currRates.c <- rep(1,nn) # initialize array for recording which branch belongs to which rate category
  17. currRates <- rep(fitContinuous(ape.tre,orig.dat)[[1]]$beta,nn) # initialize array for rate estimates branchwise
  18. currRoot <- mean(orig.dat)
  19. delta.rates <- rep(0,nn)
  20. currAlpha <- 0.001 # initialize alpha
  21. currTheta <- 0 # initialize trait optima under OU
  22. delta.theta <- rep(0,nn) # initialize local 'rates'
  23. currRegimes <- rep(1,nrow(ouch.dat)) # initial set of selective regimes
  24. nRateProp = 0 # proposal count: update rate parameter(s)
  25. nRcatProp = 0 # proposal count: update rate categories
  26. nRootProp = 0
  27. nAlphaProp = 0 # proposal count: update alpha parameter
  28. nRegimesProp = 0 # proposal count: update selective regimes
  29. nThetaProp = 0
  30. nRateOK = 0 # proposal count: successful rate changes
  31. nRcatOK = 0 # proposal count: successful rate categories updates
  32. nRootOK = 0
  33. nAlphaOK = 0 # proposal count: successful alpha updates
  34. nRegimesOK = 0 # proposal count: successful regime updates
  35. nThetaOK = 0
  36. l <- array(dim=c(ngen,4)) # array for storing output: size is number of MCMC generations
  37. l[] <- NA # initialize array for storing lnLs
  38. cOK=c( # list of proposal tallies
  39. nRateOK,
  40. nRcatOK,
  41. nRootOK,
  42. nAlphaOK,
  43. nRegimesOK,
  44. nThetaOK
  45. )
  46. errorLog=file(paste(getwd(),paste(currModel, "rjTraitErrors.log",sep="."),sep="/"),open='w+')
  47. generate.error.message(i=NULL, modCurr=NULL, modNew=NULL, lnR=NULL, errorLog=errorLog, init=TRUE)
  48. runLog=file(paste(getwd(),paste(currModel, "rjTrait.log",sep="."),sep="/"),open='w+')
  49. generate.log(bundled.parms=NULL, currModel, file=runLog, init=TRUE)
  50. ### Begin rjMCMC
  51. for (i in 1:ngen) {
  52. error.flag=FALSE
  53. lnLikelihoodRatio <- lnProposalRatio <- lnPriorRatio <- 0
  54. startparms=list(rates=currRates, cats=currRates.c, root=currRoot, alph=currAlpha, reg=currRegimes, theta=currTheta)
  55. ## OU IMPLEMENTATION ##
  56. if(currModel=="OU") {
  57. if (runif(1) < (2 * probMergeSplit)) {
  58. if(runif(1)<0.5) { # adjust regimes
  59. nr=split.or.merge(currTheta, currRegimes, decide.s.or.m(currRegimes, regimes=TRUE)->s.m, regimes=TRUE)
  60. newRegimes=nr$new.categories
  61. newTheta=nr$new.values
  62. newRates=currRates
  63. newRates.c=currRates.c
  64. nRegimesProp=nRegimesProp+1
  65. } else { # adjust rate categories
  66. nr=split.or.merge(currRates, currRates.c, decide.s.or.m(currRates.c)->s.m)
  67. newRates=nr$new.values
  68. newRates.c=nr$new.categories
  69. newRegimes=currRegimes
  70. newTheta=currTheta
  71. nRcatProp=nRcatProp+1
  72. }
  73. newAlpha=currAlpha
  74. lnProposalRatio=nr$lnl.prop
  75. lnPriorRatio=nr$lnl.prior
  76. } else { # neither split nor merge
  77. if(runif(1)<probAlpha) { # adjust alpha
  78. newAlpha=adjust.rates(currAlpha)
  79. newRates=currRates
  80. newRates.c=currRates.c
  81. newRegimes=currRegimes
  82. newTheta=currTheta
  83. nAlphaProp=nAlphaProp+1
  84. } else {
  85. if(runif(1)<0.5) {# adjust rates
  86. newRates=adjust.rates(currRates)
  87. newRates.c=fix.categories(newRates)
  88. newAlpha=currAlpha
  89. newRegimes=currRegimes
  90. newTheta=currTheta
  91. nRateProp=nRateProp+1
  92. } else { # adjust theta
  93. newTheta=sapply(currTheta, adjust.value)
  94. newAlpha=currAlpha
  95. newRates=currRates
  96. newRates.c=currRates.c
  97. newRegimes=currRegimes
  98. nThetaProp=nThetaProp+1
  99. }
  100. }
  101. }
  102. currTree=apply.BMM.to.apetree(ape.tre, currRates)
  103. newTree=apply.BMM.to.apetree(ape.tre, newRates)
  104. modCurr=new.ou.lik.fn(currRates, currAlpha, currRegimes, currTheta, currTree, ouch.dat)
  105. modNew=try(new.ou.lik.fn(newRates, newAlpha, newRegimes, newTheta, newTree, ouch.dat),silent=TRUE)
  106. } else if(currModel=="BM"){
  107. ## BM IMPLEMENTATION ##
  108. if (runif(1) < (2 * probMergeSplit)) {
  109. nr=split.or.merge(currRates, currRates.c, decide.s.or.m(currRates.c)->s.m)
  110. newRates=nr$new.values
  111. newRates.c=nr$new.categories
  112. newRoot=currRoot
  113. nRcatProp=nRcatProp+1
  114. lnProposalRatio=nr$lnl.prop
  115. lnPriorRatio=nr$lnl.prior
  116. } else {
  117. if(runif(1)<probRoot) { # adjust root
  118. newRoot=adjust.value(currRoot)
  119. newRates=currRates
  120. newRates.c=currRates.c
  121. nRootProp=nRootProp+1
  122. } else { # adjust rates
  123. newRates=adjust.rates(currRates)
  124. newRates.c=fix.categories(newRates)
  125. newRoot=currRoot
  126. nRateProp=nRateProp+1
  127. }
  128. }
  129. currTree=apply.BMM.to.apetree(ape.tre, currRates)
  130. newTree=apply.BMM.to.apetree(ape.tre, newRates)
  131. modCurr=new.bm.lik.fn(currRates, currRoot, currTree, ouch.dat)
  132. modNew=try(new.bm.lik.fn(newRates, newRoot, newTree, ouch.dat),silent=TRUE)
  133. }
  134. if(!inherits(modNew, "try-error")) {
  135. lnLikelihoodRatio = modNew$lnL - modCurr$lnL
  136. } else {
  137. lnLikelihoodRatio = -Inf
  138. modNew$lnL=NaN
  139. }
  140. r=assess.lnR((heat * lnLikelihoodRatio + heat * lnPriorRatio + lnProposalRatio)->lnR)
  141. if (runif(1) <= r$r) { # adopt proposal
  142. if(currModel=="OU") {
  143. currAlpha <- newAlpha
  144. currRegimes <- newRegimes
  145. currTheta <- newTheta
  146. } else {
  147. currRoot <- newRoot
  148. }
  149. currRates <- newRates
  150. currRates.c <- newRates.c
  151. curr.lnL <- modNew$lnL
  152. currTree <- newTree
  153. } else { # deny proposal
  154. curr.lnL <- modCurr$lnL
  155. }
  156. if(r$error) generate.error.message(i, modCurr, modNew, lnR, errorLog)
  157. l[i,]<-c(curr.lnL, max(currRates.c), currAlpha, max(currRegimes))
  158. endparms=list(rates=currRates, cats=currRates.c, root=currRoot, alph=currAlpha, reg=currRegimes, theta=currTheta)
  159. cOK=tally.mcmc.parms(startparms, endparms, cOK)
  160. bundled.parms=list(gen=i, mrate=exp(mean(log(currRates))), cats=max(currRates.c), root=currRoot, alpha=currAlpha, reg=max(currRegimes), theta=mean(currTheta), lnL=curr.lnL)
  161. if(i%%sampleFreq==0) generate.log(bundled.parms, currModel, file=runLog)
  162. }
  163. # End rjMCMC
  164. close(errorLog)
  165. close(runLog)
  166. summarize.run(cOK, (cProp<-c(nRateProp, nRcatProp, nRootProp, nAlphaProp, nRegimesProp, nThetaProp)), currModel)
  167. if(currModel=="BM") {
  168. return(list(r.cat=l[,2], lnL=l[,1]))
  169. } else {
  170. return(list(r.cat=l[,2], r.alpha=l[,3], r.regimes=l[,4], lnL=l[,1]))
  171. }
  172. }
  173. ## AUXILIARY FUNCTIONS
  174. new.ou.lik.fn <- function(rates, alpha, regimes, theta, ape.tre, ouch.dat) { # from OUCH 2.7-1:::hansen()
  175. # mod 09.13.2010
  176. ouch.tre=ape2ouch(ape.tre, scale=FALSE)
  177. ouch.dat$regimes=as.factor(regimes)
  178. alpha.ouch=as.matrix(sqrt(alpha))
  179. beta=ouch:::regime.spec(ouch.tre, ouch.dat['regimes'])
  180. dat=do.call(c,lapply(ouch.dat['trait'],function(y)y[ouch.tre@term]))
  181. n <- length(dat)
  182. otree.df=as(ouch.tre,"data.frame")
  183. ordering=otree.df[n:nrow(otree.df),'labels']
  184. ev <- eigen(alpha.ouch,symmetric=TRUE)
  185. w <- .Call(ouch:::ouch_weights,object=ouch.tre,lambda=ev$values,S=ev$vectors,beta=beta)
  186. v <- geiger:::ouMatrix(vcv.phylo(ape.tre), alpha)
  187. v.match <- match(row.names(v),ordering)
  188. v <- v[v.match,v.match]
  189. ## GEIGER call does not assume ultrametricity (and thus allows different 'rates' under BM)
  190. # -old- v <- .Call(ouch:::ouch_covar,object=ouch.tre,lambda=ev$values,S=ev$vectors,sigma.sq=1)
  191. y <- matrix(theta,ncol=1)
  192. e <- w%*%y-dat
  193. dim(y) <- dim(y)[1]
  194. dim(e) <- n
  195. q <- e%*%solve(v,e)
  196. det.v <- determinant(v,logarithm=TRUE)
  197. if (det.v$sign!=1)stop("ou.lik.fn error: non-positive determinant",call.=FALSE)
  198. dev <- n*log(2*pi)+as.numeric(det.v$modulus)+q[1,1]
  199. list(
  200. theta=theta,
  201. weight=w,
  202. vcov=v,
  203. resids=e,
  204. lnL=-0.5*dev
  205. )
  206. }
  207. new.bm.lik.fn <- function(rates, root, ape.tre, ouch.dat) { # from OUCH 2.7-1:::brown()
  208. # mod 09.13.2010
  209. tree=ape2ouch(ape.tre, scale=FALSE)
  210. data=ouch.dat['trait']
  211. if (!is(tree, "ouchtree")) {stop(sQuote("tree"), " must be an object of class ", sQuote("ouchtree"))}
  212. if (is.data.frame(data)) {
  213. nm <- rownames(data)
  214. data <- lapply(as.list(data), function(x) {names(x) <- nm; x})
  215. }
  216. if (is.numeric(data)) {
  217. nm <- deparse(substitute(data))[1]
  218. data <- list(data)
  219. names(data) <- nm
  220. }
  221. if (is.list(data)) {
  222. if (any(sapply(data, class) != "numeric") || any(sapply(data, length) != tree@nnodes)) {stop(sQuote("data"), " vector(s) must be numeric, with one entry per node of the tree")}
  223. if (any(sapply(data, function(x) (is.null(names(x))) || (!setequal(names(x), tree@nodes))))) {stop(sQuote("data"), " vector names (or data-frame row names) must match node names of ", sQuote("tree"))}
  224. for (xx in data) {
  225. no.dats <- which(is.na(xx[tree@nodes[tree@term]]))
  226. if (length(no.dats) > 0) {stop("missing data on terminal node(s): ", paste(tree@nodes[tree@term[no.dats]], collapse = ","))}
  227. }
  228. }
  229. nterm <- tree@nterm
  230. nchar <- length(data)
  231. if (is.null(names(data))) names(data) <- paste("char", 1:nchar, sep = "")
  232. dat.tmp <- lapply(data, function(x) x[tree@nodes])
  233. dat <- lapply(dat.tmp, function(y) y[tree@term])
  234. dat <- dat[[1]]
  235. nterm <- Ntip(ape.tre)
  236. nchar <- 1
  237. w <- matrix(data=1,nrow=nterm,ncol=1)
  238. b <- tree@branch.times
  239. y <- matrix(root)
  240. e <- w%*%y-dat
  241. q <- t(e)%*%solve(b,e)
  242. v <- q/nterm
  243. dev <- nchar*nterm*(1+log(2*pi))+nchar*log(det(b))+nterm*log(det(v))
  244. list(
  245. root=root,
  246. lnL = -0.5*dev
  247. )
  248. }
  249. rtpois<-function(N, lambda, k){
  250. p=ppois(k, lambda, lower.tail=FALSE)
  251. out=qpois(runif(N, min=0, max=1-p), lambda)
  252. out
  253. }
  254. get.descendants.of.node <- function(node, phy) {
  255. descendants.of.node <- function(node, phy) {
  256. current.node=node[node%in%phy$edge[,1]]
  257. if (length(current.node)>0) {
  258. desc=c(sapply(current.node, function(x) {return(phy$edge[which(phy$edge[,1]==x),2])}))
  259. write(desc,file="TEMP",append=TRUE)
  260. descendants.of.node(desc,phy)
  261. }
  262. }
  263. descendants.of.node(node, phy)
  264. if(file.exists("TEMP")) {
  265. out=unlist(strsplit(readLines("TEMP")," "))
  266. unlink("TEMP")
  267. return(sort(unique(as.numeric(out))))
  268. }
  269. }
  270. get.ancestor.of.node<-function(node, phy) {
  271. anc=phy$edge[which(phy$edge[,2]==node),1]
  272. anc
  273. }
  274. assess.lnR <- function(lnR) {
  275. if(is.na(lnR) || abs(lnR)==Inf) {
  276. error=TRUE
  277. r=0
  278. } else {
  279. if(lnR < -100) {
  280. r=0
  281. } else if(lnR > 0) {
  282. r=1
  283. } else {
  284. r=exp(lnR)
  285. }
  286. error=FALSE
  287. }
  288. return(list(r=r, error=error))
  289. }
  290. decide.s.or.m <- function(categories, regimes=FALSE) {
  291. if (max(categories) == 1) {
  292. return("split")
  293. }
  294. else if (max(categories) == length(categories)) {
  295. return("merge")
  296. }
  297. # else if (regimes && (((length(categories)+1)/2)==max(categories))) {
  298. # limits number of selective regimes to number of tips
  299. # return("merge")
  300. # }
  301. else if (runif(1) < 0.5) {
  302. return("split")
  303. }
  304. else return("merge")
  305. }
  306. split.or.merge <- function(values, categories, task=c("split","merge"), regimes=FALSE)
  307. {
  308. # updated to adjust for an additional theta when regimes are split (or one fewer theta if regimes are merged)
  309. # implement Drummon and Suchard 2010 method, adapting local relaxed clocks for local theta and BMMrates - draw changes in BMMrates from truncated Poisson
  310. cc=categories
  311. if(regimes) vv=values[cc] else vv=values
  312. new.vv=vv
  313. new.cc=cc
  314. nn=length(vv)
  315. if(task=="merge") {
  316. ncat <- max(cc)
  317. m.cc <- sample(1:ncat)[1:2] # grab two categories
  318. new.cc[new.cc == m.cc[1]] <- m.cc[2] # merge selected categories
  319. new.cc <- fix.categories(new.cc)
  320. or1 <- vv[cc == m.cc[1]][1] # value affected
  321. or2 <- vv[cc == m.cc[2]][1] # value affected
  322. n1 <- sum(cc == m.cc[1]) # no. entries affected
  323. n2 <- sum(cc == m.cc[2]) # no. entries affected
  324. nr <- (n1 * or1 + n2 * or2)/(n1 + n2) # find new value for merged category
  325. new.vv[cc == m.cc[1] | cc == m.cc[2]] <- nr # new value assigned to merged classes
  326. numSplittableBeforeMerge <- sum(table(cc) > 1)
  327. numSplittableAfterMerge <- sum(table(new.cc) > 1)
  328. if (max(cc) == nn) {
  329. probMerge = 1
  330. } else {
  331. probMerge = 0.5
  332. }
  333. if (max(new.cc) == 1) {
  334. probSplit = 1
  335. } else {
  336. probSplit = 0.5
  337. }
  338. factor = probSplit/probMerge
  339. # AS WRITTEN by LJ HARMON
  340. lnProposalRatio = log(factor) + log(nn) + log(ncat) - log(numSplittableAfterMerge) - log(2^(n1 + n2) - 2) - log(nr/mean(vv)) - log(n1 + n2)
  341. lnPriorRatio = log(Stirling2(nn, ncat)) - log(Stirling2(nn, ncat - 1))
  342. # lnHastings = log((2N-2-K+1)/K) # where N is tips, K is number of local parms in tree
  343. }
  344. if(task=="split") {
  345. ncat <- max(cc)
  346. while (1) { # find non-unique category
  347. rcat <- round(runif(1) * ncat + 0.5) # class to split
  348. nc <- sum(cc == rcat)
  349. if (nc > 1)
  350. break
  351. }
  352. while (1) { #
  353. new <- round(runif(nc) * 2 + 0.5)
  354. if (length(table(new)) == 2)
  355. break
  356. }
  357. new.cc[cc == rcat][new == 2] <- ncat + 1
  358. or <- vv[cc == rcat][1] # old rate
  359. n1 <- sum(new == 1) # no. elements affected
  360. n2 <- sum(new == 2) # no. elements affected
  361. lims <- c(-0.5 * n1 * or, 0.5 * n2 * or)
  362. lims <- lims[order(lims)]
  363. u <- runif(1, min = lims[1], max = lims[2])
  364. nr1 <- or + u/n1 # new rate 1
  365. nr2 <- or - u/n2 # new rate 2
  366. new.vv[new.cc == rcat] <- nr1 # assign new rate 1
  367. new.vv[new.cc == ncat + 1] <- nr2 # assign new rate 2
  368. new.cc <- fix.categories(new.cc)
  369. numSplittableBeforeSplit <- sum(table(cc) > 1)
  370. numSplittableAfterSplit <- sum(table(new.cc) > 1)
  371. if (max(cc) == 1) {
  372. probSplit = 1
  373. } else {
  374. probSplit = 0.5
  375. }
  376. if (max(new.cc) == nn) {
  377. probMerge = 1
  378. } else {
  379. probMerge = 0.5
  380. }
  381. factor = probMerge/probSplit
  382. # AS WRITTEN by LJ HARMON
  383. lnProposalRatio = log(factor) + log(numSplittableBeforeSplit) + log(2^(n1 + n2) - 2) + log(or/mean(vv)) + log(n1 + n2) - log(nn) - log(ncat + 1)
  384. lnPriorRatio = log(Stirling2(nn, ncat)) - log(Stirling2(nn, ncat + 1))
  385. # lnHastings=log((K+1)/(2N-2-K)) # where N is tips, K is number of local parms in tree
  386. }
  387. if(regimes) new.vv=unique(new.vv[order(new.cc)])
  388. list(new.values=new.vv, new.categories=new.cc, lnl.prop=lnProposalRatio, lnl.prior=lnPriorRatio)
  389. }
  390. fix.categories <- function(x)
  391. {
  392. f<-factor(x)
  393. n<-nlevels(f)
  394. o<-numeric(n)
  395. for(i in 1:n) o[i]<-which(f==levels(f)[i])[1]
  396. nf<-ordered(f, levels(f)[order(o)])
  397. nx<-as.numeric(nf)
  398. nx
  399. }
  400. choose.one <- function(bit.vector)
  401. {
  402. bb=bit.vector
  403. s=sample(1:length(bb),1)
  404. bb[s]=1-bb[s]
  405. bb
  406. }
  407. fix.heritable.values<-function(bit.vector, values, phy) {
  408. # assuming most recently changed value in correspondence with bit.vector has been changed on entry
  409. bb=bit.vector
  410. vv=values
  411. names(vv)<-names(bb)<-phy$edge[,2]
  412. new.bb=choose.one(bb)
  413. # new.vv=vv (do adjust value on the element that was just changed (if 0->1)
  414. shifts=sort(as.numeric(names(which(bb>0))))
  415. desc=lapply(shifts, function(x)get.descendants.of.node(x,phy))
  416. # fix if descendants of one set are included in another
  417. new.vv=match()
  418. }
  419. assign.edgelengths<-function(ouchtree) {
  420. ouchtree=as(ouchtree, "data.frame")
  421. ouchtree$edges=NA
  422. for(i in 2:nrow(ouchtree)) {
  423. ouchtree$edges[i]=ouchtree$times[i]-(ouchtree[match(ouchtree[i,'ancestors'], ouchtree[,'nodes']),'times'])
  424. }
  425. ouchtree$edges[1]=0
  426. ouchtree
  427. }
  428. apply.BMM.to.ouchtree<-function(ouchtree, rates) {
  429. ## FIXME: ensure that the tree maintains structure before and after this function is called
  430. ## VERY SLOW
  431. ## NOT CURRENTLY implemented
  432. ot=as(ouchtree, "data.frame")
  433. ot=assign.edgelengths(ot)
  434. ot$edges.new=c(0, rates)*ot$edges
  435. ot=ot[order(ot$times),]
  436. ot$times.new=NA
  437. ot$times.new[1]=0
  438. for(i in 2:nrow(ot)) {
  439. ot$times.new[i]=ot[match(ot[i,'ancestors'], ot[,'nodes']),'times.new']+ot[i,'edges.new']
  440. }
  441. ot$times=ot$times.new
  442. return(with(ot, ouchtree(nodes=nodes, ancestors=ancestors, times=times, labels=labels)))
  443. }
  444. apply.BMM.to.apetree<-function(apetree, rates) {
  445. ## FASTER than apply.BMM.to.ouchtree
  446. apetree$edge.length=apetree$edge.length*rates
  447. return(apetree)
  448. }
  449. adjust.value <- function(value) {
  450. rr=value
  451. rch <- runif(1, min = -0.5, max = 0.5)
  452. rr <- rr + rch
  453. rr
  454. }
  455. adjust.rates <- function(values) {
  456. vv=values
  457. ncat <- max(fix.categories(vv)->cc)
  458. rcat <- round(runif(1) * (ncat) + 0.5)
  459. r <- log(vv[cc == rcat][1])
  460. rch <- runif(1, min = -2, max = 2)
  461. nr <- r + rch
  462. vv[cc == rcat] <- exp(nr)
  463. vv
  464. }
  465. prepare.ouchdata <- function(phy, data) {
  466. td <- treedata(phy, data, sort = T)
  467. ouch.tre <- ape2ouch(td$phy->ape.tre, scale=FALSE)
  468. ouch.dat=data.frame(as.numeric(ouch.tre@nodes), as.character(ouch.tre@nodelabels))
  469. names(ouch.dat)=c("nodes","labels")
  470. ouch.dat[ouch.dat[,2]=="",2]=NA
  471. ouch.dat$trait=NA
  472. mM=match(ouch.dat$labels,names(data))
  473. for(i in 1:nrow(ouch.dat)){
  474. if(!is.na(mM[i])){
  475. ouch.dat$trait[i]=data[mM[i]]
  476. }
  477. }
  478. return(list(ouch.tre=ouch.tre, ouch.dat=ouch.dat, ape.tre=td$phy, orig.dat=td$data[,1]))
  479. }
  480. summarize.run<-function(cOK, cProp, currModel) {
  481. names(cProp)<-names(cOK)<-c("rates", "rcats", "root", "alpha", "sRegimes", "theta")
  482. names(cProp)=paste("prop.",names(cProp),sep="")
  483. names(cOK)=paste("okay.",names(cOK),sep="")
  484. cat("\n")
  485. if(currModel=="BM") {
  486. print(cProp[1:3])
  487. print(cOK[1:3])
  488. } else {
  489. print(cProp[c(1,2,4,5,6)])
  490. print(cOK[c(1,2,4,5,6)])
  491. }
  492. }
  493. generate.log<-function(bundled.parms, currModel, file, init=FALSE) {
  494. # bundled.parms=list(gen=i, mrate=mean(currRates), cats=max(currRates.c), root=currRoot, alpha=currAlpha, reg=max(currRegimes), theta=mean(currTheta), lnL=curr.lnL)
  495. res=bundled.parms
  496. if(init) {
  497. if(currModel=="BM") msg=paste("gen", "model", "mean.rate", "rates", "root", "lnL", sep="\t") else msg=paste("gen", "model", "mean.rate", "rates", "alpha", "regimes", "mean.theta", "lnL", sep="\t")
  498. } else {
  499. if(currModel=="BM") {
  500. msg<-paste(res$gen, sQuote(currModel), sprintf("%.3f", res$mrate), res$cats, sprintf("%.3f", res$root), sprintf("%.3f", res$lnL),sep="\t")
  501. } else {
  502. msg<-paste(res$gen, sQuote(currModel), sprintf("%.3f", res$mrate), res$cats, sprintf("%.4f", res$alpha), res$reg, sprintf("%.3f", res$theta), sprintf("%.3f", res$lnL),sep="\t")
  503. }
  504. }
  505. write(msg, file=file, append=TRUE)
  506. }
  507. generate.error.message<-function(i, modCurr, modNew, lnR, errorLog, init=FALSE) {
  508. if(init) {
  509. initmsg = write(paste("gen", "curr.lnL", "new.lnL", "lnR", sep="\t"), file=errorLog)
  510. } else {
  511. write(paste(i, sprintf("%.3f", modCurr$lnL), sprintf("%.3f", modNew$lnL), sprintf("%.3f", lnR), sep="\t"), file=errorLog)
  512. }
  513. }
  514. tally.mcmc.parms<-function(startparms, endparms, cOK) {
  515. index=array(dim=(length(startparms)-1))
  516. for(i in 1:(length(startparms)-1)) {
  517. index[i]=all(startparms[[i]]==endparms[[i]])
  518. }
  519. if(!all(index)) {
  520. cOK[max(which(index==FALSE))]=cOK[max(which(index==FALSE))]+1
  521. }
  522. if(length(startparms$theta) == length(endparms$theta)) {
  523. if(!all(sort(startparms$theta)==sort(endparms$theta))) {
  524. cOK[6]=cOK[6]+1
  525. }
  526. }
  527. cOK
  528. }
  529. Stirling2 <- function(n,m)
  530. {
  531. ## Purpose: Stirling Numbers of the 2-nd kind
  532. ## S^{(m)}_n = number of ways of partitioning a set of
  533. ## $n$ elements into $m$ non-empty subsets
  534. ## Author: Martin Maechler, Date: May 28 1992, 23:42
  535. ## ----------------------------------------------------------------
  536. ## Abramowitz/Stegun: 24,1,4 (p. 824-5 ; Table 24.4, p.835)
  537. ## Closed Form : p.824 "C."
  538. ## ----------------------------------------------------------------
  539. if (0 > m || m > n) stop("'m' must be in 0..n !")
  540. k <- 0:m
  541. sig <- rep(c(1,-1)*(-1)^m, length= m+1)# 1 for m=0; -1 1 (m=1)
  542. ## The following gives rounding errors for (25,5) :
  543. ## r <- sum( sig * k^n /(gamma(k+1)*gamma(m+1-k)) )
  544. ga <- gamma(k+1)
  545. round(sum( sig * k^n /(ga * rev(ga))))
  546. }