├── R ├── bayou-models.R ├── bayou-deprecated.R ├── RcppExports.R ├── bayou-package.R ├── teaching-functions.R ├── bayou-simulation.r ├── conversion-utilities.R ├── probability.R ├── bayou-steppingstone.R ├── bayou-prior.R ├── bayou-weight_matrix.R └── bayou-custommodel-input.R ├── src ├── Makevars ├── RcppExports.cpp ├── weightmatrix.cpp ├── threepoint.cpp └── branches.cpp ├── figure ├── unnamed-chunk-10.png ├── unnamed-chunk-13.png ├── unnamed-chunk-15.png ├── unnamed-chunk-16.png ├── unnamed-chunk-20.png ├── unnamed-chunk-22.png ├── unnamed-chunk-23.png ├── unnamed-chunk-24.png ├── unnamed-chunk-3.png ├── unnamed-chunk-33.png ├── unnamed-chunk-36.png ├── unnamed-chunk-37.png ├── unnamed-chunk-38.png ├── unnamed-chunk-4.png ├── unnamed-chunk-81.png ├── unnamed-chunk-82.png ├── unnamed-chunk-9.png ├── unnamed-chunk-121.png ├── unnamed-chunk-122.png ├── unnamed-chunk-123.png ├── unnamed-chunk-271.png ├── unnamed-chunk-272.png ├── unnamed-chunk-273.png ├── unnamed-chunk-274.png ├── unnamed-chunk-291.png ├── unnamed-chunk-292.png ├── unnamed-chunk-351.png ├── unnamed-chunk-352.png ├── unnamed-chunk-391.png ├── unnamed-chunk-3910.png ├── unnamed-chunk-3911.png ├── unnamed-chunk-3912.png ├── unnamed-chunk-3913.png ├── unnamed-chunk-3914.png ├── unnamed-chunk-3915.png ├── unnamed-chunk-3916.png ├── unnamed-chunk-392.png ├── unnamed-chunk-393.png ├── unnamed-chunk-394.png ├── unnamed-chunk-395.png ├── unnamed-chunk-396.png ├── unnamed-chunk-397.png ├── unnamed-chunk-398.png └── unnamed-chunk-399.png ├── .gitignore ├── inst └── tests │ ├── test-data_load.r │ ├── test-weight_matrix.r │ ├── test-prior.r │ └── test-likelihood.r ├── .Rbuildignore ├── man ├── print.ssMCMC.Rd ├── print.refFn.Rd ├── print.bayouFit.Rd ├── print.priorFn.Rd ├── plotBayoupars.Rd ├── model.OU.Rd ├── bayou-package.Rd ├── print.bayouMCMC.Rd ├── QG.sig2.Rd ├── OUwie2bayou.Rd ├── QG.alpha.Rd ├── plot.bayouMCMC.Rd ├── makeTransparent.Rd ├── set.burnin.Rd ├── OU.repar.Rd ├── summary.bayouMCMC.Rd ├── plot.ssMCMC.Rd ├── combine.chains.Rd ├── plotOUtreesim.Rd ├── bayou2OUwie.Rd ├── gelman.R.Rd ├── priorSim.Rd ├── dhalfcauchy.Rd ├── cdpois.Rd ├── regime.plot.Rd ├── bayou.lik.Rd ├── parmap.W.Rd ├── plotRegimes.Rd ├── dataSim.Rd ├── dloc.Rd ├── make.powerposteriorFn.Rd ├── Lposterior.Rd ├── pars2simmap.Rd ├── simmapW.Rd ├── pull.pars.Rd ├── identifyBranches.Rd ├── plotShiftSummaries.Rd ├── phenogram.density.Rd ├── load.bayou.Rd ├── OU.lik.Rd ├── shiftSummaries.Rd ├── OUphenogram.Rd ├── make.refFn.Rd ├── plotBranchHeatMap.Rd ├── bayou.checkModel.Rd ├── dsb.Rd ├── makeBayouModel.Rd ├── plotSimmap.mcmc.Rd ├── bayou-deprecated.Rd ├── bayou.makeMCMC.Rd └── make.prior.Rd ├── .travis.yml ├── DESCRIPTION ├── README.md ├── .github └── workflows │ ├── r.yml │ └── R-CMD-check.yaml └── NAMESPACE /R/bayou-models.R: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_LIBS = $(BLAS_LIBS) $(FLIBS) 2 | -------------------------------------------------------------------------------- /figure/unnamed-chunk-10.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-10.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-13.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-13.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-15.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-15.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-16.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-20.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-20.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-22.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-22.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-23.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-23.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-24.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-24.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-3.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-33.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-33.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-36.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-36.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-37.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-37.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-38.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-38.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-4.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-81.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-81.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-82.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-82.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-9.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-9.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-121.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-121.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-122.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-122.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-123.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-123.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-271.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-271.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-272.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-272.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-273.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-273.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-274.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-274.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-291.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-291.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-292.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-292.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-351.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-351.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-352.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-352.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-391.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-391.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-3910.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-3910.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-3911.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-3911.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-3912.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-3912.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-3913.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-3913.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-3914.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-3914.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-3915.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-3915.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-3916.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-3916.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-392.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-392.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-393.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-393.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-394.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-394.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-395.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-395.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-396.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-396.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-397.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-397.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-398.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-398.png -------------------------------------------------------------------------------- /figure/unnamed-chunk-399.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/uyedaj/bayou/HEAD/figure/unnamed-chunk-399.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.Rproj.user 2 | *.Rhistory 3 | *.RData 4 | Rprof.out 5 | src/*.o 6 | src/*.so 7 | src/*.dll 8 | .Rproj.user 9 | -------------------------------------------------------------------------------- /inst/tests/test-data_load.r: -------------------------------------------------------------------------------- 1 | #context("data can be loaded") 2 | testthat::test_that("data can be loaded", { 3 | library(bayou) 4 | data(chelonia, package="geiger") 5 | testthat::expect_equal(length(chelonia$phy$tip.label),226) 6 | }) 7 | -------------------------------------------------------------------------------- /R/bayou-deprecated.R: -------------------------------------------------------------------------------- 1 | ## bayou-deprecated.r 2 | #' @title Deprecated functions in package bayou. 3 | #' @description The functions listed below are deprecated and will be defunct in 4 | #' the near future. When possible, alternative functions with similar 5 | #' functionality are also mentioned. Help pages for deprecated functions are 6 | #' available at \code{help("-deprecated")}. 7 | #' @name bayou-deprecated 8 | #' @keywords internal 9 | NULL 10 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^\.gitignore$ 2 | ^bayOU_1.0\.Rproj$ 3 | ^BuildingBayOU\.R$ 4 | ^README\.md 5 | ^README\.html 6 | ^R/deprecated\.R 7 | ^.*\.Rproj$ 8 | ^\.Rproj\.user$ 9 | ^figure/.+$ 10 | ^figure$ 11 | ^tutorial\.md$ 12 | ^tutorial\.Rmd$ 13 | ^tutorial\.nb\.html$ 14 | ^\.travis\.yml 15 | ^\./R/birth-death\.R$ 16 | ^\.Rdata$ 17 | ^\.Rhistory$ 18 | ^\.travis\.yml$ 19 | ^R/\.Rhistory$ 20 | ^\.git$ 21 | ^tutorial_files$ 22 | ^tutorial_files/.+$ 23 | ^\.github$ 24 | -------------------------------------------------------------------------------- /man/print.ssMCMC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-steppingstone.R 3 | \name{print.ssMCMC} 4 | \alias{print.ssMCMC} 5 | \title{S3 method for printing ssMCMC objects} 6 | \usage{ 7 | \method{print}{ssMCMC}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An ssMCMC object} 11 | 12 | \item{...}{Optional arguments passed to print} 13 | } 14 | \description{ 15 | S3 method for printing ssMCMC objects 16 | } 17 | -------------------------------------------------------------------------------- /man/print.refFn.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-utilities.R 3 | \name{print.refFn} 4 | \alias{print.refFn} 5 | \title{S3 method for printing refFn objects} 6 | \usage{ 7 | \method{print}{refFn}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{A function of class 'refFn' produced by make.refFn} 11 | 12 | \item{...}{Additional arguments passed to \code{print}} 13 | } 14 | \description{ 15 | S3 method for printing refFn objects 16 | } 17 | -------------------------------------------------------------------------------- /man/print.bayouFit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{print.bayouFit} 4 | \alias{print.bayouFit} 5 | \title{S3 method for printing bayouFit objects} 6 | \usage{ 7 | \method{print}{bayouFit}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{A 'bayouFit' object produced by \code{bayou.mcmc}} 11 | 12 | \item{...}{Additional parameters passed to \code{print}} 13 | } 14 | \description{ 15 | S3 method for printing bayouFit objects 16 | } 17 | -------------------------------------------------------------------------------- /man/print.priorFn.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-utilities.R 3 | \name{print.priorFn} 4 | \alias{print.priorFn} 5 | \title{S3 method for printing priorFn objects} 6 | \usage{ 7 | \method{print}{priorFn}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{A function of class 'priorFn' produced by \code{make.prior}} 11 | 12 | \item{...}{Additional arguments passed to \code{print}} 13 | } 14 | \description{ 15 | S3 method for printing priorFn objects 16 | } 17 | -------------------------------------------------------------------------------- /man/plotBayoupars.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{plotBayoupars} 4 | \alias{plotBayoupars} 5 | \title{Plot parameter list as a simmap tree} 6 | \usage{ 7 | plotBayoupars(pars, tree, ...) 8 | } 9 | \arguments{ 10 | \item{pars}{A bayou formatted parameter list} 11 | 12 | \item{tree}{A tree of class 'phylo'} 13 | 14 | \item{...}{Additional arguments passed to plotRegimes} 15 | } 16 | \description{ 17 | Plot parameter list as a simmap tree 18 | } 19 | -------------------------------------------------------------------------------- /man/model.OU.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-likelihood.R 3 | \docType{data} 4 | \name{model.OU} 5 | \alias{model.OU} 6 | \title{Bayou Models} 7 | \format{ 8 | An object of class \code{list} of length 9. 9 | } 10 | \usage{ 11 | model.OU 12 | } 13 | \description{ 14 | Default bayou models. New models may be specified by providing a set of moves, control weights, 15 | tuning parameters, parameter names, RJ parameters and a likelihood function. 16 | } 17 | \keyword{datasets} 18 | -------------------------------------------------------------------------------- /man/bayou-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-package.R 3 | \name{bayou-package} 4 | \alias{bayou-package} 5 | \alias{bayou} 6 | \title{Bayesian Fitting of Ornstein-Uhlenbeck Models to Phylogenies} 7 | \description{ 8 | A package for inferring adaptive evolution to phylogenetic 9 | comparative data using Bayesian reversible-jump estimation of 10 | multi-optima Ornstein-Uhlenbeck models. 11 | } 12 | \details{ 13 | bayou-package 14 | } 15 | \author{ 16 | Josef C Uyeda 17 | } 18 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | C_threepoint <- function(dat) { 5 | .Call('_bayou_C_threepoint', PACKAGE = 'bayou', dat) 6 | } 7 | 8 | C_transf_branch_lengths <- function(dat, model, y, alpha) { 9 | .Call('_bayou_C_transf_branch_lengths', PACKAGE = 'bayou', dat, model, y, alpha) 10 | } 11 | 12 | C_weightmatrix <- function(dat, parameters) { 13 | .Call('_bayou_C_weightmatrix', PACKAGE = 'bayou', dat, parameters) 14 | } 15 | 16 | -------------------------------------------------------------------------------- /man/print.bayouMCMC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{print.bayouMCMC} 4 | \alias{print.bayouMCMC} 5 | \title{S3 method for printing bayouMCMC objects} 6 | \usage{ 7 | \method{print}{bayouMCMC}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{A mcmc chain of class 'bayouMCMC' produced by the function bayou.mcmc and loaded into the environment using load.bayou} 11 | 12 | \item{...}{Additional arguments} 13 | } 14 | \description{ 15 | S3 method for printing bayouMCMC objects 16 | } 17 | -------------------------------------------------------------------------------- /man/QG.sig2.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conversion-utilities.R 3 | \name{QG.sig2} 4 | \alias{QG.sig2} 5 | \title{Calculates the sigma^2 parameter from a QG model} 6 | \usage{ 7 | QG.sig2(pars) 8 | } 9 | \arguments{ 10 | \item{pars}{A bayou formatted parameter list with parameters h2 (heritability), P (phenotypic variance) and Ne (Effective population size)} 11 | } 12 | \value{ 13 | An sig2 value according to the equation \code{alpha = h2*P/(Ne)}. 14 | } 15 | \description{ 16 | Calculates the sigma^2 parameter from a QG model 17 | } 18 | -------------------------------------------------------------------------------- /man/OUwie2bayou.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conversion-utilities.R 3 | \name{OUwie2bayou} 4 | \alias{OUwie2bayou} 5 | \title{Converts OUwie data into bayou format} 6 | \usage{ 7 | OUwie2bayou(tree, trait) 8 | } 9 | \arguments{ 10 | \item{tree}{A phylogenetic tree with states at internal nodes as node labels} 11 | 12 | \item{trait}{A data frame in OUwie format} 13 | } 14 | \value{ 15 | A bayou formatted parameter list 16 | } 17 | \description{ 18 | \code{OUwie2bayou} Converts OUwie formatted data into a bayou formatted parameter list 19 | } 20 | -------------------------------------------------------------------------------- /man/QG.alpha.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conversion-utilities.R 3 | \name{QG.alpha} 4 | \alias{QG.alpha} 5 | \title{Calculates the alpha parameter from a QG model} 6 | \usage{ 7 | QG.alpha(pars) 8 | } 9 | \arguments{ 10 | \item{pars}{A bayou formatted parameter list with parameters h2 (heritability), P (phenotypic variance) and w2 (width of adaptive landscape)} 11 | } 12 | \value{ 13 | An alpha value according to the equation \code{alpha = h2*P/(P+w2+P)}. 14 | } 15 | \description{ 16 | Calculates the alpha parameter from a QG model 17 | } 18 | -------------------------------------------------------------------------------- /man/plot.bayouMCMC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{plot.bayouMCMC} 4 | \alias{plot.bayouMCMC} 5 | \title{S3 method for plotting bayouMCMC objects} 6 | \usage{ 7 | \method{plot}{bayouMCMC}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{A mcmc chain of class 'bayouMCMC' produced by the function bayou.mcmc and loaded into the environment using load.bayou} 11 | 12 | \item{...}{Additional arguments passed to \code{plot.mcmc} from the \code{coda} package} 13 | } 14 | \description{ 15 | S3 method for plotting bayouMCMC objects 16 | } 17 | -------------------------------------------------------------------------------- /man/makeTransparent.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{makeTransparent} 4 | \alias{makeTransparent} 5 | \title{Make a color transparent (Taken from an answer on StackOverflow by Nick Sabbe)} 6 | \usage{ 7 | makeTransparent(someColor, alpha = 100) 8 | } 9 | \arguments{ 10 | \item{someColor}{A color, either a number, string or hexidecimal code} 11 | 12 | \item{alpha}{The alpha transparency. The maxColorValue is set to 255.} 13 | } 14 | \description{ 15 | Make a color transparent (Taken from an answer on StackOverflow by Nick Sabbe) 16 | } 17 | -------------------------------------------------------------------------------- /man/set.burnin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{set.burnin} 4 | \alias{set.burnin} 5 | \title{Set the burnin proportion for bayouMCMC objects} 6 | \usage{ 7 | set.burnin(chain, burnin = 0.3) 8 | } 9 | \arguments{ 10 | \item{chain}{A bayouMCMC chain or an ssMCMC chain} 11 | 12 | \item{burnin}{The burnin proportion of samples to be discarded from downstream analyses.} 13 | } 14 | \value{ 15 | A bayouMCMC chain or ssMCMC chain with burnin proportion stored in the attributes. 16 | } 17 | \description{ 18 | Set the burnin proportion for bayouMCMC objects 19 | } 20 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | cache: packages 5 | r_packages: 6 | - covr 7 | os: 8 | - linux 9 | - osx 10 | after_success: 11 | - test $TRAVIS_R_VERSION_STRING = 'release' && Rscript -e 'covr::codecov()' 12 | notifications: 13 | email: 14 | on_success: change 15 | on_failure: change 16 | osx_image: xcode11.4 17 | addons: 18 | apt: 19 | update: true 20 | sources: 21 | - sourceline: 'ppa:opencpu/imagemagick' 22 | - sourceline: 'ppa:ubuntugis/ppa' 23 | packages: 24 | - libmagick++-dev 25 | - liblapack-dev 26 | -------------------------------------------------------------------------------- /man/OU.repar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conversion-utilities.R 3 | \name{OU.repar} 4 | \alias{OU.repar} 5 | \title{Calculates the alpha and sigma^2 from a parameter list with supplied phylogenetic half-life and stationary variance} 6 | \usage{ 7 | OU.repar(pars) 8 | } 9 | \arguments{ 10 | \item{pars}{A bayou formatted parameter list with parameters halflife (phylogenetic halflife) and Vy (stationary variance)} 11 | } 12 | \value{ 13 | A list with values for alpha and sig2. 14 | } 15 | \description{ 16 | Calculates the alpha and sigma^2 from a parameter list with supplied phylogenetic half-life and stationary variance 17 | } 18 | -------------------------------------------------------------------------------- /man/summary.bayouMCMC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{summary.bayouMCMC} 4 | \alias{summary.bayouMCMC} 5 | \title{S3 method for summarizing bayouMCMC objects} 6 | \usage{ 7 | \method{summary}{bayouMCMC}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{A bayouMCMC object} 11 | 12 | \item{...}{Additional arguments passed to \code{print}} 13 | } 14 | \value{ 15 | An invisible list with two elements: \code{statistics} which provides 16 | summary statistics for a bayouMCMC chain, and \code{branch.posteriors} which summarizes 17 | branch specific data from a bayouMCMC chain. 18 | } 19 | \description{ 20 | S3 method for summarizing bayouMCMC objects 21 | } 22 | -------------------------------------------------------------------------------- /man/plot.ssMCMC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-steppingstone.R 3 | \name{plot.ssMCMC} 4 | \alias{plot.ssMCMC} 5 | \title{S3 method for plotting ssMCMC objects} 6 | \usage{ 7 | \method{plot}{ssMCMC}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An 'ssMCMC' object} 11 | 12 | \item{...}{Additional arguments passed to \code{plot}} 13 | } 14 | \description{ 15 | S3 method for plotting ssMCMC objects 16 | } 17 | \details{ 18 | Produces 4 plots. The first 3 plot the prior, reference function and likelihood. Different colors 19 | indicate different power posteriors for each. These chains should appear to be well mixed. The final plot 20 | shows the sum of the marginal likelihood across each of the steps in the stepping stone algorithm. 21 | } 22 | -------------------------------------------------------------------------------- /inst/tests/test-weight_matrix.r: -------------------------------------------------------------------------------- 1 | #context("weight matrix can be calculated") 2 | testthat::test_that("weight matrix can be calculated", { 3 | library(bayou) 4 | data(chelonia, package="geiger") 5 | tree <- chelonia$phy 6 | dat <- chelonia$dat 7 | cache <- bayou:::.prepare.ou.univariate(tree, dat) 8 | pars <- list(alpha=0.01, sig2=1, k=3, theta=c(3,4,5), ntheta=3, sb=c(411, 400, 47), loc=c(25, 17, 33), t2=c(2,3,3)) 9 | TotExp <- exp(-cache$height*pars$alpha) 10 | stree <- pars2simmap(pars, tree) 11 | sW <- simmapW(stree$tree, pars) 12 | testthat::expect_equal(apply(sW, 1, sum), rep(1,226)) 13 | bW <- bayou:::C_weightmatrix(cache, pars)$W 14 | testthat::expect_equal(bW, sW) 15 | testthat::expect_equal(apply(bW,2,sum), c(79.58365, 117.46516, 28.95119), tolerance=0.0001) 16 | }) 17 | -------------------------------------------------------------------------------- /man/combine.chains.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{combine.chains} 4 | \alias{combine.chains} 5 | \title{Combine mcmc chains} 6 | \usage{ 7 | combine.chains(chain.list, thin = 1, burnin.prop = 0) 8 | } 9 | \arguments{ 10 | \item{chain.list}{The first chain to be combined} 11 | 12 | \item{thin}{A number or vector specifying the thinning interval to be used. If a single value, 13 | then the same proportion will be applied to all chains.} 14 | 15 | \item{burnin.prop}{A number or vector giving the proportion of burnin from each chain to be 16 | discarded. If a single value, then the same proportion will be applied to all chains.} 17 | } 18 | \value{ 19 | A combined bayouMCMC chain 20 | } 21 | \description{ 22 | Combine mcmc chains 23 | } 24 | -------------------------------------------------------------------------------- /man/plotOUtreesim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/teaching-functions.R 3 | \name{plotOUtreesim} 4 | \alias{plotOUtreesim} 5 | \title{A function to visualize a multi-optimum OU process evolving on a phylogeny} 6 | \usage{ 7 | plotOUtreesim(pars, tree, ptsperunit = 100, pal = rainbow, aph = 255, lwd = 1) 8 | } 9 | \arguments{ 10 | \item{pars}{A bayou parameter list to simulate the OU process from} 11 | 12 | \item{tree}{A phylogenetic tree} 13 | 14 | \item{ptsperunit}{A number giving the number of points to simulate per unit time} 15 | 16 | \item{pal}{A color palette function} 17 | 18 | \item{aph}{The alpha value for transparency of the lines} 19 | 20 | \item{lwd}{The width of the lines} 21 | } 22 | \description{ 23 | A function to visualize a multi-optimum OU process evolving on a phylogeny 24 | } 25 | -------------------------------------------------------------------------------- /man/bayou2OUwie.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conversion-utilities.R 3 | \name{bayou2OUwie} 4 | \alias{bayou2OUwie} 5 | \title{Converts bayou data into OUwie format} 6 | \usage{ 7 | bayou2OUwie(pars, tree, dat) 8 | } 9 | \arguments{ 10 | \item{pars}{A list with parameter values specifying \code{sb} = the branches with shifts, 11 | \code{loc} = the location on branches where a shift occurs and \code{t2} = the optima to which 12 | descendants of that shift inherit} 13 | 14 | \item{tree}{A phylogenetic tree} 15 | 16 | \item{dat}{A vector of tip states} 17 | } 18 | \value{ 19 | A list with an OUwie formatted tree with mapped regimes and an OUwie formatted data table 20 | } 21 | \description{ 22 | \code{bayou2OUwie} Converts a bayou formatted parameter list into OUwie formatted tree and data table that can be analyzed in OUwie 23 | } 24 | -------------------------------------------------------------------------------- /man/gelman.R.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{gelman.R} 4 | \alias{gelman.R} 5 | \title{Calculate Gelman's R statistic} 6 | \usage{ 7 | gelman.R(parameter, chain1, chain2, freq = 20, start = 1, plot = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{parameter}{The name or number of the parameter to calculate the statistic on} 11 | 12 | \item{chain1}{The first bayouMCMC chain} 13 | 14 | \item{chain2}{The second bayouMCMC chain} 15 | 16 | \item{freq}{The interval between which the diagnostic is calculated} 17 | 18 | \item{start}{The first sample to calculate the diagnostic at} 19 | 20 | \item{plot}{A logical indicating whether the results should be plotted} 21 | 22 | \item{...}{Optional arguments passed to \code{gelman.diag(...)} from the \code{coda} package} 23 | } 24 | \description{ 25 | Calculate Gelman's R statistic 26 | } 27 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: bayou 2 | Type: Package 3 | Title: Bayesian Fitting of Ornstein-Uhlenbeck Models to Phylogenies 4 | Version: 2.3.0 5 | Date: 2024-06-28 6 | Author: Josef C. Uyeda, Jon Eastman and Luke Harmon 7 | Maintainer: Josef C. Uyeda 8 | Description: Tools for fitting and simulating multi-optima Ornstein-Uhlenbeck 9 | models to phylogenetic comparative data using Bayesian reversible-jump 10 | methods. 11 | License: GPL (>= 2) 12 | Depends: 13 | ape (>= 3.0-6), 14 | geiger(>= 2.0), 15 | R (>= 2.15.0), 16 | phytools, 17 | coda 18 | Imports: 19 | Rcpp (>= 0.10.3), 20 | MASS, 21 | mnormt, 22 | fitdistrplus, 23 | denstrip, 24 | assertthat, 25 | foreach, 26 | Matrix, 27 | graphics, 28 | grDevices, 29 | stats 30 | Suggests: 31 | doParallel, 32 | testthat 33 | LinkingTo: Rcpp, RcppArmadillo 34 | Encoding: UTF-8 35 | RoxygenNote: 7.3.1 36 | -------------------------------------------------------------------------------- /man/priorSim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-simulation.r 3 | \name{priorSim} 4 | \alias{priorSim} 5 | \title{Simulates parameters from bayou models} 6 | \usage{ 7 | priorSim(prior, tree, plot = TRUE, nsim = 1, shiftpars = "theta", ...) 8 | } 9 | \arguments{ 10 | \item{prior}{A prior function created by \code{bayou::make.prior}} 11 | 12 | \item{tree}{A tree of class 'phylo'} 13 | 14 | \item{plot}{A logical indicating whether the simulated parameters should be plotted} 15 | 16 | \item{nsim}{The number of parameter sets to be simulated} 17 | 18 | \item{shiftpars}{A vector of parameters that split upon a shift, default is "theta"} 19 | 20 | \item{...}{Parameters passed on to \code{plotSimmap(...)}} 21 | } 22 | \value{ 23 | A list of bayou parameter lists 24 | } 25 | \description{ 26 | \code{priorSim} Simulates parameters from the prior distribution specified by \code{make.prior} 27 | } 28 | -------------------------------------------------------------------------------- /man/dhalfcauchy.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/probability.R 3 | \name{dhalfcauchy} 4 | \alias{dhalfcauchy} 5 | \alias{phalfcauchy} 6 | \alias{qhalfcauchy} 7 | \alias{rhalfcauchy} 8 | \title{Half cauchy distribution taken from the R package LaplacesDemon (Hall, 2012).} 9 | \usage{ 10 | dhalfcauchy(x, scale = 25, log = FALSE) 11 | 12 | phalfcauchy(q, scale = 25) 13 | 14 | qhalfcauchy(p, scale = 25) 15 | 16 | rhalfcauchy(n, scale = 25) 17 | } 18 | \arguments{ 19 | \item{x}{A parameter value for which the density should be calculated} 20 | 21 | \item{scale}{The scale parameter of the half-Cauchy distributoin} 22 | 23 | \item{log}{A logical indicating whether the log density should be returned} 24 | 25 | \item{q}{A vector of quantiles} 26 | 27 | \item{p}{A vector of probabilities} 28 | 29 | \item{n}{The number of observations} 30 | } 31 | \description{ 32 | \code{dhalfcauchy} returns the probability density for a half-Cauchy distribution 33 | } 34 | -------------------------------------------------------------------------------- /man/cdpois.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/probability.R 3 | \name{cdpois} 4 | \alias{cdpois} 5 | \alias{rdpois} 6 | \title{Conditional Poisson distribution} 7 | \usage{ 8 | cdpois(k, lambda, kmax, log = TRUE) 9 | 10 | rdpois(n, lambda, kmax, ...) 11 | } 12 | \arguments{ 13 | \item{k}{random variable value} 14 | 15 | \item{lambda}{rate parameter of the Poisson distribution} 16 | 17 | \item{kmax}{maximum value of the conditional Poisson distribution} 18 | 19 | \item{log}{log transformed density} 20 | 21 | \item{n}{number of samples to draw} 22 | 23 | \item{...}{additional parameters passed to \code{dpois} or \code{rpois}} 24 | } 25 | \description{ 26 | \code{cdpois} calculates the probability density of a value \code{k} from a 27 | Poisson distribution with a maximum \code{kmax}. \code{rdpois} draws random 28 | numbers from a conditional Poisson distribution. 29 | } 30 | \examples{ 31 | cdpois(10,1,10) 32 | cdpois(11,1,10) 33 | #rdpois(5,10,10) 34 | } 35 | -------------------------------------------------------------------------------- /man/regime.plot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{regime.plot} 4 | \alias{regime.plot} 5 | \title{Adds visualization of regimes to a plot} 6 | \usage{ 7 | regime.plot(pars, tree, cols, type = "rect", transparency = 100) 8 | } 9 | \arguments{ 10 | \item{pars}{A bayou formatted parameter list} 11 | 12 | \item{tree}{A tree of class 'phylo'} 13 | 14 | \item{cols}{A vector of colors to give to regimes, in the same order as pars$sb} 15 | 16 | \item{type}{Either "rect", "density" or "lines". "rect" plots a rectangle for the 95\% CI for the stationary 17 | distribution of a regime. "density" varies the transparency of the rectangles according to the probability density 18 | from the stationary distribution. "lines" plots lines for the mean and 95\% CI's without filling them.} 19 | 20 | \item{transparency}{The alpha transparency value for the maximum density, max value is 255.} 21 | } 22 | \description{ 23 | Adds visualization of regimes to a plot 24 | } 25 | -------------------------------------------------------------------------------- /man/bayou.lik.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-likelihood.R 3 | \name{bayou.lik} 4 | \alias{bayou.lik} 5 | \title{Function for calculating likelihood of an OU model in bayou using the threepoint algorithm} 6 | \usage{ 7 | bayou.lik(pars, cache, X, model = "OU") 8 | } 9 | \arguments{ 10 | \item{pars}{A list of parameters to calculate the likelihood} 11 | 12 | \item{cache}{A bayou cache object generated using .prepare.ou.univariate} 13 | 14 | \item{X}{A named vector giving the tip data} 15 | 16 | \item{model}{Parameterization of the OU model. Either "OU", "QG" or "OUrepar".} 17 | } 18 | \description{ 19 | Function for calculating likelihood of an OU model in bayou using the threepoint algorithm 20 | } 21 | \details{ 22 | This function implements the algorithm of Ho and Ane (2014) implemented 23 | in the package \code{phylolm} for the \code{OUfixedRoot} model. It is faster 24 | than the equivalent pruning algorithm in geiger, and can be used on non- 25 | ultrametric trees (unlike OU.lik, which is based on the pruning algorithm in 26 | geiger). 27 | } 28 | -------------------------------------------------------------------------------- /man/parmap.W.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-weight_matrix.R 3 | \name{parmap.W} 4 | \alias{parmap.W} 5 | \title{Calculate the weight matrix of a set of regimes on a phylogeny} 6 | \usage{ 7 | parmap.W(tree, pars) 8 | } 9 | \arguments{ 10 | \item{tree}{either a tree of class "phylo" or a cache object produced by bayOU's internal 11 | functions. Must include list element 'maps' which is a simmap reconstruction of regime history.} 12 | 13 | \item{pars}{a list of the parameters used to calculate the weight matrix. Only pars$alpha is 14 | necessary to calculate the matrix, but others can be present.} 15 | } 16 | \description{ 17 | These functions calculate weight matrices from regimes specified by a bayou formatted parameter list 18 | \code{parmap.W} calculates the weight matrix for a set of regimes from a phylogeny 19 | with a stored regime history. \code{.parmap.W} calculates the same matrix, but without checks and is 20 | generally run internally. 21 | } 22 | \details{ 23 | \code{.parmap.W} is more computationally efficient within a mcmc and is used internally. 24 | } 25 | -------------------------------------------------------------------------------- /R/bayou-package.R: -------------------------------------------------------------------------------- 1 | #' bayou-package 2 | #' 3 | #' @name bayou-package 4 | #' @aliases bayou-package bayou 5 | #' @title Bayesian Fitting of Ornstein-Uhlenbeck Models to Phylogenies 6 | #' @description A package for inferring adaptive evolution to phylogenetic 7 | #' comparative data using Bayesian reversible-jump estimation of 8 | #' multi-optima Ornstein-Uhlenbeck models. 9 | #' @author Josef C Uyeda 10 | #' @useDynLib bayou 11 | #' @import ape geiger phytools coda Rcpp MASS mnormt fitdistrplus denstrip grDevices graphics stats assertthat foreach 12 | #' @importFrom utils globalVariables read.table tail 13 | NULL 14 | # @importFrom denstrip densregion 15 | # @importFrom MASS mvrnorm 16 | # @importFrom mnormt dmnorm 17 | # @importFrom fitdistrplus fitdist 18 | # @importFrom grDevices as.raster col2rgb heat.colors rainbow rgb 19 | # @importFrom graphics abline curve lines locator mtext par plot plot.new points rasterImage rect text 20 | # @importFrom stats density dmultinom dnorm dpois median model.frame model.matrix na.pass optim quantile reorder rnorm rpois runif sd setNames terms 21 | 22 | # @importFrom assertthat validate_that 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | [![R-CMD-check](https://github.com/uyedaj/bayou/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/uyedaj/bayou/actions/workflows/R-CMD-check.yaml) 3 | 4 | 5 | ## This is the development version of the R package _bayou_. _bayou_ fits Bayesian reversible-jump multi-optima OU models to phylogenetic comparative data. 6 | 7 | Please report any bugs or issues, as this package is currently under development. 8 | 9 | Install using the devtools package. 10 | ``` 11 | install.packages("devtools") 12 | require(devtools) 13 | install_github("uyedaj/bayou") 14 | require(bayou) 15 | ``` 16 | 17 | A tutorial is available at: 18 | 19 | https://github.com/uyedaj/bayou/blob/master/tutorial.md 20 | 21 | The manuscript describing the method can be found at: 22 | 23 | https://doi.org/10.1093/sysbio/syu057 24 | 25 | [![Click for logo inspiration](https://raw.githubusercontent.com/uyedaj/josef.uyeda.github.io/master/images/bayou.png)](https://www.google.com/maps/place/Atchafalaya+Delta+State+Wildlife%E2%80%A6/@29.4780686,-91.4394682,14556m/data=!3m1!1e3!4m2!3m1!1s0x0:0x8e16460c82051ec2) 26 | 27 | 28 | -------------------------------------------------------------------------------- /man/plotRegimes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{plotRegimes} 4 | \alias{plotRegimes} 5 | \title{Function to plot the regimes from a simmap tree} 6 | \usage{ 7 | plotRegimes(tree, col = NULL, lwd = 1, pal = rainbow, ...) 8 | } 9 | \arguments{ 10 | \item{tree}{A simmap tree of class phylo or simmap with a tree$maps list} 11 | 12 | \item{col}{A named vector of colors to assign to character states, if NULL, then colors are generated from pal} 13 | 14 | \item{lwd}{A numeric value indicating the width of the edges} 15 | 16 | \item{pal}{A color palette function to generate colors if col=NULL} 17 | 18 | \item{...}{Optional arguments that are passed to plot.phylo} 19 | } 20 | \description{ 21 | Function to plot the regimes from a simmap tree 22 | } 23 | \details{ 24 | This function uses plot.phylo to generate coordinates and plot the tree, but plots the 25 | 'maps' element of phytools' simmap format. This provides much of the functionality of plot.phylo from 26 | the ape package. Currently, only types 'phylogram', 'unrooted', 'radial', and 'cladogram' are allowed. Phylogenies must 27 | have branch lengths. 28 | } 29 | -------------------------------------------------------------------------------- /man/dataSim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-simulation.r 3 | \name{dataSim} 4 | \alias{dataSim} 5 | \title{Simulates data from bayou models} 6 | \usage{ 7 | dataSim(pars, model, tree, map.type = "pars", SE = 0, phenogram = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{pars}{A bayou formated parameter list} 11 | 12 | \item{model}{The type of model specified by the parameter list (either "OU", "OUrepar" or "QG").} 13 | 14 | \item{tree}{A tree of class 'phylo'} 15 | 16 | \item{map.type}{Either "pars" if the regimes are taken from the parameter list, or "simmap" if taken from the stored simmap in the tree} 17 | 18 | \item{SE}{A single value or vector equal to the number of tips specifying the measurement error that should be simulated at the tips} 19 | 20 | \item{phenogram}{A logical indicating whether or not the simulated data should be plotted as a phenogram} 21 | 22 | \item{...}{Optional parameters passed to \code{phenogram(...)}.} 23 | } 24 | \description{ 25 | This function simulates data for a given set of parameter values. 26 | } 27 | \details{ 28 | \code{dataSim} Simulates data for a given bayou model and parameter set 29 | } 30 | -------------------------------------------------------------------------------- /man/dloc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/probability.R 3 | \name{dloc} 4 | \alias{dloc} 5 | \alias{rloc} 6 | \title{Probability density function for the location of the shift along the branch} 7 | \usage{ 8 | dloc(loc, min = 0, max = 1, log = TRUE) 9 | 10 | rloc(k, min = 0, max = 1) 11 | } 12 | \arguments{ 13 | \item{loc}{The location of the shift along the branch} 14 | 15 | \item{min}{The minimum position on the branch the shift can take} 16 | 17 | \item{max}{The maximum position on the branch the shift can take} 18 | 19 | \item{log}{A logical indicating whether the log density should be returned} 20 | 21 | \item{k}{The number of shifts to return along a branch} 22 | } 23 | \description{ 24 | Since unequal probabilities are incorporated in calculating the 25 | density via \code{dsb}, all branches are assumed to be of unit length. 26 | Thus, the \code{dloc} function simply returns 0 if \code{log=TRUE} and 1 if \code{log=FALSE}. 27 | } 28 | \details{ 29 | \code{dloc} calculates the probability of a shift occuring at a given 30 | location along the branch assuming a uniform distribution of unit length 31 | \code{rloc} randomly generates the location of a shift along the branch 32 | } 33 | -------------------------------------------------------------------------------- /man/make.powerposteriorFn.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-steppingstone.R 3 | \name{make.powerposteriorFn} 4 | \alias{make.powerposteriorFn} 5 | \title{Makes a power posterior function in bayou} 6 | \usage{ 7 | make.powerposteriorFn(Bk, priorFn, refFn, model) 8 | } 9 | \arguments{ 10 | \item{Bk}{The sequence of steps to be taken from the reference function to the posterior} 11 | 12 | \item{priorFn}{The prior function to be used in marginal likelihood estimation} 13 | 14 | \item{refFn}{The reference function generated using \code{make.refFn()} from a preexisting mcmc chain} 15 | 16 | \item{model}{A string specifying the model type ("OU", "OUrepar", "QG") or a model parameter list} 17 | } 18 | \value{ 19 | A function of class "powerposteriorFn" that returns a list of four values: \code{result} (the log density of the power posterior), 20 | \code{lik} (the log likelihood), \code{prior} (the log prior), \code{ref} the log reference density. 21 | } 22 | \description{ 23 | This function generates a power posterior function for estimation of marginal likelihood using the stepping stone method 24 | } 25 | \details{ 26 | For use in stepping stone estimation of the marginal likelihood using the method of Fan et al. (2011). 27 | } 28 | -------------------------------------------------------------------------------- /.github/workflows/r.yml: -------------------------------------------------------------------------------- 1 | # This workflow uses actions that are not certified by GitHub. 2 | # They are provided by a third-party and are governed by 3 | # separate terms of service, privacy policy, and support 4 | # documentation. 5 | # 6 | # See https://github.com/r-lib/actions/tree/master/examples#readme for 7 | # additional example workflows available for the R community. 8 | 9 | name: R 10 | 11 | on: 12 | push: 13 | branches: [ "master" ] 14 | pull_request: 15 | branches: [ "master" ] 16 | 17 | permissions: 18 | contents: read 19 | 20 | jobs: 21 | build: 22 | runs-on: macos-latest 23 | strategy: 24 | matrix: 25 | r-version: ['4.1.1', '4.4.1'] 26 | 27 | steps: 28 | - uses: actions/checkout@v4 29 | - name: Set up R ${{ matrix.r-version }} 30 | uses: r-lib/actions/setup-r@f57f1301a053485946083d7a45022b278929a78a 31 | with: 32 | r-version: ${{ matrix.r-version }} 33 | - name: Install dependencies 34 | run: | 35 | install.packages(c("remotes", "rcmdcheck")) 36 | remotes::install_deps(dependencies = TRUE) 37 | shell: Rscript {0} 38 | - name: Check 39 | run: rcmdcheck::rcmdcheck(args = "--no-manual", error_on = "error") 40 | shell: Rscript {0} 41 | -------------------------------------------------------------------------------- /man/Lposterior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{Lposterior} 4 | \alias{Lposterior} 5 | \title{Return a posterior of shift locations} 6 | \usage{ 7 | Lposterior(chain, tree, burnin = 0, simpar = NULL, mag = TRUE) 8 | } 9 | \arguments{ 10 | \item{chain}{A bayouMCMC chain} 11 | 12 | \item{tree}{A tree of class 'phylo'} 13 | 14 | \item{burnin}{A value giving the burnin proportion of the chain to be discarded} 15 | 16 | \item{simpar}{An optional bayou formatted parameter list giving the true values (if data were simulated)} 17 | 18 | \item{mag}{A logical indicating whether the average magnitude of the shifts should be returned} 19 | } 20 | \value{ 21 | A data frame with rows corresponding to postordered branches. \code{pp} indicates the 22 | posterior probability of the branch containing a shift. \code{magnitude of theta2} gives the average 23 | value of the new optima after a shift. \code{naive SE of theta2} gives the standard error of the new optima 24 | not accounting for autocorrelation in the MCMC and \code{rel location} gives the average relative location 25 | of the shift on the branch (between 0 and 1 for each branch). 26 | } 27 | \description{ 28 | Return a posterior of shift locations 29 | } 30 | -------------------------------------------------------------------------------- /man/pars2simmap.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/conversion-utilities.R 3 | \name{pars2simmap} 4 | \alias{pars2simmap} 5 | \title{Convert a bayou parameter list into a simmap formatted phylogeny} 6 | \usage{ 7 | pars2simmap(pars, tree) 8 | } 9 | \arguments{ 10 | \item{pars}{A list that contains \code{sb} (a vector of branches with shifts), \code{loc} (a vector of shift locations), 11 | \code{t2} (a vector of theta indices indicating which theta is present after the shift).} 12 | 13 | \item{tree}{A tree of class 'phylo'} 14 | } 15 | \value{ 16 | A list with elements: \code{tree} A simmap formatted tree, \code{pars} bayou formatted parameter list, and \code{cols} A named vector of colors. 17 | } 18 | \description{ 19 | This function converts a bayou formatted parameter list specifying regime locations into a simmap formatted tree that can 20 | be plotted using \code{plotSimmap} from phytools or the \code{plotRegimes} function from bayou. 21 | } 22 | \details{ 23 | \code{pars2simmap} takes a list of parameters and converts it to simmap format 24 | } 25 | \examples{ 26 | tree <- reorder(sim.bdtree(n=100), "postorder") 27 | 28 | pars <- list(k=5, sb=c(195, 196, 184, 138, 153), loc=rep(0, 5), t2=2:6) 29 | tr <- pars2simmap(pars, tree) 30 | plotRegimes(tr$tree, col=tr$col) 31 | } 32 | -------------------------------------------------------------------------------- /man/simmapW.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-weight_matrix.R 3 | \name{simmapW} 4 | \alias{simmapW} 5 | \title{Calculate the weight matrix of a set of regimes on a phylogeny} 6 | \usage{ 7 | simmapW(tree, pars) 8 | } 9 | \arguments{ 10 | \item{tree}{either a tree of class "phylo" or a cache object produced by bayOU's internal 11 | functions. Must include list element 'maps' which is a simmap reconstruction of regime history.} 12 | 13 | \item{pars}{a list of the parameters used to calculate the weight matrix. Only pars$alpha is 14 | necessary to calculate the matrix, but others can be present.} 15 | } 16 | \description{ 17 | These functions calculate weight matrices from regimes specified in phytools' simmap format. 18 | \code{simmapW} calculates the weight matrix for a set of regimes from a phylogeny 19 | with a stored regime history. \code{.simmap.W} calculates the same matrix, but without checks and is 20 | generally run internally. 21 | } 22 | \details{ 23 | \code{.simmap.W} is more computationally efficient within a mcmc and is used internally. The value 24 | of \code{TotExp} is supplied to speed computation and reduce redundancy, and cache objects must be supplied as 25 | the phylogeny, and the parameter \code{ntheta} must be present in the list \code{pars}. 26 | } 27 | -------------------------------------------------------------------------------- /man/pull.pars.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{pull.pars} 4 | \alias{pull.pars} 5 | \title{Utility function for retrieving parameters from an MCMC chain} 6 | \usage{ 7 | pull.pars(i, chain, model = "OU") 8 | } 9 | \arguments{ 10 | \item{i}{An integer giving the sample to retrieve} 11 | 12 | \item{chain}{A bayouMCMC chain} 13 | 14 | \item{model}{The parameterization used, either "OU", "QG" or "OUrepar"} 15 | } 16 | \value{ 17 | A bayou formatted parameter list 18 | } 19 | \description{ 20 | Utility function for retrieving parameters from an MCMC chain 21 | } 22 | \examples{ 23 | \dontrun{ 24 | tree <- sim.bdtree(n=30) 25 | tree$edge.length <- tree$edge.length/max(branching.times(tree)) 26 | prior <- make.prior(tree, dists=list(dk="cdpois", dsig2="dnorm", 27 | dtheta="dnorm"), 28 | param=list(dk=list(lambda=15, kmax=32), 29 | dsig2=list(mean=1, sd=0.01), 30 | dtheta=list(mean=0, sd=3)), 31 | plot.prior=FALSE) 32 | pars <- priorSim(prior, tree, plot=FALSE, nsim=1)$pars[[1]] 33 | dat <- dataSim(pars, model="OU", phenogram=FALSE, tree)$dat 34 | fit <- bayou.mcmc(tree, dat, model="OU", prior=prior, 35 | new.dir=TRUE, ngen=5000, plot.freq=NULL) 36 | chain <- load.bayou(fit, save.Rdata=TRUE, cleanup=TRUE) 37 | plotBayoupars(pull.pars(300, chain), tree) 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /man/identifyBranches.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-utilities.R 3 | \name{identifyBranches} 4 | \alias{identifyBranches} 5 | \title{Identify shifts on branches of a phylogenetic tree} 6 | \usage{ 7 | identifyBranches(tree, n, fixed.loc = TRUE, plot.simmap = TRUE) 8 | } 9 | \arguments{ 10 | \item{tree}{An object of class 'phylo'} 11 | 12 | \item{n}{The number of shifts to map interactively onto the phylogeny} 13 | 14 | \item{fixed.loc}{A logical indicating whether the exact location on the branch should be returned, or the shift will be free to move along the branch} 15 | 16 | \item{plot.simmap}{A logical indicating whether the resulting painting of regimes should be plotted following the selection shift location.} 17 | } 18 | \value{ 19 | Returns a list with elements "sb" which contains the branch numbers of all selected branches with length "n". If "fixed.loc=TRUE", then the list also 20 | contains a vector "loc" which contains the location of the selected shifts along the branch. 21 | } 22 | \description{ 23 | This is a convenience function for mapping regimes interactively on the phylogeny. The method locates the nearest branch to where the 24 | cursor is clicked on the plot and records the branch number and the location selected on the branch. 25 | } 26 | \details{ 27 | \code{identifyBranches} opens an interactive phylogeny plot that allows the user to specify the location 28 | of shifts in a phylogenetic tree. 29 | } 30 | -------------------------------------------------------------------------------- /man/plotShiftSummaries.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{plotShiftSummaries} 4 | \alias{plotShiftSummaries} 5 | \title{A function to plot a list produced by \code{shiftSummaries}} 6 | \usage{ 7 | plotShiftSummaries( 8 | summaries, 9 | pal = rainbow, 10 | ask = FALSE, 11 | single.plot = FALSE, 12 | label.pts = TRUE, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{summaries}{A list produced by the function \code{shiftSummaries}} 18 | 19 | \item{pal}{A color palette function} 20 | 21 | \item{ask}{Whether to wait for the user between plotting each shift summary} 22 | 23 | \item{single.plot}{A logical indicating whether to summarize all shifts in a single plot.} 24 | 25 | \item{label.pts}{A logical indicating whether to label the scatter plot.} 26 | 27 | \item{...}{Additional parameters passed to the function par(...)} 28 | } 29 | \description{ 30 | A function to plot a list produced by \code{shiftSummaries} 31 | } 32 | \details{ 33 | For each shift, this function plots the taxa on the phylogeny that are (usually) in this regime (each taxon 34 | is assigned to the specified shifts, thus some descendent taxa may not always be in indicated regime if the shift if 35 | they are sometimes in another tipward shift with low posterior probability). The function then plots the distribution 36 | of phenotypic states and the predicted regression line, as well as density plots for the intercept and any regression 37 | coefficients in the model. 38 | } 39 | -------------------------------------------------------------------------------- /man/phenogram.density.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{phenogram.density} 4 | \alias{phenogram.density} 5 | \title{Plot a pheongram with the posterior density for optima values} 6 | \usage{ 7 | phenogram.density( 8 | tree, 9 | dat, 10 | burnin = 0, 11 | chain, 12 | colors = NULL, 13 | pp.cutoff = NULL, 14 | K = NULL, 15 | ... 16 | ) 17 | } 18 | \arguments{ 19 | \item{tree}{A phylogeny of class 'phylo'} 20 | 21 | \item{dat}{A named vector of tip data} 22 | 23 | \item{burnin}{The initial proportion of the MCMC to be discarded} 24 | 25 | \item{chain}{A bayouMCMC object that contains the results of an MCMC chain} 26 | 27 | \item{colors}{An optional named vector of colors to assign to regimes, \code{NULL} results in no regimes being plotted.} 28 | 29 | \item{pp.cutoff}{The posterior probability cutoff value. Branches with posterior probabilities of having a shift above this value 30 | will have the average location of the regime shift painted onto the branches.} 31 | 32 | \item{K}{A list with the values of K to be plotted. If \code{NULL} all values of K are combined and a total posterior produced. This 33 | allows separate lines to be plotted for different numbers of shifts so that the location of optima can be compared, for example, between 34 | all samples that have 1 vs. 2 shifts in the posterior.} 35 | 36 | \item{...}{Additional parameters passed to \code{phenogram(...)}} 37 | } 38 | \description{ 39 | Plots a phenogram and the posterior density for optima values 40 | } 41 | -------------------------------------------------------------------------------- /man/load.bayou.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc-utilities.R 3 | \name{load.bayou} 4 | \alias{load.bayou} 5 | \title{Loads a bayou object} 6 | \usage{ 7 | load.bayou(bayouFit, saveRDS = TRUE, file = NULL, cleanup = FALSE, ref = FALSE) 8 | } 9 | \arguments{ 10 | \item{bayouFit}{An object of class \code{bayouFit} produced by the function \code{bayou.mcmc()}} 11 | 12 | \item{saveRDS}{A logical indicating whether the resulting chains should be saved as an *.rds file} 13 | 14 | \item{file}{An optional filename (possibly including path) for the saved *.rds file} 15 | 16 | \item{cleanup}{A logical indicating whether the files produced by \code{bayou.mcmc()} should be removed.} 17 | 18 | \item{ref}{A logical indicating whether a reference function is also in the output} 19 | } 20 | \description{ 21 | \code{load.bayou} loads a bayouFit object that was created using \code{bayou.mcmc()} 22 | } 23 | \details{ 24 | If both \code{save.Rdata} is \code{FALSE} and \code{cleanup} is \code{TRUE}, then \code{load.bayou} will trigger a 25 | warning and ask for confirmation. In this case, if the results of \code{load.bayou()} are not stored in an object, 26 | the results of the MCMC run will be permanently deleted. 27 | } 28 | \examples{ 29 | \dontrun{ 30 | data(chelonia) 31 | tree <- chelonia$phy 32 | dat <- chelonia$dat 33 | prior <- make.prior(tree) 34 | fit <- bayou.mcmc(tree, dat, model="OU", prior=prior, 35 | new.dir=TRUE, ngen=5000) 36 | chain <- load.bayou(fit, save.Rdata=FALSE, cleanup=TRUE) 37 | plot(chain) 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /man/OU.lik.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-likelihood.R 3 | \name{OU.lik} 4 | \alias{OU.lik} 5 | \title{Function for calculating likelihood of an OU model in bayou using pruning algorithm 6 | or matrix inversion} 7 | \usage{ 8 | OU.lik(pars, tree, X, SE = 0, model = "OU", invert = FALSE) 9 | } 10 | \arguments{ 11 | \item{pars}{A list of parameters to calculate the likelihood} 12 | 13 | \item{tree}{A phylogenetic tree of class 'phylo'} 14 | 15 | \item{X}{A named vector giving the tip data} 16 | 17 | \item{SE}{A named vector or single number giving the standard errors of the data} 18 | 19 | \item{model}{Parameterization of the OU model. Either "OU", "QG" or "OUrepar".} 20 | 21 | \item{invert}{A logical indicating whether the likelihood should be solved by matrix 22 | inversion, rather than 23 | the pruning algorithm. This is primarily present to test that calculation of the likelihood 24 | is correct.} 25 | } 26 | \value{ 27 | A list returning the log likelihood ("loglik"), the weight matrix ("W"), the optima ("theta"), 28 | the residuals ("resid") and the expected values ("Exp"). 29 | } 30 | \description{ 31 | Function for calculating likelihood of an OU model in bayou using pruning algorithm 32 | or matrix inversion 33 | } 34 | \details{ 35 | This function can be used for calculating single likelihoods using previously 36 | implemented methods. It is likely to become deprecated and replaced by \code{bayou.lik} 37 | in the future, which is based on \code{phylolm}'s threepoint algorithm, which works on 38 | non-ultrametric trees and is substantially faster. 39 | } 40 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master, abhi-clean] 6 | pull_request: 7 | branches: [main, master, abhi-clean] 8 | 9 | name: R-CMD-check 10 | 11 | permissions: read-all 12 | 13 | jobs: 14 | R-CMD-check: 15 | runs-on: ${{ matrix.config.os }} 16 | 17 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 18 | 19 | strategy: 20 | fail-fast: false 21 | matrix: 22 | config: 23 | - {os: macos-latest, r: 'release'} 24 | - {os: windows-latest, r: 'release'} 25 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 26 | - {os: ubuntu-latest, r: 'release'} 27 | - {os: ubuntu-latest, r: 'oldrel-1'} 28 | 29 | env: 30 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 31 | R_KEEP_PKG_SOURCE: yes 32 | 33 | steps: 34 | - uses: actions/checkout@v4 35 | 36 | - uses: r-lib/actions/setup-pandoc@v2 37 | 38 | - uses: r-lib/actions/setup-r@v2 39 | with: 40 | r-version: ${{ matrix.config.r }} 41 | http-user-agent: ${{ matrix.config.http-user-agent }} 42 | use-public-rspm: true 43 | 44 | - uses: r-lib/actions/setup-r-dependencies@v2 45 | with: 46 | extra-packages: any::rcmdcheck 47 | needs: check 48 | 49 | - uses: r-lib/actions/check-r-package@v2 50 | with: 51 | upload-snapshots: true 52 | build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' 53 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(plot,bayouMCMC) 4 | S3method(plot,ssMCMC) 5 | S3method(print,bayouFit) 6 | S3method(print,bayouMCMC) 7 | S3method(print,priorFn) 8 | S3method(print,refFn) 9 | S3method(print,ssMCMC) 10 | S3method(summary,bayouMCMC) 11 | export(Lposterior) 12 | export(OU.lik) 13 | export(OUphenogram) 14 | export(OUwie2bayou) 15 | export(bayou.checkModel) 16 | export(bayou.lik) 17 | export(bayou.makeMCMC) 18 | export(bayou.mcmc) 19 | export(bayou2OUwie) 20 | export(cdpois) 21 | export(combine.chains) 22 | export(dataSim) 23 | export(dhalfcauchy) 24 | export(dloc) 25 | export(dsb) 26 | export(gelman.R) 27 | export(identifyBranches) 28 | export(load.bayou) 29 | export(make.powerposteriorFn) 30 | export(make.prior) 31 | export(make.refFn) 32 | export(makeBayouModel) 33 | export(makeTransparent) 34 | export(parmap.W) 35 | export(pars2simmap) 36 | export(phalfcauchy) 37 | export(phenogram.density) 38 | export(plotBayoupars) 39 | export(plotBranchHeatMap) 40 | export(plotOUtreesim) 41 | export(plotRegimes) 42 | export(plotShiftSummaries) 43 | export(plotSimmap.mcmc) 44 | export(priorSim) 45 | export(pull.pars) 46 | export(qhalfcauchy) 47 | export(rdpois) 48 | export(rhalfcauchy) 49 | export(rloc) 50 | export(rsb) 51 | export(set.burnin) 52 | export(shiftSummaries) 53 | export(simmapW) 54 | import(MASS) 55 | import(Rcpp) 56 | import(ape) 57 | import(assertthat) 58 | import(coda) 59 | import(denstrip) 60 | import(fitdistrplus) 61 | import(foreach) 62 | import(geiger) 63 | import(grDevices) 64 | import(graphics) 65 | import(mnormt) 66 | import(phytools) 67 | import(stats) 68 | importFrom(utils,globalVariables) 69 | importFrom(utils,read.table) 70 | importFrom(utils,tail) 71 | useDynLib(bayou) 72 | -------------------------------------------------------------------------------- /man/shiftSummaries.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{shiftSummaries} 4 | \alias{shiftSummaries} 5 | \title{A function for summarizing the state of a model after a shift} 6 | \usage{ 7 | shiftSummaries(chain, mcmc, pp.cutoff = 0.3, branches = NULL) 8 | } 9 | \arguments{ 10 | \item{chain}{A bayouMCMC chain} 11 | 12 | \item{mcmc}{A bayou mcmc object} 13 | 14 | \item{pp.cutoff}{The threshold posterior probability for shifts to summarize, if 'branches' 15 | specified than this is ignored.} 16 | 17 | \item{branches}{The specific branches with shifts to summarize, assuming postordered tree} 18 | } 19 | \value{ 20 | A list with elements: 21 | \code{pars} = a bayoupars list giving the location of shifts specified; 22 | \code{tree} = The tree; 23 | \code{pred} = Predictor variable matrix; 24 | \code{dat} = A vector of the data; 25 | \code{SE} = A vector of standard errors; 26 | \code{PP} = Posterior probabilities of the specified shifts; 27 | \code{model} = A list specifying the model used; 28 | \code{variables} = The variables summarized; 29 | \code{cladesummaries} = A list providing the medians and densities of the distributions of regression 30 | variables for each shift; 31 | \code{descendents} = A list providing the taxa that belong to each regime 32 | \code{regressions} = A matrix providing the regression coefficients for each regime. 33 | } 34 | \description{ 35 | A function for summarizing the state of a model after a shift 36 | } 37 | \details{ 38 | shiftSummaries summarizes the immediate parameter values after a shift on a particular 39 | branch. Parameters are summarized only for the duration that the particular shift exists. Thus, 40 | even global parameters will be different for particular shifts. 41 | } 42 | -------------------------------------------------------------------------------- /man/OUphenogram.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{OUphenogram} 4 | \alias{OUphenogram} 5 | \title{Experimental phenogram plotting function for set of model of model parameters} 6 | \usage{ 7 | OUphenogram(pars, tree, dat, SE = 0, regime.col = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{pars}{A bayou formatted parameter list} 11 | 12 | \item{tree}{A tree of class 'phylo'} 13 | 14 | \item{dat}{A named vector of tip data} 15 | 16 | \item{SE}{Standard error of the tip states} 17 | 18 | \item{regime.col}{A named vector of colors equal in length to the number of regimes} 19 | 20 | \item{...}{Optional arguments passed to \code{phenogram()}} 21 | } 22 | \description{ 23 | Experimental phenogram plotting function for set of model of model parameters 24 | } 25 | \details{ 26 | This is an experimental plotting utility that can plot a phenogram with a given regime painting from 27 | a parameter list. Note that it uses optimization of internal node states using matrix inversion, which is very 28 | slow for large trees. However, what is returned is the maximum likelihood estimate of the internal node states 29 | given the model, data and the parameter values. 30 | } 31 | \examples{ 32 | \dontrun{ 33 | tree <- sim.bdtree(n=50) 34 | tree$edge.length <- tree$edge.length/max(branching.times(tree)) 35 | prior <- make.prior(tree, dists=list(dk="cdpois", dsig2="dnorm", 36 | dtheta="dnorm"), param=list(dk=list(lambda=5, kmax=10), 37 | dsig2=list(mean=1, sd=0.01), dtheta=list(mean=0, sd=3)), 38 | plot.prior=FALSE) 39 | pars <- priorSim(prior, tree, plot=FALSE, nsim=1)$pars[[1]] 40 | pars$alpha <- 4 41 | dat <- dataSim(pars, model="OU", phenogram=FALSE, tree)$dat 42 | OUphenogram(pars, tree, dat, ftype="off") 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /man/make.refFn.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-steppingstone.R 3 | \name{make.refFn} 4 | \alias{make.refFn} 5 | \title{Make a reference function in bayou} 6 | \usage{ 7 | make.refFn(chain, model, priorFn, burnin = 0.3, plot = TRUE) 8 | } 9 | \arguments{ 10 | \item{chain}{An mcmc chain produced by \code{bayou.mcmc()} and loaded with \code{load.bayou()}} 11 | 12 | \item{model}{A string specifying the model ("OU", "QG", "OUrepar") or a model parameter list} 13 | 14 | \item{priorFn}{The prior function used to generate the mcmc chain} 15 | 16 | \item{burnin}{The proportion of the mcmc chain to be discarded when generating the reference function} 17 | 18 | \item{plot}{Logical indicating whether or not a plot should be created} 19 | } 20 | \value{ 21 | Returns a reference function of class "refFn" that takes a parameter list and returns the log density 22 | given the reference distribution. If \code{plot=TRUE}, a plot is produced showing the density of variable parameters 23 | and the fitted distribution from the reference function (in red). 24 | } 25 | \description{ 26 | This function generates a reference function from a mcmc chain for use in marginal likelihood 27 | estimation. 28 | } 29 | \details{ 30 | Distributions are fit to each mcmc chain and the best-fitting distribution is chosen as 31 | the reference distribution for that parameter using the method of Fan et al. (2011). For positive 32 | continuous parameters \code{alpha, sigma^2, halflife, Vy, w2, Ne}, Log-normal, exponential, gamma and weibull 33 | distributions are fit. For continuous distributions \code{theta}, Normal, Cauchy and Logistic distributions 34 | are fit. For discrete distributions, \code{k}, negative binomial, poisson and geometric distributions are fit. 35 | Best-fitting distributions are determined by AIC. 36 | } 37 | -------------------------------------------------------------------------------- /inst/tests/test-prior.r: -------------------------------------------------------------------------------- 1 | #context("testing prior functions") 2 | 3 | testthat::test_that("testing prior functions", { 4 | library(bayou) 5 | data(chelonia, package="geiger") 6 | tree <- chelonia$phy 7 | dat <- chelonia$dat 8 | cache <- bayou:::.prepare.ou.univariate(tree, dat) 9 | pars <- list(alpha=0.1, sig2=1, k=16, theta=c(3,4,5,6), sb=c(411,400,47), loc=c(23, 21, 33)) 10 | QGpars <- list(h2=0.1,P=1,w2=0.9,Ne=1,k=16,theta=c(3,4,5,6), sb=c(411,400,47), loc=c(23, 21, 33)) 11 | prior <- make.prior(tree,dists=list(dalpha="dunif",dsig2="dunif"),param=list(dalpha=list(min=0,max=1),dsig2=list(min=0,max=1),dsb=list(bmax=1,prob=1)),plot.prior=FALSE) 12 | QGprior <- make.prior(tree,dists=list(dh2="dunif",dP="dunif",dw2="dunif",dNe="dunif"),param=list(dh2=list(min=0,max=1),dP=list(min=0,max=1),dw2=list(min=0,max=1),dNe=list(min=0,max=1)),model="QG", plot.prior=FALSE) 13 | testthat::expect_equal(class(try(make.prior(tree, plot.prior=FALSE),silent=TRUE))[1],"priorFn") 14 | testthat::expect_equal(class(try(make.prior(tree,model="QG", plot.prior=FALSE),silent=TRUE))[1],"priorFn") 15 | testthat::expect_equal(class(try(make.prior(tree,model="OUrepar",plot.prior=FALSE),silent=TRUE))[1],"priorFn") 16 | testthat::expect_equal(prior(pars),-94.87692,tolerance=0.0001) 17 | testthat::expect_equal(QGprior(QGpars),prior(pars)) 18 | f1tree <- tree 19 | f1tree$edge.length[pars$sb] <- tree$edge.length[pars$sb]*100 20 | priorf1 <- make.prior(tree,dists=list(dalpha="dunif",dsig2="dunif"),param=list(dalpha=list(min=0,max=1),dsig2=list(min=0,max=1),dsb=list(bmax=Inf,prob=tree$edge.length)),plot.prior=FALSE) 21 | priorf2 <- make.prior(f1tree,dists=list(dalpha="dunif",dsig2="dunif"),param=list(dalpha=list(min=0,max=1),dsig2=list(min=0,max=1),dsb=list(bmax=Inf,prob=f1tree$edge.length)),plot.prior=FALSE) 22 | testthat::expect_true(priorf1(pars)< priorf2(pars)) 23 | testthat::expect_error(QGprior(pars),"Missing parameters: h2 P w2 Ne") 24 | }) 25 | -------------------------------------------------------------------------------- /man/plotBranchHeatMap.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{plotBranchHeatMap} 4 | \alias{plotBranchHeatMap} 5 | \title{A function to plot a heatmap of reconstructed parameter values on the branches of the tree} 6 | \usage{ 7 | plotBranchHeatMap( 8 | tree, 9 | chain, 10 | variable, 11 | burnin = 0, 12 | nn = NULL, 13 | pal = heat.colors, 14 | legend_ticks = NULL, 15 | legend_settings = list(plot = TRUE), 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{tree}{A phylogenetic tree} 21 | 22 | \item{chain}{A bayou MCMC chain} 23 | 24 | \item{variable}{The parameter to reconstruct across the tree} 25 | 26 | \item{burnin}{The initial proportion of burnin samples to discard} 27 | 28 | \item{nn}{The number of discrete categories to divide the variable into} 29 | 30 | \item{pal}{A color palette function that produces nn colors} 31 | 32 | \item{legend_ticks}{The sequence of values to display a legend for} 33 | 34 | \item{legend_settings}{A list of legend attributes (passed to bayou:::.addColorBar)} 35 | 36 | \item{...}{Additional options passed to plot.phylo} 37 | } 38 | \description{ 39 | A function to plot a heatmap of reconstructed parameter values on the branches of the tree 40 | } 41 | \details{ 42 | legend_settings is an optional list of any of the following: 43 | 44 | legend - a logical indicating whether a legend should be plotted 45 | 46 | x - the x location of the legend 47 | 48 | y - the y location of the legend 49 | 50 | height - the height of the legend 51 | 52 | width - the width of the legend 53 | 54 | n - the number of gradations in color to plot from the palette 55 | 56 | adjx - an x adjustment for placing text next to the legend bar 57 | 58 | cex.lab - the size of text labels next to the legend bar 59 | 60 | text.col - The color of text labels 61 | 62 | locator - if TRUE, then x and y coordinates are ignored and legend is placed 63 | interactively. 64 | } 65 | -------------------------------------------------------------------------------- /man/bayou.checkModel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-utilities.R 3 | \name{bayou.checkModel} 4 | \alias{bayou.checkModel} 5 | \title{Function for checking parameter lists, prior and models are consistent and error-free} 6 | \usage{ 7 | bayou.checkModel( 8 | pars = NULL, 9 | tree, 10 | dat, 11 | pred = NULL, 12 | SE = 0, 13 | prior, 14 | model = "OU", 15 | autofix = TRUE 16 | ) 17 | } 18 | \arguments{ 19 | \item{pars}{A list of parameters that will be specified as starting parameter} 20 | 21 | \item{tree}{An object of class ``phylo''} 22 | 23 | \item{dat}{A named data vector that matches the tip lables in the provided tree} 24 | 25 | \item{pred}{A matrix or data frame with named columns with predictor data represented 26 | in the specified formula} 27 | 28 | \item{SE}{The standard error of the data. Either a single value applied to all the data, 29 | or a vector of length(dat).} 30 | 31 | \item{prior}{A prior function made using make.prior} 32 | 33 | \item{model}{Either one of c("OU", "QG" or "OUrepar") or a list specifying the model 34 | to be used.} 35 | 36 | \item{autofix}{A logical that indicates whether certain errors should be automatically fixed.} 37 | } 38 | \value{ 39 | A list of results of the checks and if 'autofix==TRUE', then ..$autofixed returns a 40 | list of all the input elements, with corrections. 41 | } 42 | \description{ 43 | Function for checking parameter lists, prior and models are consistent and error-free 44 | } 45 | \details{ 46 | A series of checks are performed, run internally within bayou.makeMCMC, but can also 47 | be run on provided inputs prior to this. Errors are reported. 48 | 49 | If autofix == TRUE, then the following errors will be automatically corrected: 50 | 51 | Branch lengths == 0; any branches of length 0 will be given length .Machine$double.eps 52 | is.binary(tree) == FALSE; runs multi2di 53 | pars do not match prior$fixed; parameters are resimulated from prior 54 | } 55 | -------------------------------------------------------------------------------- /R/teaching-functions.R: -------------------------------------------------------------------------------- 1 | .sim.OU <- function(ns, totaltime, alpha, sig2, theta, x0){ 2 | time.seq <- seq(0, totaltime, length.out=ns) 3 | time.step <- (totaltime - 0)/(ns-1) 4 | if(length(alpha)==1){ 5 | alpha <- rep(alpha, ns) 6 | } 7 | if(length(theta)==1){ 8 | theta <- rep(theta, ns) 9 | } 10 | if(length(sig2)==1){ 11 | sig2 <- rep(sig2, ns) 12 | } 13 | MM <- array(dim=ns) 14 | Xi <- x0 15 | for(i in 1:ns){ 16 | Xi <- .ou.next(Xi, alpha[i], sig2[i], theta[i], time.step) 17 | MM[i] <- Xi 18 | } 19 | return(MM) 20 | } 21 | 22 | .simOU.onmap <- function(mapi, alpha, sig2, theta, ptsperunit, x0){ 23 | regimes <- as.numeric(names(mapi)) 24 | nopts <- round(mapi*ptsperunit,0) 25 | totalpts <- sum(nopts) 26 | theta <- unlist(lapply(1:length(mapi), function(x) rep(theta[regimes[x]], nopts[x]))) 27 | .sim.OU(totalpts, sum(mapi), alpha, sig2, theta, x0) 28 | } 29 | 30 | .ou.next <- function(x, alpha, sig2, theta, tt){ 31 | Exp <- x*exp(-alpha*tt) + theta*(1-exp(-alpha*tt)) 32 | stats::rnorm(1, Exp, sqrt(sig2*tt)) 33 | } 34 | 35 | #' A function to visualize a multi-optimum OU process evolving on a phylogeny 36 | #' 37 | #' @param pars A bayou parameter list to simulate the OU process from 38 | #' @param tree A phylogenetic tree 39 | #' @param ptsperunit A number giving the number of points to simulate per unit time 40 | #' @param pal A color palette function 41 | #' @param aph The alpha value for transparency of the lines 42 | #' @param lwd The width of the lines 43 | #' 44 | #' @export 45 | plotOUtreesim <- function(pars, tree, ptsperunit=100, pal=rainbow, aph=255, lwd=1){ 46 | simmapTree <- pars2simmap(pars, tree) 47 | maps <- simmapTree$tree$maps 48 | alpha <- pars$alpha 49 | sig2 <- pars$sig2 50 | theta <- pars$theta 51 | x0 <- pars$theta[1] 52 | cols <- setNames(pal(pars$ntheta), 1:pars$ntheta) 53 | brcols <- cols[sapply(1:length(maps), function(x) names(utils::tail(maps[[x]], 1)))] 54 | nH <- nodeHeights(tree) 55 | history <- list() 56 | Xi <- x0 57 | for(i in length(maps):1){ 58 | if(i < length(maps) -1) Xi <- history[[which(tree$edge[,2]==tree$edge[i,1])]][length(history[[which(tree$edge[,2]==tree$edge[i,1])]])] 59 | history[[i]] <- .simOU.onmap(maps[[i]], alpha, sig2, theta, ptsperunit, Xi) 60 | } 61 | plot(c(min(nH), max(nH)), c(min(unlist(history)), max(unlist(history))), type="n", xlab="", ylab="", xaxt="n", yaxt="n", bty="n") 62 | invisible(lapply(1:length(history), function(x) lines(seq(nH[x,1], nH[x,2], length.out=length(history[[x]])), history[[x]], col=makeTransparent(brcols[[x]], alpha=aph),lwd=lwd))) 63 | } -------------------------------------------------------------------------------- /man/dsb.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/probability.R 3 | \name{dsb} 4 | \alias{dsb} 5 | \alias{rsb} 6 | \title{Probability density functions for bayou} 7 | \usage{ 8 | dsb(sb, ntips = ntips, bmax = 1, prob = 1, log = TRUE) 9 | 10 | rsb(k, ntips = ntips, bmax = 1, prob = 1, log = TRUE) 11 | } 12 | \arguments{ 13 | \item{sb}{A vector giving the branch numbers (for a post-ordered tree)} 14 | 15 | \item{ntips}{The number of tips in the phylogeny} 16 | 17 | \item{bmax}{A single integer or a vector of integers equal to the number of 18 | branches in the phylogeny indicating the 19 | maximum number of shifts allowable in the phylogeny. Can take values 0, 1 and Inf.} 20 | 21 | \item{prob}{A single value or a vector of values equal to the number of branches 22 | in the phylogeny indicating the probability that 23 | a randomly selected shift will lie on this branch. Can take any positive value, 24 | values need not sum to 1 (they will be scaled to sum to 1)} 25 | 26 | \item{log}{A logical indicating whether the log probability should be returned. 27 | Default is 'TRUE'} 28 | 29 | \item{k}{The number of shifts to randomly draw from the distribution} 30 | } 31 | \value{ 32 | The log density of the particular number and arrangement of shifts. 33 | } 34 | \description{ 35 | This function provides a means to specify the prior for the location 36 | of shifts across the phylogeny. Certain combinations are not 37 | allowed. For example, a maximum shift number of Inf on one branch cannot be combined 38 | with a maximum shift number of 1 on another. Thus, bmax must be 39 | either a vector of 0's and Inf's or a vector of 0's and 1's. Also, if bmax == 1, 40 | then all probabilities must be equal, as bayou cannot sample unequal 41 | probabilities without replacement. 42 | } 43 | \details{ 44 | \code{dsb} calculates the probability of a particular arrangement of shifts 45 | for a given set of assumptions. 46 | } 47 | \examples{ 48 | n=10 49 | tree <- sim.bdtree(n=n) 50 | tree <- reorder(tree, "postorder") 51 | nbranch <- 2*n-2 52 | sb <- c(1,2, 2, 3) 53 | 54 | # Allow any number of shifts on each branch, with probability 55 | # proportional to branch length 56 | dsb(sb, ntips=n, bmax=Inf, prob=tree$edge.length) 57 | 58 | # Disallow shifts on the first branch, returns -Inf because sb[1] = 1 59 | dsb(sb, ntips=n, bmax=c(0, rep(1, nbranch-1)), prob=tree$edge.length) 60 | 61 | # Set maximum number of shifts to 1, returns -Inf because two shifts 62 | # are on branch 2 63 | dsb(sb, ntips=n, bmax=1, prob=1) 64 | 65 | # Generate a random set of k branches 66 | rsb(5, ntips=n, bmax=Inf, prob=tree$edge.length) 67 | } 68 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | 9 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 10 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 11 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 12 | #endif 13 | 14 | // C_threepoint 15 | SEXP C_threepoint(SEXP dat); 16 | RcppExport SEXP _bayou_C_threepoint(SEXP datSEXP) { 17 | BEGIN_RCPP 18 | Rcpp::RObject rcpp_result_gen; 19 | Rcpp::RNGScope rcpp_rngScope_gen; 20 | Rcpp::traits::input_parameter< SEXP >::type dat(datSEXP); 21 | rcpp_result_gen = Rcpp::wrap(C_threepoint(dat)); 22 | return rcpp_result_gen; 23 | END_RCPP 24 | } 25 | // C_transf_branch_lengths 26 | SEXP C_transf_branch_lengths(SEXP dat, int model, NumericVector y, double alpha); 27 | RcppExport SEXP _bayou_C_transf_branch_lengths(SEXP datSEXP, SEXP modelSEXP, SEXP ySEXP, SEXP alphaSEXP) { 28 | BEGIN_RCPP 29 | Rcpp::RObject rcpp_result_gen; 30 | Rcpp::RNGScope rcpp_rngScope_gen; 31 | Rcpp::traits::input_parameter< SEXP >::type dat(datSEXP); 32 | Rcpp::traits::input_parameter< int >::type model(modelSEXP); 33 | Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); 34 | Rcpp::traits::input_parameter< double >::type alpha(alphaSEXP); 35 | rcpp_result_gen = Rcpp::wrap(C_transf_branch_lengths(dat, model, y, alpha)); 36 | return rcpp_result_gen; 37 | END_RCPP 38 | } 39 | // C_weightmatrix 40 | SEXP C_weightmatrix(SEXP dat, SEXP parameters); 41 | RcppExport SEXP _bayou_C_weightmatrix(SEXP datSEXP, SEXP parametersSEXP) { 42 | BEGIN_RCPP 43 | Rcpp::RObject rcpp_result_gen; 44 | Rcpp::RNGScope rcpp_rngScope_gen; 45 | Rcpp::traits::input_parameter< SEXP >::type dat(datSEXP); 46 | Rcpp::traits::input_parameter< SEXP >::type parameters(parametersSEXP); 47 | rcpp_result_gen = Rcpp::wrap(C_weightmatrix(dat, parameters)); 48 | return rcpp_result_gen; 49 | END_RCPP 50 | } 51 | 52 | RcppExport SEXP bm_direct2(SEXP, SEXP); 53 | RcppExport SEXP cache_descendants(SEXP, SEXP); 54 | 55 | static const R_CallMethodDef CallEntries[] = { 56 | {"_bayou_C_threepoint", (DL_FUNC) &_bayou_C_threepoint, 1}, 57 | {"_bayou_C_transf_branch_lengths", (DL_FUNC) &_bayou_C_transf_branch_lengths, 4}, 58 | {"_bayou_C_weightmatrix", (DL_FUNC) &_bayou_C_weightmatrix, 2}, 59 | {"bm_direct2", (DL_FUNC) &bm_direct2, 2}, 60 | {"cache_descendants", (DL_FUNC) &cache_descendants, 2}, 61 | {NULL, NULL, 0} 62 | }; 63 | 64 | RcppExport void R_init_bayou(DllInfo *dll) { 65 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 66 | R_useDynamicSymbols(dll, FALSE); 67 | } 68 | -------------------------------------------------------------------------------- /man/makeBayouModel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-custommodel-input.R 3 | \name{makeBayouModel} 4 | \alias{makeBayouModel} 5 | \title{This function makes a bayou model object that can be used for customized allometric regression models.} 6 | \usage{ 7 | makeBayouModel( 8 | f, 9 | rjpars, 10 | tree, 11 | dat, 12 | pred, 13 | prior, 14 | SE = 0, 15 | slopechange = "immediate", 16 | impute = NULL, 17 | startpar = NULL, 18 | moves = NULL, 19 | control.weights = NULL, 20 | D = NULL, 21 | shiftpars = c("sb", "loc", "t2"), 22 | model = "OU" 23 | ) 24 | } 25 | \arguments{ 26 | \item{f}{A formula describing the relationship between the data and one or more predictors (use 'dat' 27 | for the dependent variable)} 28 | 29 | \item{rjpars}{A character vector of parameters to split at the mapped shifts on the tree} 30 | 31 | \item{tree}{A phylogenetic tree} 32 | 33 | \item{dat}{A named vector of trait data (dependent variable)} 34 | 35 | \item{pred}{A matrix or data frame with named columns with predictor data represented in the specified 36 | formula} 37 | 38 | \item{prior}{A prior function made by the 'make.prior' function} 39 | 40 | \item{SE}{A single value or vector of measurement error estimates} 41 | 42 | \item{slopechange}{"immediate", "alphaWeighted" or "fullPGLS"} 43 | 44 | \item{impute}{The name of a single predictor for which missing values will be imputed using BM (see details). 45 | Default is NULL.} 46 | 47 | \item{startpar}{An optional list of starting parameters for the model. If not provided, the model will simulate 48 | starting values from the prior function.} 49 | 50 | \item{moves}{An optional list of moves to be passed on to bayou.makeMCMC.} 51 | 52 | \item{control.weights}{An optional list of control weights to be passed on to bayou.makeMCMC.} 53 | 54 | \item{D}{A vector of tuning parameters to be passed on to bayou.makeMCMC.} 55 | 56 | \item{shiftpars}{The names of the parameters defining the map of shifts (for now, always c("sb", "loc", "t2")).} 57 | 58 | \item{model}{The parameterization of the OU model, either "OU", "OUrepar" or "QG".} 59 | } 60 | \description{ 61 | This function makes a bayou model object that can be used for customized allometric regression models. 62 | } 63 | \details{ 64 | This function generates a list with the '$model', which provides the specifications of the regression 65 | model and '$startpar', which provides starting values to input into bayou.makeMCMC. Note that this model assumes 66 | that predictors immediately affect trait values at a shift. In other words, regardless of the past history of the 67 | predictor, only the current value affects the current expected trait value. This is only reasonable for allometric 68 | models, although it may be appropriate for other models if phylogenetic inertia is very low (short half-lives). 69 | 70 | One predictor variable may include missing data (coded as "NA"). The model will assume the maximum-likelihood 71 | best-fit BM model and simulate the missing predictor values throughout the course of the MCMC. These values will 72 | then be used to calculate the likelihood given the parameters for each MCMC step. 73 | } 74 | -------------------------------------------------------------------------------- /man/plotSimmap.mcmc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-plotting.R 3 | \name{plotSimmap.mcmc} 4 | \alias{plotSimmap.mcmc} 5 | \title{Plot a phylogenetic tree with posterior probabilities from a bayouMCMC chain (function adapted from phytools' plotSimmap)} 6 | \usage{ 7 | plotSimmap.mcmc( 8 | chain, 9 | burnin = NULL, 10 | lwd = 1, 11 | edge.type = c("regimes", "theta", "none", "pp"), 12 | pal = rainbow, 13 | pp.cutoff = 0.3, 14 | circles = TRUE, 15 | circle.cex.max = 3, 16 | circle.col = "red", 17 | circle.pch = 21, 18 | circle.lwd = 0.75, 19 | circle.alpha = 100, 20 | pp.labels = FALSE, 21 | pp.col = 1, 22 | pp.alpha = 255, 23 | pp.cex = 0.75, 24 | edge.color = 1, 25 | parameter.sample = 1000, 26 | ... 27 | ) 28 | } 29 | \arguments{ 30 | \item{chain}{A bayouMCMC chain} 31 | 32 | \item{burnin}{The proportion of runs to be discarded, if NULL, then the value stored in the bayouMCMC chain's attributes is used} 33 | 34 | \item{lwd}{The width of the edges} 35 | 36 | \item{edge.type}{Either "theta" (branches will be colored according to their median value of theta), "regimes" (clades will be assigned to distinct regimes if the posterior probability of a shift 37 | on that branch is > pp.cutoff), or "pp" (branches will be colored according to the probability of a shift on that branch). If "none" then edge.color will be assigned to all branches.} 38 | 39 | \item{pal}{A color palette function used to paint the branches (unless edge.type="none")} 40 | 41 | \item{pp.cutoff}{If edge.type=="regimes", the posterior probability above which a shift should be reconstructed on the tree.} 42 | 43 | \item{circles}{a logical value indicating whether or not a circle should be plotted at the base of the node with values that correspond to the posterior probability of having a shift.} 44 | 45 | \item{circle.cex.max}{The cex value of a circle with a posterior probability of 1} 46 | 47 | \item{circle.col}{The color used to fill the circles} 48 | 49 | \item{circle.pch}{the type of symbol used to plot at the node to indicate posterior probability} 50 | 51 | \item{circle.lwd}{the line width of the points plotted at the nodes} 52 | 53 | \item{circle.alpha}{a value between 0 and 255 that indicates the transparency of the circles (255 is completely opaque).} 54 | 55 | \item{pp.labels}{a logical indicating whether the posterior probability for each branch should be printed above the branch} 56 | 57 | \item{pp.col}{The color used for the posterior probability labels} 58 | 59 | \item{pp.alpha}{a logical or numeric value indicating transparency of posterior probability labels. If TRUE, then transparency is ramped from invisible (pp=0), to black (pp=1). If numeric, all labels are given the same transparency. If NULL, then no transparency is given.} 60 | 61 | \item{pp.cex}{the size of the posterior probability labels} 62 | 63 | \item{edge.color}{The color of edges if edge.type="none"} 64 | 65 | \item{parameter.sample}{When edge.type=="theta", the number of samples used to estimate the median "theta" value from each branch. Since this is 66 | computationally intensive, this enables you to downsample the chain.} 67 | 68 | \item{...}{Additional arguments passed to ape's plot.phylo} 69 | } 70 | \description{ 71 | Plot a phylogenetic tree with posterior probabilities from a bayouMCMC chain (function adapted from phytools' plotSimmap) 72 | } 73 | -------------------------------------------------------------------------------- /man/bayou-deprecated.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-deprecated.R, R/bayou-mcmc.R 3 | \name{bayou-deprecated} 4 | \alias{bayou-deprecated} 5 | \alias{bayou.mcmc} 6 | \title{Deprecated functions in package bayou.} 7 | \usage{ 8 | bayou.mcmc( 9 | tree, 10 | dat, 11 | SE = 0, 12 | model = "OU", 13 | prior, 14 | ngen = 10000, 15 | samp = 10, 16 | chunk = 100, 17 | control = NULL, 18 | tuning = NULL, 19 | new.dir = FALSE, 20 | plot.freq = 500, 21 | outname = "bayou", 22 | plot.fn = phenogram, 23 | ticker.freq = 1000, 24 | tuning.int = c(0.1, 0.2, 0.3), 25 | startpar = NULL, 26 | moves = NULL, 27 | control.weights = NULL, 28 | lik.fn = NULL 29 | ) 30 | } 31 | \arguments{ 32 | \item{tree}{a phylogenetic tree of class 'phylo'} 33 | 34 | \item{dat}{a named vector of continuous trait values matching the tips in tree} 35 | 36 | \item{SE}{The standard error of the data. Either a single value applied to all 37 | the data, or a vector of length(dat).} 38 | 39 | \item{model}{The parameterization of the OU model used. Either "OU" for standard parameterization with 40 | alpha and sigma^2; "OUrepar" for phylogenetic half-life and stationary variance (Vy), or "QG" for the 41 | Lande model, with parameters h^2 (heritability), P (phenotypic variance), omega^2 (width of adaptive 42 | landscape), and Ne (effective population size)} 43 | 44 | \item{prior}{A prior function of class 'priorFn' that gives the prior distribution of all parameters} 45 | 46 | \item{ngen}{The number of generations to run the Markov Chain} 47 | 48 | \item{samp}{The frequency at which Markov samples are retained} 49 | 50 | \item{chunk}{The number of samples retained in memory before being written to a file} 51 | 52 | \item{control}{A list providing a control object governing how often and which proposals are used} 53 | 54 | \item{tuning}{A named vector that governs how liberal or conservative proposals are that equals the 55 | number of proposal mechanisms.} 56 | 57 | \item{new.dir}{If TRUE, then results are stored in a new temporary directory. If FALSE, results are 58 | written to the current working directory. If a character string, 59 | then results are written to that working directory.} 60 | 61 | \item{plot.freq}{How often plots should be made during the mcmc. If NULL, then plots are not produced} 62 | 63 | \item{outname}{The prefix given to files created by the mcmc} 64 | 65 | \item{plot.fn}{Function used in plotting, defaults to phytools::phenogram} 66 | 67 | \item{ticker.freq}{How often a summary log should be printed to the screen} 68 | 69 | \item{tuning.int}{How often the tuning parameters should be adjusted as a fraction of the total 70 | number of generations (currently ignored)} 71 | 72 | \item{startpar}{A list with the starting parameters for the mcmc. If NULL, starting parameters are 73 | simulated from the prior distribution} 74 | 75 | \item{moves}{A named list providing the proposal functions to be used in the mcmc. Names correspond to 76 | the parameters to be modified in the parameter list. See 'details' for default values.} 77 | 78 | \item{control.weights}{A named vector providing the relative frequency each proposal mechanism is to 79 | be used during the mcmc} 80 | 81 | \item{lik.fn}{Likelihood function to be evaluated. Defaults to \code{bayou.lik}.} 82 | } 83 | \description{ 84 | The functions listed below are deprecated and will be defunct in 85 | the near future. When possible, alternative functions with similar 86 | functionality are also mentioned. Help pages for deprecated functions are 87 | available at \code{help("-deprecated")}. 88 | 89 | Runs a reversible-jump Markov chain Monte Carlo on continuous phenotypic data on a phylogeny, 90 | sampling possible shift locations and shift magnitudes, and shift numbers. 91 | } 92 | \section{\code{bayou.mcmc}}{ 93 | This function is deprecated, please use \code{\link{bayou.makeMCMC}}. 94 | } 95 | 96 | \keyword{internal} 97 | -------------------------------------------------------------------------------- /man/bayou.makeMCMC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-mcmc.R 3 | \name{bayou.makeMCMC} 4 | \alias{bayou.makeMCMC} 5 | \title{Revision of bayou.mcmc that only makes the mcmc loop function, rather than running it itself.} 6 | \usage{ 7 | bayou.makeMCMC( 8 | tree, 9 | dat, 10 | pred = NULL, 11 | SE = 0, 12 | model = "OU", 13 | prior, 14 | samp = 10, 15 | chunk = 100, 16 | control = NULL, 17 | tuning = NULL, 18 | file.dir = tempdir(), 19 | plot.freq = 500, 20 | outname = "bayou", 21 | plot.fn = phenogram, 22 | ticker.freq = 1000, 23 | startpar = NULL, 24 | moves = NULL, 25 | control.weights = NULL, 26 | lik.fn = NULL, 27 | perform.checks = TRUE 28 | ) 29 | } 30 | \arguments{ 31 | \item{tree}{a phylogenetic tree of class 'phylo'} 32 | 33 | \item{dat}{a named vector of continuous trait values matching the tips in tree} 34 | 35 | \item{pred}{A matrix or data frame with named columns with predictor data represented in the 36 | specified 37 | formula} 38 | 39 | \item{SE}{The standard error of the data. Either a single value applied to all the data, or a 40 | vector of length(dat).} 41 | 42 | \item{model}{The parameterization of the OU model used. Either "OU" for standard parameterization 43 | with alpha and sigma^2; "OUrepar" for phylogenetic half-life and stationary variance (Vy), or 44 | "QG" for the Lande model, with parameters h^2 (heritability), P (phenotypic variance), omega^2 45 | (width of adaptive landscape), and Ne (effective population size)} 46 | 47 | \item{prior}{A prior function of class 'priorFn' that gives the prior distribution of all 48 | parameters} 49 | 50 | \item{samp}{The frequency at which Markov samples are retained} 51 | 52 | \item{chunk}{The number of samples retained in memory before being written to a file} 53 | 54 | \item{control}{A list providing a control object governing how often and which proposals are used} 55 | 56 | \item{tuning}{A named vector that governs how liberal or conservative proposals are that equals 57 | the number of proposal mechanisms.} 58 | 59 | \item{file.dir}{If a character string, then results are written to that working directory. If NULL, 60 | then results are not saved to files, but instead held in memory. Default is `tempdir()`, which 61 | writes to an R temporary directory.} 62 | 63 | \item{plot.freq}{How often plots should be made during the mcmc. If NULL, then plots are not 64 | produced} 65 | 66 | \item{outname}{The prefix given to files created by the mcmc} 67 | 68 | \item{plot.fn}{Function used in plotting, defaults to phytools::phenogram} 69 | 70 | \item{ticker.freq}{How often a summary log should be printed to the screen} 71 | 72 | \item{startpar}{A list with the starting parameters for the mcmc. If NULL, starting parameters 73 | are simulated from the prior distribution} 74 | 75 | \item{moves}{A named list providing the proposal functions to be used in the mcmc. Names correspond 76 | to the parameters to be modified in the parameter list. See 'details' for default values.} 77 | 78 | \item{control.weights}{A named vector providing the relative frequency each proposal mechanism is 79 | to be used during the mcmc} 80 | 81 | \item{lik.fn}{Likelihood function to be evaluated. Defaults to \code{bayou.lik}.} 82 | 83 | \item{perform.checks}{A logical indicating whether to use bayou.checkModel to validate model inputs.} 84 | } 85 | \description{ 86 | Runs a reversible-jump Markov chain Monte Carlo on continuous phenotypic data 87 | on a phylogeny, sampling possible shift locations and 88 | shift magnitudes, and shift numbers. 89 | } 90 | \details{ 91 | By default, the alpha, sig2 (and various reparameterizations of these parameters) are adjusted 92 | with multiplier proposals, theta are adjusted with sliding window proposals, 93 | and the number of shifts is adjusted by splitting and merging, as well as sliding the shifts 94 | both within and between branches. Allowed shift locations are specified by the 95 | prior function (see make.prior()). 96 | } 97 | -------------------------------------------------------------------------------- /inst/tests/test-likelihood.r: -------------------------------------------------------------------------------- 1 | #context("can calculate likelihoods") 2 | testthat::test_that("can calculate likelihoods", { 3 | library(bayou) 4 | data(chelonia, package="geiger") 5 | tree <- chelonia$phy 6 | dat <- chelonia$dat 7 | cache <- bayou:::.prepare.ou.univariate(tree, dat, SE=0) 8 | pars <- list(alpha=0.01, sig2=1, k=3, ntheta=4, theta=c(3,4,5,6), sb= c(408, 399, 448), loc=c(8, 9, 31), t2=2:4) 9 | testthat::expect_true(is.finite(bayou.lik(pars, cache, dat)$loglik)) 10 | testthat::expect_equal(bayou.lik(pars, cache, dat)$loglik[1], OU.lik(pars, tree, dat)$loglik[1]) 11 | testthat::expect_equal(bayou.lik(pars, cache, dat)$loglik[1], -494.775911175547) 12 | ##Test Brownian motion works 13 | pars <- list(alpha=0, sig2=1, k=3, ntheta=4, theta=c(3,4,5,6), sb= c(408, 399, 448), loc=c(8, 9, 31), t2=2:4) 14 | #geiger_bm <- bm.lik(tree, dat, model="BM") 15 | #expect_that(OU.lik(pars, cache, dat)$loglik[1], equals(geiger_bm(c(pars$sig2, 0, pars$theta[1]), root=geiger:::ROOT.GIVEN)[1])) 16 | #expect_that(bayou.lik(pars, cache, dat)$loglik[1], equals(geiger_bm(c(pars$sig2, 0, pars$theta[1]), root=ROOT.GIVEN)[1])) 17 | ##Test QG parameterization 18 | QGpars <- list(h2=0.4, P=2, Ne=100, w2=10, k=3, ntheta=4, theta=c(3,4,5,6), sb= c(408, 399, 448), loc=c(8, 9, 31), t2=2:4) 19 | testthat::expect_equal(bayou.lik(QGpars, cache, dat, model="QG")$loglik[1], OU.lik(QGpars, tree, dat, model="QG")$loglik[1]) 20 | ##Test OUrepar parameterization 21 | OUrepars <- list(halflife=50, Vy=3, k=3, ntheta=4, theta=c(3,4,5,6), sb= c(408, 399, 448), loc=c(8, 9, 31), t2=2:4) 22 | testthat::expect_equal(bayou.lik(OUrepars, cache, dat, model="OUrepar")$loglik[1], OU.lik(OUrepars, tree, dat, model="OUrepar")$loglik[1]) 23 | ##Deprecated tests 24 | #expect_that(is.finite(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU")$loglik[1]),is_true()) 25 | #expect_that(emOU.lik(pars,emap,tree,dat,SE=0.1,model="OU")$loglik[1], 26 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 27 | #expect_that(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU")$loglik[1], 28 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 29 | #expect_that(.emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU")$loglik[1], 30 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 31 | #expect_that(emOU.lik(QGpars,emap,cache,dat,SE=0.1,model="QG")$loglik[1], 32 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 33 | #expect_that(.emOU.lik(QGpars,emap,cache,dat,SE=0.1,model="QG")$loglik[1], 34 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 35 | #expect_that(smOU.lik(pars,tree,dat,SE=0.1,model="OU")$loglik[1], 36 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 37 | #expect_that(smOU.lik(QGpars,tree,dat,SE=0.1,model="QG")$loglik[1], 38 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 39 | #expect_that(.smOU.lik(pars,cache,dat,SE=0.1,model="OU")$loglik[1], 40 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 41 | #expect_that(.smOU.lik(QGpars,cache,dat,SE=0.1,model="QG")$loglik[1], 42 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 43 | #pars$sb <- which(emap$sh==1) 44 | #pars$loc <- emap$r1[emap$sh==1] 45 | #pars$t2 <- emap$t2[emap$sh==1] 46 | #QGpars$sb <- which(emap$sh==1) 47 | #QGpars$loc <- emap$r1[emap$sh==1] 48 | #QGpars$t2 <- emap$t2[emap$sh==1] 49 | #expect_that(.OU.lik(pars,cache,dat,SE=0.1,model="OU")$loglik[1], 50 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 51 | #expect_that(OU.lik(pars,tree,dat,SE=0.1,model="OU")$loglik[1], 52 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 53 | #expect_that(.OU.lik(QGpars,cache,dat,SE=0.1,model="QG")$loglik[1], 54 | # equals(emOU.lik(pars,emap,cache,dat,SE=0.1,model="OU",method="invert")$loglik)) 55 | }) 56 | 57 | -------------------------------------------------------------------------------- /src/weightmatrix.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | using namespace arma; 8 | using namespace Rcpp; 9 | 10 | // [[Rcpp::depends("RcppArmadillo")]] 11 | 12 | // [[Rcpp::export]] 13 | SEXP C_weightmatrix(SEXP dat, SEXP parameters) 14 | { 15 | Rcpp::List cache(dat); 16 | Rcpp::List pars(parameters); 17 | int k = Rcpp::as(pars["k"]); 18 | int n = Rcpp::as(cache["n"]); 19 | arma::vec theta = Rcpp::as(pars["theta"]); 20 | arma::vec data = Rcpp::as(cache["dat"]); 21 | if(k==0){ 22 | arma::vec W(n); 23 | W.ones(); 24 | arma::vec Etheta = W * theta; 25 | arma::vec residuals = data - Etheta; 26 | return Rcpp::List::create( 27 | Rcpp::Named("W", W), 28 | Rcpp::Named("E", Etheta), 29 | Rcpp::Named("resid", residuals) 30 | ); 31 | } else { 32 | int N = Rcpp::as(cache["N"]); 33 | int ntheta = Rcpp::as(pars["ntheta"]); 34 | double alpha = Rcpp::as(pars["alpha"]); 35 | bool ultrametric = Rcpp::as(cache["ultrametric"]); 36 | arma::ivec sb = Rcpp::as(pars["sb"]); 37 | arma::ivec t2 = Rcpp::as(pars["t2"]); 38 | arma::vec loc = Rcpp::as(pars["loc"]); 39 | arma::vec len = Rcpp::as(cache["edge.length"]); 40 | arma::vec nH = Rcpp::as(cache["nH"]); 41 | arma::ivec anc = Rcpp::as(cache["anc"]); 42 | arma::ivec des = Rcpp::as(cache["des"]); 43 | arma::mat branchtrace = Rcpp::as(cache["branchtrace"]); 44 | arma::vec tipheight; 45 | if(ultrametric > 0){ 46 | tipheight = Rcpp::as(cache["height"]); 47 | } else { 48 | tipheight = Rcpp::as(cache["tipFromRoot"]); 49 | } 50 | arma::ivec start(N); 51 | start.ones(); 52 | arma::uvec l_ord = stable_sort_index(loc); 53 | sb = sb(l_ord); 54 | t2 = t2(l_ord); 55 | loc = loc(l_ord); 56 | arma::mat bW(N, ntheta); 57 | bW.zeros(); 58 | for(int i=N; i > 0; --i){ 59 | //int i = 15; 60 | arma::vec mstart; 61 | arma::ivec mtheta(1); 62 | arma::vec mend(1); 63 | mstart.zeros(1); 64 | mend(0) = len(i-1); 65 | arma::uvec ind = find(sb==i); 66 | mtheta(0) = start(i-1); 67 | arma::vec x = loc(ind); 68 | if(ind.n_rows > 0){ 69 | mstart.insert_rows(mstart.n_rows, loc(ind)); 70 | mend.insert_rows(0, loc(ind)); 71 | mtheta.insert_rows(mtheta.n_rows, t2(ind)); 72 | } 73 | arma::uvec desb = find(anc == des(i-1)); 74 | if(desb.n_rows >0){ 75 | start(desb(0)) = (mtheta(mtheta.n_rows-1)); 76 | start(desb(1)) = (mtheta(mtheta.n_rows-1)); 77 | } 78 | arma::vec mdiff = mend - mstart; 79 | arma::vec W1 = alpha*(nH(i-1) + mstart - tipheight.max()); 80 | arma::vec W2 = alpha * mdiff; 81 | for(int j=0; j < mstart.n_rows; ++j){ 82 | if(any(W2 > 500)){ 83 | if(W2(j) > 500){ 84 | bW.submat(i-1, mtheta(j)-1, i-1, mtheta(j)-1) = bW.submat(i-1, mtheta(j)-1, i-1, mtheta(j)-1) + exp(W1(j)+W2(j)); 85 | } else{ 86 | bW.submat(i-1, mtheta(j)-1, i-1, mtheta(j)-1) = bW.submat(i-1, mtheta(j)-1, i-1, mtheta(j)-1) + exp(W1(j)) * expm1(W2(j)); 87 | } 88 | } else { 89 | bW.submat(i-1, mtheta(j)-1, i-1, mtheta(j)-1) = bW.submat(i-1, mtheta(j)-1, i-1, mtheta(j)-1) + exp(W1(j)) * expm1(W2(j)); 90 | } 91 | } 92 | } 93 | arma::mat W(n, ntheta); 94 | arma::mat btrace; 95 | if(ultrametric==1){ 96 | arma::mat btrace = branchtrace; 97 | W = btrace * bW; 98 | W.col(0) = W.col(0) + as_scalar(exp(-alpha * tipheight)); 99 | } else { 100 | arma::mat btrace = branchtrace; 101 | for(int i=0; i < n; ++i){ 102 | btrace.row(i) = btrace.row(i) * exp(alpha * (tipheight.max() - tipheight(i))); 103 | } 104 | W = btrace * bW; 105 | W.col(0) = W.col(0) + exp(-alpha * tipheight); 106 | } 107 | arma::vec Etheta = W * theta; 108 | arma::vec residuals = data - Etheta; 109 | return Rcpp::List::create( 110 | Rcpp::Named("bW", bW), 111 | Rcpp::Named("W", W), 112 | Rcpp::Named("E", Etheta), 113 | Rcpp::Named("resid", residuals) 114 | ); 115 | } 116 | } 117 | 118 | 119 | -------------------------------------------------------------------------------- /man/make.prior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayou-prior.R 3 | \name{make.prior} 4 | \alias{make.prior} 5 | \title{Make a prior function for bayou} 6 | \usage{ 7 | make.prior( 8 | tree, 9 | dists = list(), 10 | param = list(), 11 | fixed = list(), 12 | plot.prior = TRUE, 13 | model = "OU" 14 | ) 15 | } 16 | \arguments{ 17 | \item{tree}{A tree object of class "phylo"} 18 | 19 | \item{dists}{A list providing the function names of the distribution functions describing the prior distributions of parameters (see details). If no 20 | distributions are provided for a parameter, default values are given. Note that the names are provided as text strings, not the functions themselves.} 21 | 22 | \item{param}{A list providing the parameter values of the prior distributions (see details).} 23 | 24 | \item{fixed}{A list of parameters that are to be fixed at provided values. These are removed from calculation of the prior value.} 25 | 26 | \item{plot.prior}{A logical indicating whether the prior distributions should be plotted.} 27 | 28 | \item{model}{One of three specifications of the OU parameterization used. 29 | Takes values \code{"OU"} (alpha & sig2), \code{"QG"} (h2, P, w2, Ne), or \code{"OUrepar"} (halflife,Vy)} 30 | } 31 | \value{ 32 | returns a prior function of class "priorFn" that calculates the log prior density for a set of parameter values provided in a list with correctly named values. 33 | } 34 | \description{ 35 | This function generates a prior function to be used for bayou according to user specifications. 36 | } 37 | \details{ 38 | Default distributions and parameter values are given as follows: 39 | OU: \code{list(dists=list("dalpha"="dlnorm","dsig2"="dlnorm", 40 | "dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dunif"), 41 | param=list("dalpha"=list(),"dsig2"=list(),"dtheta"=list(), 42 | "dk"=list(lambda=1,kmax=2*ntips-2),"dloc"=list(min=0,max=1),"dsb"=list()))} 43 | QG: \code{list(dists=list("dh2"="dbeta","dP"="dlnorm","dw2"="dlnorm","dNe"="dlnorm", 44 | "dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dunif"), 45 | param=list("dh2"=list(shape1=1,shape2=1),"dP"=list(),"dw2"=list(),"dNe"=list(),"dtheta"=list(), 46 | "dk"=list(lambda=1,kmax=2*ntips-2),"dloc"=list(min=0,max=1),"dsb"=list()))} 47 | OUrepar: \code{list(dists=list("dhalflife"="dlnorm","dVy"="dlnorm", 48 | "dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dunif"), 49 | param=list("dhalflife"=list("meanlog"=0.25,"sdlog"=1.5),"dVy"=list("meanlog"=1,"sdlog"=2), 50 | "dk"=list(lambda=1,kmax=2*ntips-2),"dtheta"=list(),"dloc"=list(min=0,max=1)),"dsb"=list())} 51 | 52 | \code{dalpha, dsig2, dh2, dP, dw2, dNe, dhalflife}, and \code{dVy} must be positive continuous distributions and provide the parameters used to calculate alpha and sigma^2 of the OU model. 53 | \code{dtheta} must be continuous and describes the prior distribution of the optima. dk is the prior distribution for the number of shifts. For Poisson and conditional Poisson (cdpois) are provided 54 | the parameter \code{lambda}, which provides the total number of shifts expected on the tree (not the rate per unit branch length). Otherwise, \code{dk} can take any positive, discrete distribution. 55 | dsb indicates the prior probability of a given set of branches having shifts, and is generally specified by the "dsb" function in the bayou package. See the documentation for dsb for specifying the number 56 | of shifts allowed per branch, the probability of a branch having a shift, and specifying constraints on where shifts can occur.\code{"dloc"} indicates the prior probability of the location of a shift within 57 | a single branch. Currently, all locations are given uniform density. All distributions are set to return log-transformed probability densities. 58 | } 59 | \examples{ 60 | ## Load data 61 | data(chelonia) 62 | tree <- chelonia$phy 63 | dat <- chelonia$dat 64 | 65 | #Create a prior that allows only one shift per branch with equal probability 66 | #across branches 67 | prior <- make.prior(tree, dists=list(dalpha="dlnorm", dsig2="dlnorm", 68 | dsb="dsb", dk="cdpois", dtheta="dnorm"), 69 | param=list(dalpha=list(meanlog=-5, sdlog=2), 70 | dsig2=list(meanlog=-1, sdlog=5), dk=list(lambda=15, kmax=200), 71 | dsb=list(bmax=1,prob=1), dtheta=list(mean=mean(dat), sd=2))) 72 | 73 | #Evaluate some parameter sets 74 | pars1 <- list(alpha=0.1, sig2=0.1, k=5, ntheta=6, theta=rnorm(6, mean(dat), 2), 75 | sb=c(32, 53, 110, 350, 439), loc=rep(0.1, 5), t2=2:6) 76 | pars2 <- list(alpha=0.1, sig2=0.1, k=5, ntheta=6, theta=rnorm(6, mean(dat), 2), 77 | sb=c(43, 43, 432, 20, 448), loc=rep(0.1, 5), t2=2:6) 78 | prior(pars1) 79 | prior(pars2) #-Inf because two shifts on one branch 80 | 81 | #Create a prior that allows any number of shifts along each branch with probability proportional 82 | #to branch length 83 | prior <- make.prior(tree, dists=list(dalpha="dlnorm", dsig2="dlnorm", 84 | dsb="dsb", dk="cdpois", dtheta="dnorm"), 85 | param=list(dalpha=list(meanlog=-5, sdlog=2), 86 | dsig2=list(meanlog=-1, sdlog=5), dk=list(lambda=15, kmax=200), 87 | dsb=list(bmax=Inf,prob=tree$edge.length), 88 | dtheta=list(mean=mean(dat), sd=2))) 89 | prior(pars1) 90 | prior(pars2) 91 | 92 | #Create a prior with fixed regime placement and sigma^2 value 93 | prior <- make.prior(tree, dists=list(dalpha="dlnorm", dsig2="fixed", 94 | dsb="fixed", dk="fixed", dtheta="dnorm", dloc="dunif"), 95 | param=list(dalpha=list(meanlog=-5, sdlog=2), 96 | dtheta=list(mean=mean(dat), sd=2)), 97 | fixed=list(sig2=1, k=3, ntheta=4, sb=c(447, 396, 29))) 98 | 99 | pars3 <- list(alpha=0.01, theta=rnorm(4, mean(dat), 2), loc=rep(0.1, 4)) 100 | prior(pars3) 101 | 102 | ##Return a list of functions used to calculate prior 103 | attributes(prior)$functions 104 | 105 | ##Return parameter values used in prior distribution 106 | attributes(prior)$parameters 107 | } 108 | -------------------------------------------------------------------------------- /src/threepoint.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | using namespace arma; 6 | using namespace Rcpp; 7 | 8 | // [[Rcpp::depends("RcppArmadillo")]] 9 | 10 | // [[Rcpp::export]] 11 | SEXP C_threepoint(SEXP dat) 12 | { 13 | Rcpp::List cache(dat); 14 | int root = Rcpp::as(cache["root"]); 15 | int n = Rcpp::as(cache["n"]); 16 | int N = Rcpp::as(cache["N"]); 17 | int Nnode = N - n + 1; 18 | int ROOT = n ; 19 | arma::vec len = Rcpp::as(cache["len"]); 20 | arma::vec diagm = Rcpp::as(cache["diagMatrix"]); 21 | arma::vec P = Rcpp::as(cache["P"]); 22 | std::vector anc = Rcpp::as >(cache["anc"]); 23 | std::vector des = Rcpp::as >(cache["des"]); 24 | int rowP = P.n_rows; 25 | int des_i, anc_i; 26 | arma::mat Pm; 27 | Pm.ones(rowP, 2); 28 | Pm.col(1) = P; 29 | arma::mat P_dm = Pm; 30 | P_dm.col(0) = P_dm.col(0) / diagm; 31 | P_dm.col(1) = P_dm.col(1) / diagm; 32 | arma::cube PP; 33 | PP.zeros(2, 2, n + Nnode); 34 | arma::vec zero, tmp11, logd; 35 | arma::mat P_dm_des, pp, tmpP1, tmp; 36 | tmpP1.zeros(2, n + Nnode); 37 | P_dm_des.zeros(1, 2); 38 | pp.zeros(2,2); 39 | zero = tmp11 = logd = zeros(n + Nnode); 40 | double el; 41 | //double tmp2; 42 | for (int i=0; i 0){ 48 | logd[des_i] = log(el); 49 | P_dm_des = P_dm.row(des_i); 50 | pp = P_dm_des.t() * P_dm_des; 51 | PP.subcube(0, 0, des_i, 1, 1, des_i) = pp / el; 52 | tmpP1.col(des_i) = trans(P_dm.row(des_i) / el); 53 | tmp11(des_i) = 1/el; 54 | } else zero(anc_i) = zero(anc_i) + 1; 55 | } else { 56 | if((el <= 0 && zero(des_i) > 0) || zero(des_i) >1) break; 57 | logd(des_i) = logd(des_i) + log(1+el*tmp11(des_i)); 58 | tmp = tmpP1.col(des_i) * trans(tmpP1.col(des_i)); 59 | //tmp2 = el/(1 + el * tmp11(des_i)); 60 | tmp *= el/(1 + el * tmp11(des_i)); 61 | PP.subcube(0, 0, des_i, 1, 1, des_i) += -1*tmp; 62 | tmpP1.col(des_i) *= (1 - 1/(1+1/el/tmp11(des_i))); 63 | tmp11(des_i) *= (1 - 1/(1+1/el/tmp11(des_i))); 64 | }; 65 | logd(anc_i) += logd(des_i); 66 | PP.subcube(0, 0, anc_i, 1, 1, anc_i) += PP.subcube(0, 0, des_i, 1, 1, des_i); 67 | tmpP1.col(anc_i) += tmpP1.col(des_i); 68 | tmp11(anc_i) += tmp11(des_i); 69 | } 70 | logd(ROOT) += log(1+root*tmp11(ROOT)) + 2*sum(log(diagm)); 71 | PP.subcube(0, 0, ROOT, 1, 1, ROOT) += -1*root/(1+root*tmp11(ROOT))*tmpP1.col(ROOT)*trans(tmpP1.col(ROOT)); 72 | arma::vec vec11, vecPP, vecP1; 73 | vec11 = PP.subcube(0,0,ROOT,0,0,ROOT); 74 | vecP1 = PP.subcube(0,1,ROOT,0,1,ROOT); 75 | vecPP = PP.subcube(1,1,ROOT,1,1,ROOT); 76 | return Rcpp::List::create( 77 | Rcpp::Named("P_dm", P_dm), 78 | Rcpp::Named("tmpP1", tmpP1), 79 | Rcpp::Named("vec11", vec11), 80 | Rcpp::Named("P1", vecP1), 81 | Rcpp::Named("PP", vecPP), 82 | Rcpp::Named("logd", logd(ROOT)) 83 | ); 84 | } 85 | 86 | // [[Rcpp::export]] 87 | SEXP C_transf_branch_lengths(SEXP dat, int model, NumericVector y, double alpha) 88 | { 89 | Rcpp::List cache(dat); 90 | int N = Rcpp::as(cache["N"]); 91 | int n = Rcpp::as(cache["n"]); 92 | LogicalVector externalEdge = Rcpp::as(cache["externalEdge"]); 93 | arma::vec times = Rcpp::as(cache["times"]); 94 | arma::vec D = Rcpp::as(cache["D"]); 95 | std::vector banc = Rcpp::as >(cache["branches.anc2"]); 96 | std::vector bdes = Rcpp::as >(cache["branches.des2"]); 97 | std::vector anc = Rcpp::as >(cache["anc"]); 98 | std::vector des = Rcpp::as >(cache["des"]); 99 | double Tmax = Rcpp::as(cache["Tmax"]); 100 | //int anc_i, des_i, banc_i, bdes_i; 101 | int des_i, banc_i, bdes_i; 102 | double d1, d2, root; 103 | arma::vec len, distFromRoot, exp_times, diagMatrix; 104 | if(alpha==0){ 105 | len = Rcpp::as(cache["edge.length"]); 106 | root = 0; 107 | diagMatrix.ones(n); 108 | } else { 109 | if(model == 1){ 110 | len.zeros(N); 111 | exp_times = exp(-2*alpha*times); 112 | distFromRoot = (1 - exp(-2 * alpha * (Tmax - times))); 113 | distFromRoot %= exp_times; 114 | for (int i=0; i 0){ 84 | maps <- pars2simmap(simpar[[i]],tree) 85 | plotRegimes(maps$tree, ...) 86 | } else { 87 | plot(tree, ...) 88 | } 89 | } 90 | } 91 | return(list(pars=simpar,tree=tree)) 92 | } 93 | 94 | #' Simulates data from bayou models 95 | #' 96 | #' \code{dataSim} Simulates data for a given bayou model and parameter set 97 | #' 98 | #' @param pars A bayou formated parameter list 99 | #' @param model The type of model specified by the parameter list (either "OU", "OUrepar" or "QG"). 100 | #' @param tree A tree of class 'phylo' 101 | #' @param map.type Either "pars" if the regimes are taken from the parameter list, or "simmap" if taken from the stored simmap in the tree 102 | #' @param SE A single value or vector equal to the number of tips specifying the measurement error that should be simulated at the tips 103 | #' @param phenogram A logical indicating whether or not the simulated data should be plotted as a phenogram 104 | #' @param ... Optional parameters passed to \code{phenogram(...)}. 105 | #' 106 | #' @description This function simulates data for a given set of parameter values. 107 | #' 108 | #' @export 109 | dataSim <- function(pars, model, tree, map.type="pars", SE=0, 110 | phenogram=TRUE, ...){ 111 | if(model %in% c("QG")){ 112 | pars$alpha <- QG.alpha(pars) 113 | pars$sig2 <- QG.sig2(pars) 114 | } 115 | if(model %in% c("OUrepar")){ 116 | p <- OU.repar(pars) 117 | pars$alpha <- p$alpha 118 | pars$sig2 <- p$sig2 119 | } 120 | if(map.type=="simmap"){ 121 | print("Using mapped regimes from ape tree file") 122 | maps <- tree$maps 123 | } 124 | if(map.type=="pars"){ 125 | print("Using mapped regimes from parameter list") 126 | maps <- pars2simmap(pars, tree)$tree$maps 127 | } 128 | dummy <- rep(0, length(tree$tip.label)) 129 | names(dummy) <- tree$tip.label 130 | tree$maps <- maps 131 | cache <- .prepare.ou.univariate(tree,dummy) 132 | cache$maps <- maps 133 | W <- .simmap.W(cache,pars) 134 | if(pars$k > 0){ 135 | E.th <- W%*%pars$theta 136 | } else {E.th <- W*pars$theta} 137 | Sigma <- .ouMatrix(vcv.phylo(tree),pars$alpha)*pars$sig2 138 | diag(Sigma) <- diag(Sigma)+SE 139 | X <- mvrnorm(1,E.th,Sigma) 140 | if(phenogram){ 141 | col <- c(1,rainbow(pars$k)) 142 | names(col) <- 1:pars$ntheta 143 | phenogram(cache$phy,X,colors=col, spread.labels=FALSE, ...) 144 | } 145 | return(list(W=W, E.th=E.th,dat=X)) 146 | } 147 | 148 | -------------------------------------------------------------------------------- /R/conversion-utilities.R: -------------------------------------------------------------------------------- 1 | #' Convert a bayou parameter list into a simmap formatted phylogeny 2 | #' 3 | #' \code{pars2simmap} takes a list of parameters and converts it to simmap format 4 | #' 5 | #' @param pars A list that contains \code{sb} (a vector of branches with shifts), \code{loc} (a vector of shift locations), 6 | #' \code{t2} (a vector of theta indices indicating which theta is present after the shift). 7 | #' @param tree A tree of class 'phylo' 8 | #' 9 | #' @description This function converts a bayou formatted parameter list specifying regime locations into a simmap formatted tree that can 10 | #' be plotted using \code{plotSimmap} from phytools or the \code{plotRegimes} function from bayou. 11 | #' 12 | #' @return A list with elements: \code{tree} A simmap formatted tree, \code{pars} bayou formatted parameter list, and \code{cols} A named vector of colors. 13 | #' 14 | #' @examples 15 | #' tree <- reorder(sim.bdtree(n=100), "postorder") 16 | #' 17 | #' pars <- list(k=5, sb=c(195, 196, 184, 138, 153), loc=rep(0, 5), t2=2:6) 18 | #' tr <- pars2simmap(pars, tree) 19 | #' plotRegimes(tr$tree, col=tr$col) 20 | #' @export 21 | pars2simmap <- function(pars,tree){ 22 | tree <- reorder(tree, "postorder") 23 | sb <- pars$sb 24 | loc <- pars$loc 25 | t2 <- pars$t2 26 | if(!all(pars$sb %in% 1:nrow(tree$edge))) stop("Invalid parameter list. Specified branches not found in the tree") 27 | if(!all(pars$loc < tree$edge.length[pars$sb])) stop("Invalid parameter list. Some shift locations specified beyond the length of the branch") 28 | Th <- NULL 29 | nbranch <- length(tree$edge.length) 30 | maps <- lapply(tree$edge.length,function(x){y <- x; names(y) <- 1; y}) 31 | dup <- which(duplicated(sb)) 32 | if(pars$k > 0){ 33 | if(length(dup)>0){ 34 | maps[sb[-dup]] <- lapply(1:length(sb[-dup]),.addshift2map,maps=maps,sb=sb[-dup],loc=loc[-dup],t2=t2[-dup]) 35 | } else { 36 | maps[sb] <- lapply(1:length(sb),.addshift2map,maps=maps,sb=sb,loc=loc,t2=t2) 37 | } 38 | for(i in dup){ 39 | maps[[sb[i]]] <-.addshift2map(i,maps=maps,sb=sb,loc=loc,t2=t2) 40 | } 41 | nopt <- rep(1,nbranch) 42 | for(i in nbranch:1){ 43 | if(i %in% sb){ 44 | opt <- as.integer(names(maps[[i]])[length(maps[[i]])]) 45 | nopt[tree$edge[i,2]] <- opt 46 | names(maps[[i]])[1] <- nopt[tree$edge[i,1]] 47 | } else { 48 | names(maps[[i]])[1] <- nopt[tree$edge[i,1]] 49 | nopt[tree$edge[i,2]] <- nopt[tree$edge[i,1]] 50 | } 51 | } 52 | shiftdown <- nopt[tree$edge[,1]] 53 | new.maps <- lapply(1:nbranch,function(x){names(maps[[x]])[1] <- shiftdown[x]; maps[[x]]}) 54 | new.maps <- maps 55 | for(j in 1:nbranch){ 56 | names(new.maps[[j]])[1] <-shiftdown[j] 57 | } 58 | anc.theta <- unlist(lapply(new.maps[sb],function(x) as.integer(names(x)[length(x)-1])),F,F) 59 | o <- rev(order(sb,loc*-1)) 60 | shifted.maps <- new.maps[sb[o]] 61 | t1 <- rep(NA,length(t2)) 62 | for(i in 1:length(t2)){ 63 | nm <- as.integer(names(maps[[sb[o][i]]])) 64 | t1[nm[2:length(nm)]-1] <- nm[1:(length(nm)-1)] 65 | Th[t2[o[i]]] <- Th[t1[o[i]]] 66 | } 67 | } else { 68 | new.maps <- maps 69 | } 70 | new.tree <- tree 71 | new.tree$maps <- new.maps 72 | new.pars <- pars 73 | col <- c(1,rainbow(pars$k)) 74 | names(col) <- 1:(pars$k+1) 75 | return(list(tree=new.tree,pars=new.pars,col=col)) 76 | } 77 | 78 | ## New version of .pars2map is faster, returns 3 elements rather than 2 named elements 79 | .pars2map <- function(pars, cache){ 80 | nbranch <- length(cache$edge.length) 81 | nshifts <- table(pars$sb) 82 | shifts <- rep(0,nbranch) 83 | shifts[as.numeric(attributes(nshifts)$dimnames[[1]])]<- nshifts 84 | irow <- rep(1:nbranch,shifts+1) 85 | segs <- c(cache$edge.length, pars$loc) 86 | tmp.o <- c(1:nbranch, pars$sb) 87 | #names(segs) <- tmp.o 88 | add.o <- order(tmp.o,segs) 89 | segs <- segs[add.o] 90 | ind <- tmp.o[add.o] 91 | #ind <- tmp.o 92 | t2index <- add.o[which(add.o > nbranch)] 93 | t2b <- c(rep(1,length(segs))) 94 | t2b[match(t2index,add.o)+1] <- pars$t2[t2index-nbranch] 95 | loc.o <- order(pars$loc,decreasing=TRUE) 96 | sandwiches <- loc.o[which(duplicated(pars$sb[loc.o]))] 97 | if(length(sandwiches)>0){ 98 | sb.down <- pars$sb[-sandwiches] 99 | t2.down <- pars$t2[-sandwiches] 100 | } else {sb.down <- pars$sb; t2.down <- pars$t2} 101 | sb.o <- order(sb.down) 102 | sb.down <- sb.down[sb.o] 103 | t2.down <- t2.down[sb.o] 104 | sb.desc <- cache$bdesc[sb.down] 105 | desc.length <- unlist(lapply(sb.desc, length),F,F) 106 | sb.desc <- sb.desc[which(desc.length>0)] 107 | #names(t2b) <- names(segs) 108 | sb.desc2 <- unlist(sb.desc,F,F) 109 | sb.dup <- duplicated(sb.desc2) 110 | sb.desc3 <- sb.desc2[which(!sb.dup)] 111 | t2.names <- rep(t2.down[which(desc.length>0)], unlist(lapply(sb.desc,length),F,F)) 112 | t2.names <- t2.names[which(!sb.dup)] 113 | #t2b[as.character(unlist(sb.desc3,F,F))] <- t2.names 114 | t2b[match(sb.desc3, ind)] <- t2.names 115 | base <- duplicated(ind)*c(0,segs[1:(length(segs)-1)]) 116 | segs <- segs-base 117 | #maps <- lapply(1:nbranch, function(x) segs[ind==x]) 118 | #maps <- lapply(maps, function(x) if(length(x) >1) {c(x[1],diff(x[1:length(x)]))} else x) 119 | return(list(segs=segs,theta=t2b, branch=ind)) 120 | } 121 | 122 | #' Calculates the alpha parameter from a QG model 123 | #' 124 | #' @param pars A bayou formatted parameter list with parameters h2 (heritability), P (phenotypic variance) and w2 (width of adaptive landscape) 125 | #' 126 | #' @return An alpha value according to the equation \code{alpha = h2*P/(P+w2+P)}. 127 | QG.alpha <- function(pars){ 128 | pars$h2*pars$P/(pars$P+pars$w2*pars$P) 129 | } 130 | 131 | #' Calculates the sigma^2 parameter from a QG model 132 | #' 133 | #' @param pars A bayou formatted parameter list with parameters h2 (heritability), P (phenotypic variance) and Ne (Effective population size) 134 | #' 135 | #' @return An sig2 value according to the equation \code{alpha = h2*P/(Ne)}. 136 | QG.sig2 <- function(pars){ 137 | (pars$h2*pars$P)/pars$Ne 138 | } 139 | 140 | 141 | #' Calculates the alpha and sigma^2 from a parameter list with supplied phylogenetic half-life and stationary variance 142 | #' 143 | #' @param pars A bayou formatted parameter list with parameters halflife (phylogenetic halflife) and Vy (stationary variance) 144 | #' 145 | #' @return A list with values for alpha and sig2. 146 | OU.repar <- function(pars){ 147 | alpha <- log(2)/pars$halflife 148 | sig2 <- (2*log(2)/(pars$halflife))*pars$Vy 149 | return(list(alpha=alpha,sig2=sig2)) 150 | } 151 | 152 | .toSimmap <- function(map, cache){ 153 | maps <- lapply(1:length(cache$edge.length), function(x){ y <- map$segs[which(map$branch==x)]; names(y) <- map$theta[which(map$branch==x)]; y }) 154 | tree <- cache$phy 155 | tree$maps <- maps 156 | return(tree) 157 | } 158 | 159 | #' Converts OUwie data into bayou format 160 | #' 161 | #' \code{OUwie2bayou} Converts OUwie formatted data into a bayou formatted parameter list 162 | #' 163 | #' @param tree A phylogenetic tree with states at internal nodes as node labels 164 | #' @param trait A data frame in OUwie format 165 | #' 166 | #' @return A bayou formatted parameter list 167 | #' @export 168 | OUwie2bayou <- function(tree, trait){ 169 | tree <- reorder(tree, 'postorder') 170 | tip.states <- trait[,2] 171 | names(tip.states) <- trait[,1] 172 | states <- c(tip.states[tree$tip.label], tree$node.label) 173 | states <- unname(states) 174 | e1 <- states[tree$edge[,1]] 175 | e2 <- states[tree$edge[,2]] 176 | sb <- which(e1 != e2) 177 | loc <- 0.5*tree$edge.length[sb] 178 | t2 <- as.numeric(factor(e2[sb]))+1 179 | k <- length(sb) 180 | ntheta <- length(unique(t2))+1 181 | pars <- list(k=k, ntheta=ntheta, sb=sb, loc=loc, t2=t2) 182 | class(pars) <- c("bayoupars","list") 183 | return(pars) 184 | } 185 | 186 | #' Converts bayou data into OUwie format 187 | #' 188 | #' \code{bayou2OUwie} Converts a bayou formatted parameter list into OUwie formatted tree and data table that can be analyzed in OUwie 189 | #' 190 | #' @param pars A list with parameter values specifying \code{sb} = the branches with shifts, 191 | #' \code{loc} = the location on branches where a shift occurs and \code{t2} = the optima to which 192 | #' descendants of that shift inherit 193 | #' @param tree A phylogenetic tree 194 | #' @param dat A vector of tip states 195 | #' 196 | #' @return A list with an OUwie formatted tree with mapped regimes and an OUwie formatted data table 197 | #' @export 198 | bayou2OUwie <- function(pars, tree, dat){ 199 | if(is.null(names(dat))){ 200 | warning("No labels on trait data, assuming the same order as the tip labels") 201 | } else {dat <- dat[tree$tip.label]} 202 | ntips <- length(tree$tip.label) 203 | cache <- .prepare.ou.univariate(tree, dat) 204 | tr <- .toSimmap(.pars2map(pars, cache),cache) 205 | tips <- which(tr$edge[,2] <= ntips) 206 | node.states <- sapply(tr$maps, function(x) names(x)[1]) 207 | names(node.states) <- tr$edge[,1] 208 | node.states <- rev(node.states[unique(names(node.states))]) 209 | tr$node.label <- as.numeric(node.states) 210 | tip.states <- sapply(tr$maps[tips], function(x) names(x)[length(x)]) 211 | names(tip.states) <- tr$tip.label[tr$edge[tips,2]] 212 | tip.states <- as.numeric(tip.states[tr$tip.label]) 213 | OUwie.dat <- data.frame("Genus_species"=tr$tip.label, "Reg"= tip.states, "X"= dat) 214 | rownames(OUwie.dat) <- NULL 215 | return(list(tree=tr, dat=OUwie.dat)) 216 | } 217 | 218 | 219 | -------------------------------------------------------------------------------- /R/probability.R: -------------------------------------------------------------------------------- 1 | #' Conditional Poisson distribution 2 | #' 3 | #' \code{cdpois} calculates the probability density of a value \code{k} from a 4 | #' Poisson distribution with a maximum \code{kmax}. \code{rdpois} draws random 5 | #' numbers from a conditional Poisson distribution. 6 | #' 7 | #' @rdname cdpois 8 | #' @param k random variable value 9 | #' @param n number of samples to draw 10 | #' @param kmax maximum value of the conditional Poisson distribution 11 | #' @param log log transformed density 12 | #' @param lambda rate parameter of the Poisson distribution 13 | #' @param ... additional parameters passed to \code{dpois} or \code{rpois} 14 | #' @export 15 | #' @examples 16 | #' cdpois(10,1,10) 17 | #' cdpois(11,1,10) 18 | #' #rdpois(5,10,10) 19 | cdpois <- function(k,lambda,kmax,log=TRUE){ 20 | if(kmax < lambda) stop("lambda is too high relative to kmax") 21 | kmax <- ceiling(kmax) 22 | i <- 0:kmax 23 | R <- sum(dpois(i,lambda)) 24 | num <- ifelse(k<=kmax, dpois(k,lambda), 0) 25 | if(log){ 26 | log(num/R) 27 | } else {num/R } 28 | } 29 | #' @rdname cdpois 30 | #' @export 31 | rdpois <- function(n,lambda,kmax, ...){ 32 | kmax <- ceiling(kmax) 33 | i=rep(kmax+1,n) 34 | j=0 35 | while(any(i>kmax)){ 36 | i[i>kmax] <- rpois(sum(i>kmax),lambda, ...) 37 | j <- j+1 38 | if(j>100){stop ("Lambda too high relative to kmax")} 39 | } 40 | return(i) 41 | } 42 | #' Probability density functions for bayou 43 | #' 44 | #' \code{dsb} calculates the probability of a particular arrangement of shifts 45 | #' for a given set of assumptions. 46 | #' 47 | #' @rdname dsb 48 | #' @param sb A vector giving the branch numbers (for a post-ordered tree) 49 | #' @param ntips The number of tips in the phylogeny 50 | #' @param bmax A single integer or a vector of integers equal to the number of 51 | #' branches in the phylogeny indicating the 52 | #' maximum number of shifts allowable in the phylogeny. Can take values 0, 1 and Inf. 53 | #' @param prob A single value or a vector of values equal to the number of branches 54 | #' in the phylogeny indicating the probability that 55 | #' a randomly selected shift will lie on this branch. Can take any positive value, 56 | #' values need not sum to 1 (they will be scaled to sum to 1) 57 | #' @param log A logical indicating whether the log probability should be returned. 58 | #' Default is 'TRUE' 59 | #' @param k The number of shifts to randomly draw from the distribution 60 | #' 61 | #' @description This function provides a means to specify the prior for the location 62 | #' of shifts across the phylogeny. Certain combinations are not 63 | #' allowed. For example, a maximum shift number of Inf on one branch cannot be combined 64 | #' with a maximum shift number of 1 on another. Thus, bmax must be 65 | #' either a vector of 0's and Inf's or a vector of 0's and 1's. Also, if bmax == 1, 66 | #' then all probabilities must be equal, as bayou cannot sample unequal 67 | #' probabilities without replacement. 68 | #' 69 | #' @return The log density of the particular number and arrangement of shifts. 70 | #' 71 | #' @examples 72 | #' n=10 73 | #' tree <- sim.bdtree(n=n) 74 | #' tree <- reorder(tree, "postorder") 75 | #' nbranch <- 2*n-2 76 | #' sb <- c(1,2, 2, 3) 77 | #' 78 | #' # Allow any number of shifts on each branch, with probability 79 | #' # proportional to branch length 80 | #' dsb(sb, ntips=n, bmax=Inf, prob=tree$edge.length) 81 | #' 82 | #' # Disallow shifts on the first branch, returns -Inf because sb[1] = 1 83 | #' dsb(sb, ntips=n, bmax=c(0, rep(1, nbranch-1)), prob=tree$edge.length) 84 | #' 85 | #' # Set maximum number of shifts to 1, returns -Inf because two shifts 86 | #' # are on branch 2 87 | #' dsb(sb, ntips=n, bmax=1, prob=1) 88 | #' 89 | #' # Generate a random set of k branches 90 | #' rsb(5, ntips=n, bmax=Inf, prob=tree$edge.length) 91 | #' @export 92 | dsb <- function(sb, ntips=ntips, bmax=1, prob=1, log=TRUE){ 93 | if(any(!(bmax %in% c(0,1,Inf)))) stop("Number of shifts allowed per branch must be 0, 1, or Inf") 94 | if(length(bmax)==1) bmax <- rep(bmax, 2*ntips-2) 95 | if(length(bmax)!=(2*ntips-2)) stop ("bmax not a multiple of the number of branches") 96 | sbt <- table(sb) 97 | if(any(sbt > bmax[as.numeric(names(sbt))])){ 98 | dens <- 0 99 | if(log) return(log(0)) else 0 100 | } else { 101 | if(max(bmax)==1){ 102 | if(length(prob)>1) warning("cannot sample unequal probabilities without replacement, assuming equal probabilities for each branch") 103 | dens <- 1/choose(sum(bmax),sum(sbt)) 104 | if(log) return(log(dens)) else return(dens) 105 | } else { 106 | if(any(!(bmax %in% c(0,Inf)))) stop("Cannot sample unequal probabilities without replacement") 107 | if(length(prob)==1) prob <- rep(1,2*ntips-2) 108 | if(length(prob)!=2*ntips-2) stop("Number of probabilities provided must equal number of branches") 109 | prob[bmax==0] <- 0 110 | sbp.all <- prob/sum(prob) 111 | sbp <- c(sbp.all[as.numeric(names(sbt))],1-sum(sbp.all[as.numeric(names(sbt))])) 112 | if(log) return(dmultinom(c(sbt,0),prob=sbp,log=TRUE)) else return(dmultinom(c(sbt,0),prob=sbp)) 113 | } 114 | } 115 | } 116 | #' @rdname dsb 117 | #' @export 118 | rsb <- function(k, ntips=ntips, bmax=1, prob=1, log=TRUE){ 119 | if(any(!(bmax %in% c(0,1,Inf)))) stop("Number of shifts allowed per branch must be 0, 1, or Inf") 120 | if(length(bmax)==1) bmax <- rep(bmax, 2*ntips-2) 121 | if(length(bmax)!=(2*ntips-2)) stop ("bmax not a multiple of the number of branches") 122 | if(max(bmax)==1){ 123 | if(length(prob)>1) warning("cannot sample unequal probabilities without replacement, assuming equal probabilities for each branch") 124 | sb <- .sample((1:(2*ntips-2))[bmax==1], k, replace=FALSE) 125 | return(sb) 126 | } else { 127 | if(any(!(bmax %in% c(0,Inf)))) stop("Cannot sample unequal probabilities without replacement") 128 | if(length(prob)==1) prob <- rep(1,2*ntips-2) 129 | if(length(prob)!=2*ntips-2) stop("Number of probabilities provided must equal number of branches") 130 | prob[bmax==0] <- 0 131 | sbp.all <- prob/sum(prob) 132 | sb <- suppressWarnings(.sample((1:(2*ntips-2)), k, prob=sbp.all, replace=TRUE)) 133 | return(sb) 134 | } 135 | } 136 | 137 | #' Probability density function for the location of the shift along the branch 138 | #' 139 | #' \code{dloc} calculates the probability of a shift occuring at a given 140 | #' location along the branch assuming a uniform distribution of unit length 141 | #' \code{rloc} randomly generates the location of a shift along the branch 142 | #' 143 | #' @param loc The location of the shift along the branch 144 | #' @param min The minimum position on the branch the shift can take 145 | #' @param max The maximum position on the branch the shift can take 146 | #' @param log A logical indicating whether the log density should be returned 147 | #' @param k The number of shifts to return along a branch 148 | #' 149 | #' @description Since unequal probabilities are incorporated in calculating the 150 | #' density via \code{dsb}, all branches are assumed to be of unit length. 151 | #' Thus, the \code{dloc} function simply returns 0 if \code{log=TRUE} and 1 if \code{log=FALSE}. 152 | #' @rdname dloc 153 | #' @export 154 | dloc <- function(loc,min=0,max=1,log=TRUE) if(log) return (rep(0,length(loc))) else return(rep(1,length(loc))) 155 | #' @rdname dloc 156 | #' @export 157 | rloc <- function(k,min=0,max=1){ 158 | return(runif(k)) 159 | } 160 | 161 | #' Half cauchy distribution taken from the R package LaplacesDemon (Hall, 2012). 162 | #' 163 | #' \code{dhalfcauchy} returns the probability density for a half-Cauchy distribution 164 | #' 165 | #' @param x A parameter value for which the density should be calculated 166 | #' @param scale The scale parameter of the half-Cauchy distributoin 167 | #' @param log A logical indicating whether the log density should be returned 168 | #' @param q A vector of quantiles 169 | #' @param p A vector of probabilities 170 | #' @param n The number of observations 171 | #' 172 | #' @rdname dhalfcauchy 173 | #' 174 | #'@export 175 | dhalfcauchy <- function(x, scale=25, log=FALSE) 176 | { 177 | if(all(x > 0)){ 178 | x <- as.vector(x); scale <- as.vector(scale) 179 | if(any(scale <= 0)) stop("The scale parameter must be positive.") 180 | NN <- max(length(x), length(scale)) 181 | x <- rep(x, len=NN); scale <- rep(scale, len=NN) 182 | dens <- log(2*scale) - log(pi*{x*x + scale*scale}) 183 | if(log == FALSE) dens <- exp(dens) 184 | } else { 185 | if(log == FALSE){ dens <- 0 } else {dens=-Inf} 186 | } 187 | return(dens) 188 | } 189 | #' @rdname dhalfcauchy 190 | #' @export 191 | phalfcauchy <- function(q, scale=25) 192 | { 193 | q <- as.vector(q); scale <- as.vector(scale) 194 | if(any(scale <= 0)) stop("The scale parameter must be positive.") 195 | NN <- max(length(q), length(scale)) 196 | q <- rep(q, len=NN); scale <- rep(scale, len=NN) 197 | z <- {2/pi}*atan(q/scale) 198 | return(z) 199 | } 200 | #' @rdname dhalfcauchy 201 | #' @export 202 | qhalfcauchy <- function(p, scale=25) 203 | { 204 | p <- as.vector(p); scale <- as.vector(scale) 205 | if(any(p < 0) || any(p > 1)) stop("p must be in [0,1].") 206 | if(any(scale <= 0)) stop("The scale parameter must be positive.") 207 | NN <- max(length(p), length(scale)) 208 | p <- rep(p, len=NN); scale <- rep(scale, len=NN) 209 | q <- scale*tan({pi*p}/2) 210 | return(q) 211 | } 212 | #' @rdname dhalfcauchy 213 | #' @export 214 | rhalfcauchy <- function(n, scale=25) 215 | { 216 | scale <- rep(scale, len=n) 217 | if(any(scale <= 0)) stop("The scale parameter must be positive.") 218 | p <- runif(n, 0, 1) 219 | x <- scale*tan({pi*p}/2) 220 | return(x) 221 | } 222 | -------------------------------------------------------------------------------- /src/branches.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | RcppExport SEXP bm_direct2 (SEXP dat, SEXP pars) 6 | { 7 | /* 8 | * all objects ordered from 1:(Nnode(phy)+Ntip(phy)) unless noted otherwise 9 | * dat: a list of elements 10 | * len: edge lengths (vector) 11 | * root: root ID 12 | * y: tip data 13 | * order: order of internal IDs for pruning algorithm 14 | * pars: rates associated with each branch 15 | */ 16 | 17 | try { 18 | /* call in parameters associated with 'dat' object */ 19 | Rcpp::List cache(dat); 20 | 21 | int root = Rcpp::as(cache["root"]); 22 | int n = Rcpp::as(cache["n"]); 23 | 24 | double drift = Rcpp::as(cache["drift"]); 25 | 26 | std::vector len = Rcpp::as >(cache["len"]); 27 | std::vector y = Rcpp::as >(cache["y"]); 28 | std::vector var = Rcpp::as >(cache["var"]); 29 | std::vector known = Rcpp::as >(cache["given"]); // 30 | std::vector intorder = Rcpp::as >(cache["intorder"]); 31 | std::vector tiporder = Rcpp::as >(cache["tiporder"]); 32 | std::vector descR = Rcpp::as >(cache["descRight"]); 33 | std::vector descL = Rcpp::as >(cache["descLeft"]); 34 | 35 | std::vector rates = Rcpp::as > (pars); 36 | 37 | std::vector lq; 38 | lq.assign(n,0.0); 39 | 40 | double yi, ri, li, m1, m2, v1, v2, v12, m12, n12, nm, nv, m, mm, v, k; 41 | 42 | double const PIx = 4.0*atan(1.0); 43 | 44 | std::vector branchinitM; 45 | std::vector branchinitV; 46 | std::vector branchbaseM; 47 | std::vector branchbaseV; 48 | 49 | branchinitM.assign(n,0.0); 50 | branchinitV.assign(n,0.0); 51 | branchbaseM.assign(n,0.0); 52 | branchbaseV.assign(n,0.0); 53 | 54 | int i, z, cur, d1, d2; 55 | 56 | /* mean and variance for leaves */ 57 | z=tiporder.size(); 58 | for(i=0; i(cache["N"]); 184 | int n = Rcpp::as(cache["n"]); 185 | int nn = N+n; 186 | int node = Rcpp::as(cache["node"]); 187 | std::vector exclude = Rcpp::as >(cache["exclude"]); 188 | std::vector subtended; 189 | std::vector drop; 190 | 191 | int i, j, k, se, sn, sd, nd, cur; 192 | 193 | std::vector res; 194 | 195 | if(node>N) 196 | { 197 | /* fix exclude vector (drop) */ 198 | se=exclude.size(); 199 | for(i=0; inode) & (cur<=nn) ) 203 | { 204 | std::vector dd=adesc[cur-1]; 205 | sd=dd.size(); 206 | for(j=0; j nodedesc = adesc[node-1]; 213 | se=drop.size(); 214 | if(se>0) 215 | { 216 | /* find descendants not in drop list */ 217 | sn=nodedesc.size(); 218 | sd=drop.size(); 219 | for(i=0; i(phylo["N"]); 262 | int maxnode = Rcpp::as(phylo["MAXNODE"]); 263 | std::vector anc = Rcpp::as >(phylo["ANC"]); 264 | std::vector des = Rcpp::as >(phylo["DES"]); 265 | 266 | int rows = maxnode-1; 267 | int root = N+1; 268 | 269 | std::vector< std::vector > TIPS; 270 | std::vector< std::vector > FDESC; 271 | std::vector< std::vector > ADESC; 272 | std::vector< std::vector > AANC; 273 | 274 | std::vector empty; 275 | 276 | 277 | int i, j, k, s, t, z, dn, fd; 278 | 279 | /* initialize TIPS with known descendants (tips and root), otherwise leave empty */ 280 | std::vector cur; 281 | for(i = 0; i < maxnode; i++) { 282 | FDESC.push_back(empty); 283 | AANC.push_back(empty); 284 | if(i < N) 285 | { 286 | cur.push_back(i+1); 287 | TIPS.push_back(cur); 288 | ADESC.push_back(cur); 289 | } 290 | else 291 | { 292 | TIPS.push_back(empty); 293 | ADESC.push_back(empty); 294 | } 295 | cur.clear(); 296 | } 297 | 298 | /* store nodes associated with root -- TIPS */ 299 | for(i=0; i N) { 329 | /* find descendant nodes */ 330 | std::vector subtends; 331 | for(j=0; j subtendedtips; 342 | std::vector subtendednodes; 343 | s=subtends.size(); 344 | for(k = 0; k < s; k++){ 345 | 346 | /* find nodes subtended by immediate descendants of nd */ 347 | fd = subtends.at(k); 348 | subtendednodes.push_back(fd); 349 | 350 | if(fd descnodes = ADESC[fd-1]; 354 | t=descnodes.size(); 355 | for(z = 0; z < t; z++){ 356 | dn=descnodes[z]; 357 | if(dn ancnodes = AANC[idx-1]; 374 | ancnodes.push_back(nd); 375 | AANC.at(idx-1)=ancnodes; 376 | } 377 | } 378 | } 379 | 380 | for(i=0; i ancnodes = AANC[k]; 387 | ancnodes.push_back(root); 388 | AANC.at(k)=ancnodes; 389 | } 390 | } 391 | return Rcpp::List::create(Rcpp::Named("tips",TIPS), 392 | Rcpp::Named("fdesc",FDESC), 393 | Rcpp::Named("adesc",ADESC), 394 | Rcpp::Named("anc",AANC)); 395 | } catch( std::exception &ex ) { 396 | forward_exception_to_r( ex ); 397 | } catch(...) { 398 | ::Rf_error( "C++ exception: unknown reason" ); 399 | } 400 | return R_NilValue; 401 | } 402 | -------------------------------------------------------------------------------- /R/bayou-steppingstone.R: -------------------------------------------------------------------------------- 1 | #' Make a reference function in bayou 2 | #' 3 | #' This function generates a reference function from a mcmc chain for use in marginal likelihood 4 | #' estimation. 5 | #' 6 | #' @param chain An mcmc chain produced by \code{bayou.mcmc()} and loaded with \code{load.bayou()} 7 | #' @param model A string specifying the model ("OU", "QG", "OUrepar") or a model parameter list 8 | #' @param priorFn The prior function used to generate the mcmc chain 9 | #' @param burnin The proportion of the mcmc chain to be discarded when generating the reference function 10 | #' @param plot Logical indicating whether or not a plot should be created 11 | #' 12 | #' @details Distributions are fit to each mcmc chain and the best-fitting distribution is chosen as 13 | #' the reference distribution for that parameter using the method of Fan et al. (2011). For positive 14 | #' continuous parameters \code{alpha, sigma^2, halflife, Vy, w2, Ne}, Log-normal, exponential, gamma and weibull 15 | #' distributions are fit. For continuous distributions \code{theta}, Normal, Cauchy and Logistic distributions 16 | #' are fit. For discrete distributions, \code{k}, negative binomial, poisson and geometric distributions are fit. 17 | #' Best-fitting distributions are determined by AIC. 18 | #' 19 | #' @export 20 | #' @return Returns a reference function of class "refFn" that takes a parameter list and returns the log density 21 | #' given the reference distribution. If \code{plot=TRUE}, a plot is produced showing the density of variable parameters 22 | #' and the fitted distribution from the reference function (in red). 23 | make.refFn <- function(chain, model, priorFn, burnin=0.3, plot=TRUE){ 24 | if(is.character(model)){ 25 | model.pars <- switch(model, "OU"=model.OU, "QG"=model.QG, "OUrepar"=model.OUrepar)#, "bd"=model.bd) 26 | } else { 27 | model.pars <- model 28 | model <- "Custom" 29 | } 30 | contdists <- c("norm", "cauchy", "logis") 31 | poscontdists <- c("lnorm", "exp", "gamma", "weibull") 32 | discdists <- c("nbinom", "pois", "geom") 33 | bounddists <- c("beta") 34 | parorder <- model.pars$parorder 35 | postburn <- max(c(1,round(burnin*length(chain[[1]]),0))):length(chain[[1]]) 36 | dists <- attributes(priorFn)$functions 37 | dists <- dists[!(names(dists) %in% paste("d", model.pars$shiftpars, sep=""))] 38 | distnames <- gsub('^[d]', "", names(dists)) 39 | 40 | ## This code tests each prior for whether it's continuous, positive continuous, bounded or discrete...not perfect; only tests bounded 41 | ## distributions between 0 and 1, etc.... 42 | test.dists <- suppressWarnings(apply(is.finite(sapply(dists, function(x) c(x(-0.5), x(1.5), x(0.5), x(1)))), 2, function(x) paste(as.numeric(x), collapse=""))) 43 | dist.types <- rep(NA, length(dists)) 44 | names(dist.types) <- names(dists) 45 | dist.types[which(test.dists=="0111")] <- "pcdist" 46 | dist.types[which(test.dists=="1111")] <- "cdist" 47 | dist.types[which(test.dists=="0010" |test.dists== "0011")] <- "bdist" 48 | dist.types[which(test.dists=="0001")] <- "ddist" 49 | refFx <- list() 50 | refNames <- list() 51 | dists <- list() 52 | parameters <- list() 53 | x <- NULL 54 | for(i in 1:length(dist.types)){ 55 | parname <- gsub('^[a-zA-Z]',"",names(dist.types)[i]) 56 | xx <- unlist(chain[[parname]][postburn]) 57 | fitdists <- switch(dist.types[i], "ddist"=discdists, "pcdist"=poscontdists, "bdist"=bounddists, "cdist"=contdists) 58 | { 59 | tmpFits <- lapply(fitdists, function(x) suppressWarnings(try(fitdistrplus::fitdist(xx, x), silent=TRUE))) 60 | tmpFits[sapply(tmpFits, function(x) (class(x)=="try-error"))] <- lapply(which(sapply(tmpFits, function(x) (class(x)=="try-error"))), function(j) suppressWarnings(try(fitdistrplus::fitdist(xx, fitdists[j], method="mme"), silent=TRUE))) 61 | tmpFits <- tmpFits[sapply(tmpFits, function(x) !(class(x)=="try-error"))] 62 | aic <- sapply(tmpFits, function(x) x$aic) 63 | fit <- tmpFits[[which(aic==min(aic,na.rm=TRUE))]] 64 | ## Fix for problem with negative binomial distribution 65 | if(fit$distname == "nbinom"){fit$estimate <- c(fit$estimate, prob=unname(fit$estimate['size']/(fit$estimate['size']+fit$estimate['mu'])))} 66 | fitPars <- as.list(fit$estimate) 67 | fitPars$log <- TRUE 68 | fitName <- fit$distname 69 | fitfx <- get(paste("d",fitName, sep="")) 70 | refFx[[i]] <- .set.defaults(fitfx, defaults=fitPars) 71 | } 72 | 73 | dists[[i]] <- fitName 74 | parameters[[i]] <- fitPars 75 | } 76 | names(refFx) <- gsub('^[a-zA-Z]',"", names(dist.types)) 77 | par.names <- names(refFx) 78 | names(dists) <- par.names 79 | names(parameters) <- par.names 80 | if(attributes(priorFn)$distributions$dsb!="fixed"){ 81 | dists$dsb <- "dsb" 82 | parameters$dsb <- attributes(priorFn)$parameters$dsb 83 | refFx$dsb <- attributes(priorFn)$functions$dsb 84 | par.names <- c(par.names, "sb") 85 | } 86 | if(attributes(priorFn)$distributions$dloc!="fixed"){ 87 | dists$dloc = "dloc" 88 | parameters$dloc <- attributes(priorFn)$parameters$dloc 89 | refFx$dloc <- attributes(priorFn)$functions$dloc 90 | par.names <- c(par.names, "loc") 91 | } 92 | 93 | if(plot){ 94 | pars2plot <- par.names[!(par.names %in% c("sb", "loc"))] 95 | par(mfrow=c(ceiling(length(pars2plot)/2),2)) 96 | for(i in 1:length(pars2plot)){ 97 | plot(density(unlist(chain[[pars2plot[i]]][postburn])), main=pars2plot[i]) 98 | if(pars2plot[i]=="k"){ 99 | points(seq(ceiling(par('usr')[1]),floor(par('usr')[2]),1), refFx[[pars2plot[i]]](seq(ceiling(par('usr')[1]),floor(par('usr')[2]),1),log=FALSE),pch=21,bg="red") 100 | } else {x <- NULL; curve(refFx[[pars2plot[i]]](x,log=FALSE), add=TRUE, col="red")} 101 | } 102 | } 103 | refFUN <- function(pars,cache){ 104 | if(any(!(par.names %in% names(pars)))) stop(paste("Missing parameters: ", paste(par.names[!(par.names %in% names(pars))],collapse=" "))) 105 | pars.o <- pars[match(par.names,names(pars))] 106 | pars.o <- pars.o[!is.na(names(pars.o))] 107 | densities <- sapply(1:length(pars.o),function(x) refFx[[x]](pars.o[[x]])) 108 | names(densities) <- par.names 109 | lnprior <- sum(unlist(densities,F,F)) 110 | return(lnprior) 111 | } 112 | attributes(refFUN) <- list("model"=model,"parnames"=par.names,"distributions"=dists,"parameters"=parameters,"functions"=refFx) 113 | class(refFUN) <- c("refFn","function") 114 | return(refFUN) 115 | } 116 | 117 | 118 | #' Makes a power posterior function in bayou 119 | #' 120 | #' This function generates a power posterior function for estimation of marginal likelihood using the stepping stone method 121 | #' 122 | #' @param Bk The sequence of steps to be taken from the reference function to the posterior 123 | #' @param priorFn The prior function to be used in marginal likelihood estimation 124 | #' @param refFn The reference function generated using \code{make.refFn()} from a preexisting mcmc chain 125 | #' @param model A string specifying the model type ("OU", "OUrepar", "QG") or a model parameter list 126 | #' 127 | #' @details For use in stepping stone estimation of the marginal likelihood using the method of Fan et al. (2011). 128 | #' @export 129 | #' @return A function of class "powerposteriorFn" that returns a list of four values: \code{result} (the log density of the power posterior), 130 | #' \code{lik} (the log likelihood), \code{prior} (the log prior), \code{ref} the log reference density. 131 | make.powerposteriorFn <- function(Bk, priorFn, refFn, model){ 132 | #Turn these off for now, need to add back in checks 133 | #model <- attributes(priorFn)$model 134 | #if(model != attributes(refFn)$model) stop("Error: prior and reference function are not of same type") 135 | if(is.character(model)){ 136 | model.pars <- switch(model, "OU"=model.OU, "QG"=model.QG, "OUrepar"=model.OUrepar)#, "bd"=model.bd) 137 | } else { 138 | model.pars <- model 139 | model <- "Custom" 140 | } 141 | powerposteriorFn <- function(k, Bk, pars, cache, dat, model=model.pars){ 142 | lik <- model$lik.fn(pars, cache, dat)$loglik 143 | prior <- priorFn(pars, cache) 144 | ref <- refFn(pars, cache) 145 | coeff <- c(Bk[k],Bk[k],(1-Bk[k])) 146 | result <- c(lik, prior, ref) 147 | result[coeff==0] <- 0 148 | result <- result*coeff 149 | result <- sum(result) 150 | return(list(result=result, lik=lik, prior=prior, ref=ref)) 151 | } 152 | class(powerposteriorFn) <- c("powerposteriorFn", "function") 153 | return(powerposteriorFn) 154 | } 155 | 156 | powerPosteriorFn <- function(k, Bk, lik, prior, ref){ 157 | coeff <- c(Bk[k],Bk[k],(1-Bk[k])) 158 | result <- c(lik, prior, ref) 159 | result[coeff==0] <- 0 160 | result <- result*coeff 161 | result <- sum(result) 162 | return(result) 163 | } 164 | 165 | 166 | #' S3 method for printing ssMCMC objects 167 | #' 168 | #' @param x An ssMCMC object 169 | #' @param ... Optional arguments passed to print 170 | #' 171 | #' @export 172 | #' @method print ssMCMC 173 | print.ssMCMC <- function(x, ...){ 174 | cat("Stepping stone estimation of marginal likelihood\n") 175 | cat("Marginal Likelihood:\n") 176 | print(x$lnr, ...) 177 | cat(paste("A total of ", length(x$Bk), " power posteriors were run along the sequence: ",paste(round(x$Bk,5), collapse="\t\t"), "\n", sep="")) 178 | cat("lnr_k", round(unlist(x$lnrk),2)) 179 | } 180 | #' S3 method for plotting ssMCMC objects 181 | #' 182 | #' @param x An 'ssMCMC' object 183 | #' @param ... Additional arguments passed to \code{plot} 184 | #' 185 | #' @details Produces 4 plots. The first 3 plot the prior, reference function and likelihood. Different colors 186 | #' indicate different power posteriors for each. These chains should appear to be well mixed. The final plot 187 | #' shows the sum of the marginal likelihood across each of the steps in the stepping stone algorithm. 188 | #' 189 | #' @export 190 | #' @method plot ssMCMC 191 | plot.ssMCMC <- function(x, ...){ 192 | oldpar <- graphics::par(no.readonly = TRUE) 193 | on.exit(graphics::par(oldpar)) 194 | par(mfrow=c(2,2)) 195 | if(is.null(attributes(x)$burnin)){ 196 | start <- 1 197 | } else { 198 | start <- round(attributes(x)$burnin*length(x$chains[[1]][[1]]),0) 199 | } 200 | postburn <- start:length(x$chains[[1]][[1]]) 201 | lnL <- lapply(x$chains, function(x) x$lnL[postburn]) 202 | rangelnL <- c(min(unlist(lnL))-2, max(unlist(lnL))+2) 203 | plot(0,0,type="n", xlim=c(0,length(unlist(lnL))), ylim=rangelnL,xaxt="n",xlab="",ylab="lnL", main="lnL",...) 204 | xindex <- lapply(1:length(lnL), function(x) (x-1)*length(lnL[[1]]) + 1:length(lnL[[1]])) 205 | sapply(1:length(lnL), function(x) lines(xindex[[x]], lnL[[x]], col=x)) 206 | abline(v=seq(0,length(unlist(lnL)), length.out=length(lnL)+1),lty=2) 207 | 208 | pr <- lapply(x$chains, function(x) x$prior[postburn]) 209 | rangepr <- c(min(unlist(pr))-2, max(unlist(pr))+2) 210 | plot(0,0,type="n", xlim=c(0,length(unlist(pr))), ylim=rangepr,xaxt="n",xlab="",ylab="Ln prior", main="ln prior",...) 211 | xindex <- lapply(1:length(pr), function(x) (x-1)*length(pr[[1]]) + 1:length(pr[[1]])) 212 | sapply(1:length(pr), function(x) lines(xindex[[x]], pr[[x]], col=x)) 213 | abline(v=seq(0,length(unlist(pr)), length.out=length(pr)+1),lty=2) 214 | 215 | ref <- lapply(x$chains, function(x) x$ref[postburn]) 216 | rangeref <- c(min(unlist(ref))-2, max(unlist(ref))+2) 217 | plot(0,0,type="n", xlim=c(0,length(unlist(ref))), ylim=rangeref,xaxt="n",xlab="",ylab="Ln ref", main="ln ref",...) 218 | xindex <- lapply(1:length(ref), function(x) (x-1)*length(ref[[1]]) + 1:length(ref[[1]])) 219 | sapply(1:length(ref), function(x) lines(xindex[[x]], ref[[x]], col=x)) 220 | abline(v=seq(0,length(unlist(ref)), length.out=length(ref)+1),lty=2) 221 | 222 | plot(x$Bk, c(0, cumsum(x$lnrk)), ylab="ln r", xlab="power posterior",pch=21, bg=1:length(ref),cex=1.5, ...) 223 | lines(x$Bk, c(0,cumsum(x$lnrk))) 224 | } 225 | 226 | .pull.rsample <- function(samp, chain){ 227 | #pars.list <- lapply(samp,function(y) pull.pars(y,chain,model=model)) 228 | #emap.list <- lapply(samp,function(y) read.emap(chain$branch.shift[[y]],chain$location[[y]],chain$t2[[y]],cache$phy)$emap) 229 | L <- chain$lnL[samp]+chain$prior[samp]-chain$ref[samp] 230 | Lmax <- max(L) 231 | Lfactored <- L-Lmax 232 | return(list(Lmax=Lmax,Lfactored=Lfactored)) 233 | } 234 | 235 | ## Compute marginal likelihood 236 | ## 237 | ## \code{computelnr} computes the marginal likelihood of a set of chains estimated via stepping stone 238 | ## sampling and produced by the function \code{steppingstone} 239 | .computelnr <- function(Kchains,Bk,samp){ 240 | lnr <- list() 241 | for(i in 1:(length(Bk)-1)){ 242 | Lk <- .pull.rsample(samp, Kchains[[i]]) 243 | lnr[[i]] <- (Bk[i+1]-Bk[i])*Lk$Lmax+log(1/length(Lk$Lfactored)*sum(exp(Lk$Lfactored)^(Bk[i+1]-Bk[i]))) 244 | } 245 | return(list("lnr"=sum(unlist(lnr)),"lnrk"=lnr)) 246 | } 247 | 248 | 249 | 250 | 251 | -------------------------------------------------------------------------------- /R/bayou-prior.R: -------------------------------------------------------------------------------- 1 | #' Make a prior function for bayou 2 | #' 3 | #' This function generates a prior function to be used for bayou according to user specifications. 4 | #' 5 | #' @param tree A tree object of class "phylo" 6 | #' @param dists A list providing the function names of the distribution functions describing the prior distributions of parameters (see details). If no 7 | #' distributions are provided for a parameter, default values are given. Note that the names are provided as text strings, not the functions themselves. 8 | #' @param param A list providing the parameter values of the prior distributions (see details). 9 | #' @param plot.prior A logical indicating whether the prior distributions should be plotted. 10 | #' @param model One of three specifications of the OU parameterization used. 11 | #' Takes values \code{"OU"} (alpha & sig2), \code{"QG"} (h2, P, w2, Ne), or \code{"OUrepar"} (halflife,Vy) 12 | #' @param fixed A list of parameters that are to be fixed at provided values. These are removed from calculation of the prior value. 13 | #' @details Default distributions and parameter values are given as follows: 14 | #' OU: \code{list(dists=list("dalpha"="dlnorm","dsig2"="dlnorm", 15 | #' "dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dunif"), 16 | #' param=list("dalpha"=list(),"dsig2"=list(),"dtheta"=list(), 17 | #' "dk"=list(lambda=1,kmax=2*ntips-2),"dloc"=list(min=0,max=1),"dsb"=list()))} 18 | #' QG: \code{list(dists=list("dh2"="dbeta","dP"="dlnorm","dw2"="dlnorm","dNe"="dlnorm", 19 | #' "dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dunif"), 20 | #' param=list("dh2"=list(shape1=1,shape2=1),"dP"=list(),"dw2"=list(),"dNe"=list(),"dtheta"=list(), 21 | #' "dk"=list(lambda=1,kmax=2*ntips-2),"dloc"=list(min=0,max=1),"dsb"=list()))} 22 | #' OUrepar: \code{list(dists=list("dhalflife"="dlnorm","dVy"="dlnorm", 23 | #' "dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dunif"), 24 | #' param=list("dhalflife"=list("meanlog"=0.25,"sdlog"=1.5),"dVy"=list("meanlog"=1,"sdlog"=2), 25 | #' "dk"=list(lambda=1,kmax=2*ntips-2),"dtheta"=list(),"dloc"=list(min=0,max=1)),"dsb"=list())} 26 | #' 27 | #' \code{dalpha, dsig2, dh2, dP, dw2, dNe, dhalflife}, and \code{dVy} must be positive continuous distributions and provide the parameters used to calculate alpha and sigma^2 of the OU model. 28 | #' \code{dtheta} must be continuous and describes the prior distribution of the optima. dk is the prior distribution for the number of shifts. For Poisson and conditional Poisson (cdpois) are provided 29 | #' the parameter \code{lambda}, which provides the total number of shifts expected on the tree (not the rate per unit branch length). Otherwise, \code{dk} can take any positive, discrete distribution. 30 | #' dsb indicates the prior probability of a given set of branches having shifts, and is generally specified by the "dsb" function in the bayou package. See the documentation for dsb for specifying the number 31 | #' of shifts allowed per branch, the probability of a branch having a shift, and specifying constraints on where shifts can occur.\code{"dloc"} indicates the prior probability of the location of a shift within 32 | #' a single branch. Currently, all locations are given uniform density. All distributions are set to return log-transformed probability densities. 33 | #' 34 | #' @return returns a prior function of class "priorFn" that calculates the log prior density for a set of parameter values provided in a list with correctly named values. 35 | #' 36 | #' @export 37 | #' @examples 38 | #' ## Load data 39 | #' data(chelonia) 40 | #' tree <- chelonia$phy 41 | #' dat <- chelonia$dat 42 | #' 43 | #' #Create a prior that allows only one shift per branch with equal probability 44 | #' #across branches 45 | #' prior <- make.prior(tree, dists=list(dalpha="dlnorm", dsig2="dlnorm", 46 | #' dsb="dsb", dk="cdpois", dtheta="dnorm"), 47 | #' param=list(dalpha=list(meanlog=-5, sdlog=2), 48 | #' dsig2=list(meanlog=-1, sdlog=5), dk=list(lambda=15, kmax=200), 49 | #' dsb=list(bmax=1,prob=1), dtheta=list(mean=mean(dat), sd=2))) 50 | #' 51 | #' #Evaluate some parameter sets 52 | #' pars1 <- list(alpha=0.1, sig2=0.1, k=5, ntheta=6, theta=rnorm(6, mean(dat), 2), 53 | #' sb=c(32, 53, 110, 350, 439), loc=rep(0.1, 5), t2=2:6) 54 | #' pars2 <- list(alpha=0.1, sig2=0.1, k=5, ntheta=6, theta=rnorm(6, mean(dat), 2), 55 | #' sb=c(43, 43, 432, 20, 448), loc=rep(0.1, 5), t2=2:6) 56 | #' prior(pars1) 57 | #' prior(pars2) #-Inf because two shifts on one branch 58 | #' 59 | #' #Create a prior that allows any number of shifts along each branch with probability proportional 60 | #' #to branch length 61 | #' prior <- make.prior(tree, dists=list(dalpha="dlnorm", dsig2="dlnorm", 62 | #' dsb="dsb", dk="cdpois", dtheta="dnorm"), 63 | #' param=list(dalpha=list(meanlog=-5, sdlog=2), 64 | #' dsig2=list(meanlog=-1, sdlog=5), dk=list(lambda=15, kmax=200), 65 | #' dsb=list(bmax=Inf,prob=tree$edge.length), 66 | #' dtheta=list(mean=mean(dat), sd=2))) 67 | #' prior(pars1) 68 | #' prior(pars2) 69 | #' 70 | #' #Create a prior with fixed regime placement and sigma^2 value 71 | #' prior <- make.prior(tree, dists=list(dalpha="dlnorm", dsig2="fixed", 72 | #' dsb="fixed", dk="fixed", dtheta="dnorm", dloc="dunif"), 73 | #' param=list(dalpha=list(meanlog=-5, sdlog=2), 74 | #' dtheta=list(mean=mean(dat), sd=2)), 75 | #' fixed=list(sig2=1, k=3, ntheta=4, sb=c(447, 396, 29))) 76 | #' 77 | #' pars3 <- list(alpha=0.01, theta=rnorm(4, mean(dat), 2), loc=rep(0.1, 4)) 78 | #' prior(pars3) 79 | #' 80 | #' ##Return a list of functions used to calculate prior 81 | #' attributes(prior)$functions 82 | #' 83 | #' ##Return parameter values used in prior distribution 84 | #' attributes(prior)$parameters 85 | 86 | make.prior <- function(tree, dists=list(), param=list(), fixed=list(), plot.prior=TRUE,model="OU"){ 87 | tree <- reorder.phylo(tree, "postorder") 88 | nH <- max(nodeHeights(tree)) 89 | ntips <- length(tree$tip.label) 90 | TH <- sum(tree$edge.length) 91 | default.OU <- list(dists=list("dalpha"="dlnorm","dsig2"="dlnorm","dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dloc"),param=list("dalpha"=list(),"dsig2"=list(),"dtheta"=list(),"dk"=list(lambda=1,kmax=2*ntips-2),"dloc"=list(min=0,max=1),"dsb"=list(ntips=ntips, bmax=1, prob=1))) 92 | default.QG <- list(dists=list("dh2"="dbeta","dP"="dlnorm","dw2"="dlnorm","dNe"="dlnorm","dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dloc"),param=list("dh2"=list(shape1=1,shape2=1),"dP"=list(),"dw2"=list(),"dNe"=list(),"dtheta"=list(),"dk"=list(lambda=1,kmax=2*ntips-2),"dloc"=list(min=0,max=1),"dsb"=list(ntips=ntips, bmax=1, prob=1))) 93 | default.OUrepar <- list(dists=list("dhalflife"="dlnorm","dVy"="dlnorm","dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dloc"),param=list("dhalflife"=list("meanlog"=0.25,"sdlog"=1.5),"dVy"=list("meanlog"=1,"sdlog"=2),"dk"=list(lambda=1,kmax=2*ntips-2),"dtheta"=list(),"dloc"=list(min=0,max=1),"dsb"=list(ntips=ntips, bmax=1, prob=1))) 94 | #default.ffancova <- list(dists=list("dalpha"="dlnorm","dsig2"="dlnorm","dbeta1"="dnorm","dk"="cdpois","dtheta"="dnorm","dsb"="dsb","dloc"="dloc"),param=list("dalpha"=list(),"dsig2"=list(),"dbeta1"=list(),"dtheta"=list(),"dk"=list(lambda=1,kmax=2*ntips-2),"dloc"=list(min=0,max=1),"dsb"=list(ntips=ntips, bmax=1, prob=1))) 95 | #default.OUcpp <- list(dists=list("dalpha"="dlnorm","dsig2"="dlnorm","dsig2jump"="dlnorm","dk"="dpois","dtheta"="dnorm","dloc"="dunif"),param=list("dalpha"=NULL,"dsig2"=list(),"dsig2jump"=list(),"dtheta"=list(),"dk"=list(lambda=1),"dloc"=list(min=0,max=TH))) 96 | #default.QGcpp <- list(dists=list("dh2"="dbeta","dP"="dlnorm","dw2"="dlnorm","dNe"="dlnorm","dk"="dpois","dtheta"="dnorm","dloc"="dunif"),param=list("dh2"=list(shape1=1,shape2=1),"dP"=list(),"dw2"=list(),"dNe"=list(),"dsig2jump"=list(),"dtheta"=list(),"dk"=list(lambda=1),"dloc"=list(min=0,max=TH))) 97 | #default.OUreparcpp <- list(dists=list("dhalflife"="dlnorm","dVy"="dlnorm","dsig2jump"="dlnorm","dk"="dpois","dtheta"="dnorm","dloc"="dunif"),param=list("dhalflife"=list("meanlog"=0.25,"sdlog"=1.5),"dVy"=list("meanlog"=1,"sdlog"=2),"dk"=list(lambda=1),"dsig2jump"=list(),"dtheta"=list(),"dloc"=list(min=0,max=TH))) 98 | 99 | default <- switch(model,"OU"=default.OU,"QG"=default.QG,"OUrepar"=default.OUrepar)#,"OUcpp"=default.OUcpp,"QGcpp"=default.QGcpp,"OUreparcpp"=default.OUreparcpp) 100 | notprovided <- setdiff(names(default$dist),names(dists)) 101 | pars.notprovided <- setdiff(names(default$param),names(param)) 102 | dists[notprovided] <- default$dists[notprovided] 103 | param[pars.notprovided] <- default$param[pars.notprovided] 104 | if(length(setdiff(names(default$param),names(param)))>0) 105 | stop("Provided parameters are not in the model") 106 | if(length(setdiff(names(default$dists),names(dists)))>0) 107 | stop("Provided parameters are not in the model") 108 | if(dists$dsb=="dsb") param$dsb$ntips <- ntips 109 | if(dists$dloc=="dunif" & dists$dsb=="dsb"){ 110 | dists$dloc <- "dloc" 111 | } 112 | remove <- which(unlist(dists)=="fixed") 113 | if(length(remove)>0){ 114 | dists2get <- dists[-remove] 115 | param2get <- param[-(match(names(remove),names(param)))] 116 | fixed.param <- gsub('^[a-zA-Z]',"",names(remove)) 117 | if("sb" %in% fixed.param & !("k" %in% names(fixed))) fixed$k <- length(fixed$sb) 118 | if("sb" %in% fixed.param & !("t2" %in% names(fixed)) & length(fixed$sb)>0) fixed$t2 <- 2:(length(fixed$sb)+1) 119 | if("sb" %in% fixed.param & !("t2" %in% names(fixed)) & length(fixed$sb)==0) fixed$t2 <- numeric(0) 120 | missing.fixed <- fixed.param[!(fixed.param %in% names(fixed))] 121 | if(length(missing.fixed)>0){ 122 | stop(paste("'", paste(missing.fixed, collapse="', '"), "' set as 'fixed' but not provided", sep="")) 123 | } 124 | } else {dists2get <- dists; param2get <- param} 125 | prior.fx <- lapply(dists2get,get) 126 | param2get <- suppressWarnings(lapply(param2get,function(x){ x$log = TRUE; x})) 127 | prior.param <- param2get[match(names(prior.fx),names(param2get))] 128 | prior.fx <- lapply(1:length(prior.param),function(x) .set.defaults(prior.fx[[x]],defaults=prior.param[[x]])) 129 | names(prior.fx) <- names(prior.param) 130 | #if(model %in% c("OUcpp","QGcpp","OUreparcpp")){ 131 | #droot <- prior.fx$dtheta 132 | #prior.fx$dtheta <- function(x){ 133 | #droot(x[1]) 134 | #} 135 | #} 136 | par.names <- gsub('^[a-zA-Z]',"",names(dists2get)) 137 | 138 | rfx <- lapply(gsub('^[a-zA-Z]',"r",dists2get),function(x) try(get(x),silent=TRUE)) 139 | rprior.param <- prior.param[1:(length(prior.param))] 140 | rprior.param <- lapply(rprior.param, function(x) x[-length(x)]) 141 | if(!is.null(dists2get$dsb) & !is.null(dists2get$dloc)){ 142 | if(dists2get$dsb=="dsb" & any(rprior.param$dsb$bmax==1)){rprior.param$dsb$bmax[rprior.param$dsb$bmax==1] <- Inf; rprior.param$dsb$prob <- 1} 143 | } 144 | rfx <- lapply(1:length(rprior.param),function(x) try(.set.defaults(rfx[[x]],defaults=rprior.param[[x]]),silent=TRUE)) 145 | plot.names<-par.names[sapply(rfx,class)=="function"] 146 | rfx <- rfx[sapply(rfx,class)=="function"] 147 | names(rfx) <- names(rprior.param) 148 | 149 | if(plot.prior){ 150 | oldpar <- graphics::par(no.readonly = TRUE) 151 | on.exit(graphics::par(oldpar)) 152 | graphics::par(mfrow=c(ceiling(length(dists2get)/2),2)) 153 | nsim <-500000 154 | for(i in 1:length(rfx)){ 155 | if(names(rfx)[i]=="dsb"){ 156 | graphics::curve(sapply(x,function(y) prior.fx$dsb(y,log=FALSE)),xlim=c(1,(2*ntips-2)),ylab="Density",main="branches") 157 | } else { 158 | x <- rfx[[i]](nsim) 159 | qq <- stats::quantile(x,c(0.001,0.999)) 160 | graphics::plot(stats::density(x),xlim=qq, main=plot.names[i],lwd=2) 161 | } 162 | } 163 | } 164 | priorFUN <- function(pars,cache){ 165 | if(any(!(par.names %in% names(pars)))) stop(paste("Missing parameters: ", paste(par.names[!(par.names %in% names(pars))],collapse=" "))) 166 | pars.o <- pars[match(par.names,names(pars))] 167 | pars.o <- pars.o[!is.na(names(pars.o))] 168 | densities <- sapply(1:length(pars.o),function(x) prior.fx[[x]](pars.o[[x]])) 169 | names(densities) <- par.names 170 | lnprior <- sum(unlist(densities,F,F)) 171 | return(lnprior) 172 | } 173 | 174 | if(length(remove)>0){ 175 | if("sb" %in% fixed.param){ 176 | prior.param$dsb$bmax <- rep(0, nrow(tree$edge)) 177 | prior.param$dsb$bmax[fixed$sb] <- 1 178 | prior.param$dsb$prob <- prior.param$dsb$bmax 179 | } 180 | } 181 | attributes(priorFUN) <- list("model"=model,"parnames"=par.names,"distributions"=dists, "parameters"=prior.param,"fixed"=fixed, "functions"=prior.fx,"rfunctions"=rfx, "splitmergepars"="theta") 182 | class(priorFUN) <- c("priorFn","function") 183 | return(priorFUN) 184 | } 185 | -------------------------------------------------------------------------------- /R/bayou-weight_matrix.R: -------------------------------------------------------------------------------- 1 | #' Calculate the weight matrix of a set of regimes on a phylogeny 2 | #' 3 | #' These functions calculate weight matrices from regimes specified in phytools' simmap format. 4 | #' \code{simmapW} calculates the weight matrix for a set of regimes from a phylogeny 5 | #' with a stored regime history. \code{.simmap.W} calculates the same matrix, but without checks and is 6 | #' generally run internally. 7 | #' 8 | #' @rdname simmapW 9 | #' @param tree either a tree of class "phylo" or a cache object produced by bayOU's internal 10 | #' functions. Must include list element 'maps' which is a simmap reconstruction of regime history. 11 | #' @param pars a list of the parameters used to calculate the weight matrix. Only pars$alpha is 12 | #' necessary to calculate the matrix, but others can be present. 13 | #' 14 | #' @details \code{.simmap.W} is more computationally efficient within a mcmc and is used internally. The value 15 | #' of \code{TotExp} is supplied to speed computation and reduce redundancy, and cache objects must be supplied as 16 | #' the phylogeny, and the parameter \code{ntheta} must be present in the list \code{pars}. 17 | #' @export 18 | simmapW <- function(tree,pars){ 19 | if(inherits(tree, "phylo")){ 20 | X <- rep(NA,length(tree$tip.label)) 21 | names(X) <- tree$tip.label 22 | cache <- .prepare.ou.univariate(tree,X) 23 | } else {cache <- tree} 24 | if(is.null(pars$ntheta)){ 25 | pars$ntheta <- length(unique(names(unlist(cache$maps)))) 26 | } 27 | nbranch <- length(cache$edge.length) 28 | maps <- cache$maps 29 | shifts <- unlist(lapply(maps,length),F,F)-1 30 | irow <- rep(1:nbranch,shifts+1) 31 | csbase <- cache$nH[irow] 32 | csmaps <- csbase+unlist(lapply(maps,cumsum),FALSE,TRUE) 33 | multips <- which(irow[2:length(irow)]==irow[1:(length(irow)-1)]) 34 | csbase[multips+1] <- csmaps[multips] 35 | oW <- pars$alpha*(csbase-cache$height) 36 | nW <- (csmaps-csbase)*pars$alpha 37 | if(any(nW>500)){ 38 | tmp <- ifelse(nW>500, exp(nW+oW), exp(oW)*(exp(nW)-1)) 39 | } else { 40 | tmp <- exp(oW)*(exp(nW)-1) 41 | } 42 | bW <- matrix(0,nrow=nbranch,ncol=pars$ntheta) 43 | index <- irow + (as.integer(names(tmp))-1)*nbranch 44 | if(any(shifts>1)){ 45 | tmp <- tapply(tmp,index,sum) 46 | bW[as.numeric(names(tmp))] <- tmp 47 | } else {bW[index] <- tmp} 48 | W=cache$branchtrace%*%bW 49 | W[,1] <- W[,1]+exp(-cache$height*pars$alpha) 50 | return(W) 51 | } 52 | 53 | 54 | .simmap.W <- function(cache,pars){ 55 | nbranch <- length(cache$edge.length) 56 | maps <- cache$maps 57 | #Dangerous...may not have listed the shift (if shift occurs at node) 58 | shifts <- unlist(lapply(maps,length),F,F)-1 59 | #Index vector indicating which branch a given segment exists on 60 | irow <- rep(1:nbranch,shifts+1) 61 | #Height of the beginning of each branch 62 | csbase <- cache$nH[irow] 63 | #Height of the end of each segment 64 | csmaps <- csbase+unlist(lapply(maps,cumsum),FALSE,TRUE) 65 | #Determine which branches contain more than one segment 66 | multips <- which(irow[2:length(irow)]==irow[1:(length(irow)-1)]) 67 | #Set segments with more than one shift per branch to start at end of last shift 68 | csbase[multips+1] <- csmaps[multips] 69 | #Exponential term 1 70 | oW <- pars$alpha*(csbase-cache$height) 71 | #Exponential term 2 72 | nW <- (csmaps-csbase)*pars$alpha 73 | #If value of expnential term is too large (resulting in overflow), then use approximation 74 | if(any(nW>500)){ 75 | tmp <- ifelse(nW>500, exp(nW+oW), exp(oW)*(exp(nW)-1)) 76 | } else { 77 | tmp <- exp(oW)*(exp(nW)-1) 78 | } 79 | #Set up branch weight matrix 80 | bW <- matrix(0,nrow=nbranch,ncol=pars$ntheta) 81 | #Set up index over matrix, so that values go to right row index and column, based on the name of the segment in maps 82 | index <- irow + (as.integer(names(tmp))-1)*nbranch 83 | if(any(shifts>1)){ 84 | tmp <- tapply(tmp,index,sum) 85 | bW[as.numeric(names(tmp))] <- tmp 86 | } else {bW[index] <- tmp} 87 | W=cache$branchtrace%*%bW 88 | W[,1] <- W[,1]+exp(-cache$height*pars$alpha) 89 | return(W) 90 | } 91 | 92 | .parmap.W <- function(cache, pars){ 93 | if(pars$k > 0){ 94 | nbranch <- length(cache$edge.length) 95 | #create a vector called shifts that indicates the number of shifts for each branch 96 | nshifts <- table(pars$sb) 97 | shifts <- rep(0,nbranch) 98 | shifts[as.numeric(attributes(nshifts)$dimnames[[1]])]<- nshifts 99 | #Create an index equal to the number of segments that identifies the branch on which each segment is found 100 | irow <- rep(1:nbranch,shifts+1) 101 | #For now, starting height is just the height of the node 102 | csbase <- cache$nH[irow] 103 | #Calculate the ending height by sorting the edge.length and the location of shifts by their branch identity and location 104 | csadd <- c(cache$edge.length, pars$loc) 105 | tmp.o <- c(1:nbranch, pars$sb) 106 | names(csadd) <- tmp.o 107 | add.o <- order(tmp.o,csadd) 108 | csadd <- csadd[add.o] 109 | #Ending height of the segment 110 | csmaps <- csadd + csbase 111 | #We need to know what the ending theta is for each segment, so we sort pars$t2 as we did for pars$loc, but +1 because t2 is the ending regime 112 | t2index <- add.o[which(add.o > nbranch)] 113 | t2b <- c(rep(1,length(csmaps))) 114 | t2b[match(t2index,add.o)+1] <- pars$t2[t2index-nbranch] 115 | #Now we need to cascade these regime down the tree. We won't need to cascade sandwiches, as they are trapped on the branch they occur. So we find them below: 116 | loc.o <- order(pars$loc,decreasing=TRUE) 117 | sandwiches <- duplicated(pars$sb[loc.o]) 118 | # And remove them: 119 | if(sum(sandwiches)>0){ 120 | sb.down <- pars$sb[!sandwiches] 121 | t2.down <- pars$t2[!sandwiches] 122 | } else {sb.down <- pars$sb; t2.down <- pars$t2} 123 | #Now we order the sb's and t2's to prepare for a postorder tree traversal 124 | sb.o <- order(sb.down) 125 | sb.down <- sb.down[sb.o] 126 | t2.down <- t2.down[sb.o] 127 | sb.desc <- cache$bdesc[sb.down] 128 | #Loop traveling down the tree, saving all descendents that are from that shift into the vector censored. These branches cannot be modified by shifts further down the tree. 129 | censored <- NULL 130 | name.o <- names(csmaps) 131 | names(t2b) <- name.o 132 | for(i in 1:length(sb.desc)){ 133 | sb.desc[[i]] <- sb.desc[[i]][!(sb.desc[[i]] %in% censored)] 134 | censored <- c(censored, sb.desc[[i]]) 135 | t2b[name.o[name.o %in% sb.desc[[i]]]] <- t2.down[i] 136 | } 137 | names(csmaps) <- t2b 138 | multips <- which(irow[2:length(irow)]==irow[1:(length(irow)-1)]) 139 | #Set segments with more than one shift per branch to start at end of last shift 140 | csbase[multips+1] <- csmaps[multips] 141 | #Exponential term 1 142 | oW <- pars$alpha*(csbase-cache$height) 143 | #Exponential term 2 144 | nW <- (csmaps-csbase)*pars$alpha 145 | #If value of expnential term is too large (resulting in overflow), then use approximation 146 | if(any(nW>500)){ 147 | tmp <- ifelse(nW>500, exp(nW+oW), exp(oW)*(exp(nW)-1)) 148 | } else { 149 | tmp <- exp(oW)*(exp(nW)-1) 150 | } 151 | #Set up branch weight matrix 152 | bW <- matrix(0,nrow=nbranch,ncol=pars$ntheta) 153 | #Set up index over matrix, so that values go to right row index and column, based on the name of the segment in maps 154 | index <- irow + (as.integer(names(tmp))-1)*nbranch 155 | if(any(duplicated(index))){ 156 | tmp <- tapply(tmp,index,sum) 157 | bW[as.numeric(names(tmp))] <- tmp 158 | } else {bW[index] <- tmp} 159 | W=cache$branchtrace%*%bW 160 | W[,1] <- W[,1]+exp(-cache$height*pars$alpha) 161 | } else { 162 | W <- matrix(rep(1,cache$ntips),ncol=1) 163 | } 164 | return(W) 165 | } 166 | 167 | #' Calculate the weight matrix of a set of regimes on a phylogeny 168 | #' 169 | #' These functions calculate weight matrices from regimes specified by a bayou formatted parameter list 170 | #' \code{parmap.W} calculates the weight matrix for a set of regimes from a phylogeny 171 | #' with a stored regime history. \code{.parmap.W} calculates the same matrix, but without checks and is 172 | #' generally run internally. 173 | #' 174 | #' @rdname parmap.W 175 | #' @param tree either a tree of class "phylo" or a cache object produced by bayOU's internal 176 | #' functions. Must include list element 'maps' which is a simmap reconstruction of regime history. 177 | #' @param pars a list of the parameters used to calculate the weight matrix. Only pars$alpha is 178 | #' necessary to calculate the matrix, but others can be present. 179 | #' 180 | #' @details \code{.parmap.W} is more computationally efficient within a mcmc and is used internally. 181 | #' @export 182 | parmap.W <- function(tree, pars){ 183 | if(inherits(tree, "phylo")){ 184 | X <- rep(NA,length(tree$tip.label)) 185 | names(X) <- tree$tip.label 186 | cache <- .prepare.ou.univariate(tree,X) 187 | } else {cache <- tree} 188 | if(is.null(pars$ntheta)){ 189 | pars$ntheta <- length(pars$theta) 190 | } 191 | if(pars$k > 0){ 192 | nbranch <- length(cache$edge.length) 193 | #create a vector called shifts that indicates the number of shifts for each branch 194 | nshifts <- table(pars$sb) 195 | shifts <- rep(0,nbranch) 196 | shifts[as.numeric(attributes(nshifts)$dimnames[[1]])]<- nshifts 197 | #Create an index equal to the number of segments that identifies the branch on which each segment is found 198 | irow <- rep(1:nbranch,shifts+1) 199 | #For now, starting height is just the height of the node 200 | csbase <- cache$nH[irow] 201 | #Calculate the ending height by sorting the edge.length and the location of shifts by their branch identity and location 202 | csadd <- c(tree$edge.length, pars$loc) 203 | tmp.o <- c(1:nbranch, pars$sb) 204 | names(csadd) <- tmp.o 205 | add.o <- order(tmp.o,csadd) 206 | csadd <- csadd[add.o] 207 | #Ending height of the segment 208 | csmaps <- csadd + csbase 209 | #We need to know what the ending theta is for each segment, so we sort pars$t2 as we did for pars$loc, but +1 because t2 is the ending regime 210 | t2index <- add.o[which(add.o > nbranch)] 211 | t2b <- c(rep(1,length(csmaps))) 212 | t2b[match(t2index,add.o)+1] <- pars$t2[t2index-nbranch] 213 | #Now we need to cascade these regime down the tree. We won't need to cascade sandwiches, as they are trapped on the branch they occur. So we find them below: 214 | loc.o <- order(pars$loc,decreasing=TRUE) 215 | sandwiches <- duplicated(pars$sb[loc.o]) 216 | # And remove them: 217 | if(sum(sandwiches)>0){ 218 | sb.down <- pars$sb[!sandwiches] 219 | t2.down <- pars$t2[!sandwiches] 220 | } else {sb.down <- pars$sb; t2.down <- pars$t2} 221 | #Now we order the sb's and t2's to prepare for a postorder tree traversal 222 | sb.o <- order(sb.down) 223 | sb.down <- sb.down[sb.o] 224 | t2.down <- t2.down[sb.o] 225 | sb.desc <- cache$bdesc[sb.down] 226 | #Loop traveling down the tree, saving all descendents that are from that shift into the vector censored. These branches cannot be modified by shifts further down the tree. 227 | censored <- NULL 228 | name.o <- names(csmaps) 229 | names(t2b) <- name.o 230 | for(i in 1:length(sb.desc)){ 231 | sb.desc[[i]] <- sb.desc[[i]][!(sb.desc[[i]] %in% censored)] 232 | censored <- c(censored, sb.desc[[i]]) 233 | t2b[name.o[name.o %in% sb.desc[[i]]]] <- t2.down[i] 234 | } 235 | names(csmaps) <- t2b 236 | multips <- which(irow[2:length(irow)]==irow[1:(length(irow)-1)]) 237 | #Set segments with more than one shift per branch to start at end of last shift 238 | csbase[multips+1] <- csmaps[multips] 239 | #Exponential term 1 240 | oW <- pars$alpha*(csbase-cache$height) 241 | #Exponential term 2 242 | nW <- (csmaps-csbase)*pars$alpha 243 | #If value of expnential term is too large (resulting in overflow), then use approximation 244 | if(any(nW>500)){ 245 | tmp <- ifelse(nW>500, exp(nW+oW), exp(oW)*(exp(nW)-1)) 246 | } else { 247 | tmp <- exp(oW)*(exp(nW)-1) 248 | } 249 | #Set up branch weight matrix 250 | bW <- matrix(0,nrow=nbranch,ncol=pars$ntheta) 251 | #Set up index over matrix, so that values go to right row index and column, based on the name of the segment in maps 252 | index <- irow + (as.integer(names(tmp))-1)*nbranch 253 | if(any(duplicated(index))){ 254 | tmp <- tapply(tmp,index,sum) 255 | bW[as.numeric(names(tmp))] <- tmp 256 | } else {bW[index] <- tmp} 257 | W=cache$branchtrace%*%bW 258 | W[,1] <- W[,1]+exp(-cache$height*pars$alpha) 259 | } else { 260 | W <- matrix(rep(1,cache$ntips),ncol=1) 261 | } 262 | return(W) 263 | } 264 | 265 | # Calculate the weight matrix for an auteur bm-jumps model 266 | # 267 | # Example: 268 | #pars <- list(sig2 = 1, sig2jump = 2, k=2, ntheta=3, sb= c(447, 436), t2= c(2, 3), loc= c(0,0)) 269 | .auteur.W <- function(cache, pars){ 270 | nbranch <- length(cache$edge.length) 271 | nshifts <- table(pars$sb) 272 | shifts <- rep(0, nbranch) 273 | shifts[as.numeric(attributes(nshifts)$dimnames[[1]])] <- nshifts 274 | irow <- rep(1:nbranch, shifts + 1) 275 | #segs <- c(cache$edge.length, pars$loc) 276 | t2b <- rep(1, nbranch+pars$k) 277 | tmp.o <- c(1:nbranch, pars$sb) 278 | names(t2b) <- tmp.o 279 | add.o <- order(tmp.o, t2b) 280 | t2b <- t2b[add.o] 281 | ind <- names(t2b) 282 | t2index <- add.o[which(add.o > nbranch)] 283 | t2b[match(t2index, add.o) + 1] <- pars$t2[t2index - nbranch] 284 | loc.o <- order(pars$loc, decreasing = TRUE) 285 | sandwiches <- loc.o[duplicated(pars$sb[loc.o])] 286 | if (length(sandwiches) > 0) { 287 | sb.down <- pars$sb[-sandwiches] 288 | t2.down <- pars$t2[-sandwiches] 289 | } else { 290 | sb.down <- pars$sb 291 | t2.down <- pars$t2 292 | } 293 | sb.o <- order(sb.down) 294 | sb.down <- sb.down[sb.o] 295 | t2.down <- t2.down[sb.o] 296 | sb.desc <- cache$bdesc[sb.down] 297 | desc.length <- unlist(lapply(sb.desc, length), F, F) 298 | sb.desc <- sb.desc[desc.length > 0] 299 | #names(t2b) <- names(segs) 300 | sb.desc2 <- unlist(sb.desc, F, F) 301 | sb.dup <- duplicated(sb.desc2) 302 | sb.desc3 <- sb.desc2[!sb.dup] 303 | t2.names <- rep(t2.down[desc.length > 0], unlist(lapply(sb.desc, 304 | length), F, F)) 305 | t2.names <- t2.names[!sb.dup] 306 | t2b[as.character(unlist(sb.desc3, F, F))] <- t2.names 307 | return(t2b) 308 | } 309 | #.auteur.W(cache, pars) %*% 310 | 311 | 312 | -------------------------------------------------------------------------------- /R/bayou-custommodel-input.R: -------------------------------------------------------------------------------- 1 | getPreValues <- function(cache, col){ 2 | V <- phytools::vcvPhylo(cache$phy, anc.nodes=FALSE) 3 | X <- cache$pred[,col] 4 | unknown <- is.na(X) 5 | known <- !unknown 6 | Vkk <- V[known, known] 7 | Vuu <- V[unknown, unknown] 8 | Vku <- V[known, unknown] 9 | Vuk <- V[unknown, known] 10 | iVkk <- solve(Vkk) 11 | sigmabar <- as.matrix(Matrix::forceSymmetric(Vuu - Vuk%*%iVkk%*%Vku)) 12 | cholSigmabar <- chol(sigmabar) 13 | mubarmat <- Vuk%*%iVkk 14 | return(list(V=V, X=X, unknown=unknown, known=known, Vkk=Vkk, Vuu=Vuu, Vku=Vku, Vuk=Vuk, iVkk=iVkk, sigmabar=sigmabar, mubarmat=mubarmat, cholSigmabar=cholSigmabar)) 15 | } 16 | 17 | # Proposal function to simulate conditional draws from a multivariate normal distribution 18 | .imputePredBM <- function(cache, pars, d, move,ct=NULL, prevalues=pv, prior=prior){ 19 | #(tree, dat, sig2, plot=TRUE, ...){ 20 | X <- prevalues$X 21 | Vuk <- pars$pred.sig2*prevalues$Vuk 22 | iVkk <- (1/pars$pred.sig2)*prevalues$iVkk 23 | Vku <- pars$pred.sig2*prevalues$Vku 24 | Vuu <- pars$pred.sig2*prevalues$Vuu 25 | known <- prevalues$known 26 | unknown <- prevalues$unknown 27 | mu <- rep(pars$pred.root, cache$n) 28 | muk <- mu[known] 29 | muu <- mu[unknown] 30 | mubar <- t(muu + Vuk%*%iVkk%*%(X[known]-muk)) 31 | sigmabar <- Vuu - Vuk%*%iVkk%*%Vku 32 | res <- MASS::mvrnorm(1, mubar, sigmabar) 33 | pars.new <- pars 34 | pars.new$missing.pred <- res 35 | hr=Inf 36 | type="impute" 37 | return(list(pars=pars.new, hr=hr, decision = type)) 38 | } 39 | 40 | .make.monitorFn <- function(model, noMonitor=c("missing.pred", "ntheta"), integers=c("gen","k")){ 41 | parorder <- model$parorder 42 | rjpars <- model$rjpars 43 | exclude <- which(parorder %in% noMonitor) 44 | if(length(exclude) > 0){ 45 | pars2monitor <- parorder[-exclude] 46 | } else {pars2monitor <- parorder} 47 | if(length(rjpars) > 0){ 48 | rjp <- which(pars2monitor %in% rjpars) 49 | pars2monitor[rjp] <- paste("r", pars2monitor[rjp], sep="") 50 | } 51 | pars2monitor <- c("gen", "lnL", "prior", pars2monitor) 52 | type <- rep(".2f", length(pars2monitor)) 53 | type[which(pars2monitor %in% integers)] <- "i" 54 | string <- paste(paste("%-8", type, sep=""), collapse="") 55 | monitor.fn = function(i, lik, pr, pars, accept, accept.type, j){ 56 | names <- pars2monitor 57 | #names <- c("gen", "lnL", "prior", "alpha" , "sig2", "rbeta1", "endo", "k") 58 | #string <- "%-8i%-8.2f%-8.2f%-8.2f%-8.2f%-8.2f%-8.2f%-8i" 59 | acceptratios <- unlist(accept/accept.type) #tapply(accept, accept.type, mean) 60 | names <- c(names, names(acceptratios)) 61 | if(j==0){ 62 | cat(sprintf("%-7.7s", names), "\n", sep=" ") 63 | } 64 | cat(sprintf(string, i, lik, pr, pars$alpha, pars$sig2, pars$beta1[1], pars$endo, pars$k), sprintf("%-8.2f", acceptratios),"\n", sep="") 65 | } 66 | } 67 | 68 | .getTipMap <- function(pars, cache){ 69 | map <- .pars2map(pars,cache) 70 | tipreg <- rev(map$theta) 71 | ntipreg <- rev(map$branch) 72 | #ntipreg <- names(map$theta) 73 | dups <- !duplicated(ntipreg) & ntipreg %in% (1:nrow(cache$edge))[cache$externalEdge] 74 | tipreg <- tipreg[which(dups)] 75 | ntipreg <- ntipreg[which(dups)] 76 | o <- order(cache$edge[as.numeric(ntipreg), 2]) 77 | betaID <- tipreg[o] 78 | } 79 | 80 | 81 | .colorRamp <- function(trait, pal, nn){ 82 | strait <- (trait-min(trait))/max(trait-min(trait)) 83 | itrait <- round(strait*nn, 0)+1 84 | return(pal(nn+1)[itrait]) 85 | } 86 | 87 | .addColorBar <- function(x, y, height, width, pal, trait, ticks, adjx=0, n=100,cex.lab=1,pos=2, text.col="black"){ 88 | legend_image <- as.raster(matrix(rev(pal(n)),ncol = 1)) 89 | #text(x = 1.5, y = round(seq(range(ave.Div)[1], range(ave.Div)[2], l = 5), 2), labels = seq(range(ave.Div)[1], range(ave.Div)[2], l = 5)) 90 | seqtrait <- seq(min(trait), max(trait), length.out=nrow(legend_image)) 91 | mincut <- n-which(abs(seqtrait - min(ticks))==min(abs(seqtrait-min(ticks)))) 92 | maxcut <- n-which(abs(seqtrait - max(ticks))==min(abs(seqtrait-max(ticks)))) 93 | legend_cut <- legend_image[maxcut:mincut,] 94 | legend_cut <- rbind(matrix(rep(legend_image[1,1],round(0.05*n,0)),ncol=1), legend_cut) 95 | rasterImage(legend_cut, x, y, x+width, y+height) 96 | ticklab <- format(ticks, digits=2, trim=TRUE) 97 | ticklab[length(ticklab)] <- paste(">", ticklab[length(ticklab)], sep="") 98 | text(x+adjx, y=seq(y, y+height, length.out=length(ticks)), labels=ticklab, pos=pos,cex=cex.lab, col=text.col) 99 | } 100 | 101 | 102 | #' This function makes a bayou model object that can be used for customized allometric regression models. 103 | #' 104 | #' @param f A formula describing the relationship between the data and one or more predictors (use 'dat' 105 | #' for the dependent variable) 106 | #' @param rjpars A character vector of parameters to split at the mapped shifts on the tree 107 | #' @param tree A phylogenetic tree 108 | #' @param dat A named vector of trait data (dependent variable) 109 | #' @param pred A matrix or data frame with named columns with predictor data represented in the specified 110 | #' formula 111 | #' @param prior A prior function made by the 'make.prior' function 112 | #' @param SE A single value or vector of measurement error estimates 113 | #' @param impute The name of a single predictor for which missing values will be imputed using BM (see details). 114 | #' Default is NULL. 115 | #' @param startpar An optional list of starting parameters for the model. If not provided, the model will simulate 116 | #' starting values from the prior function. 117 | #' @param moves An optional list of moves to be passed on to bayou.makeMCMC. 118 | #' @param control.weights An optional list of control weights to be passed on to bayou.makeMCMC. 119 | #' @param D A vector of tuning parameters to be passed on to bayou.makeMCMC. 120 | #' @param shiftpars The names of the parameters defining the map of shifts (for now, always c("sb", "loc", "t2")). 121 | #' @param model The parameterization of the OU model, either "OU", "OUrepar" or "QG". 122 | #' @param slopechange "immediate", "alphaWeighted" or "fullPGLS" 123 | #' 124 | #' @details This function generates a list with the '$model', which provides the specifications of the regression 125 | #' model and '$startpar', which provides starting values to input into bayou.makeMCMC. Note that this model assumes 126 | #' that predictors immediately affect trait values at a shift. In other words, regardless of the past history of the 127 | #' predictor, only the current value affects the current expected trait value. This is only reasonable for allometric 128 | #' models, although it may be appropriate for other models if phylogenetic inertia is very low (short half-lives). 129 | #' 130 | #' One predictor variable may include missing data (coded as "NA"). The model will assume the maximum-likelihood 131 | #' best-fit BM model and simulate the missing predictor values throughout the course of the MCMC. These values will 132 | #' then be used to calculate the likelihood given the parameters for each MCMC step. 133 | #' 134 | #' @export 135 | makeBayouModel <- function(f, rjpars, tree, dat, pred, prior, SE=0, slopechange="immediate", impute=NULL, startpar=NULL, moves=NULL, control.weights=NULL, D=NULL, shiftpars=c("sb", "loc", "t2"), model="OU"){ 136 | cache <- .prepare.ou.univariate(tree, dat, SE=SE, pred=pred) 137 | vars <- terms(f) 138 | cache$pred <- as.data.frame(cache$pred) 139 | dep <- rownames(attr(vars, "factors"))[attr(vars, "response")] 140 | mf <- cbind(cache$dat, cache$pred) 141 | colnames(mf)[1] <- dep 142 | MF <- model.frame(f, data=mf, na.action=na.pass) 143 | MM <- model.matrix(f, MF) 144 | colnames(MM) <- gsub(":", "x", colnames(MM)) 145 | parnames <- paste("beta", colnames(MM)[-1], sep="_") 146 | if(length(rjpars) > 0){ 147 | rjpars2 <- c(rjpars, paste("beta", rjpars, sep="_")) 148 | rj <- which(colnames(MM) %in% rjpars2)-1 149 | if(slopechange=="alphaWeighted"){ 150 | expFn <- function(pars, cache){ 151 | W <- C_weightmatrix(cache, pars)$W 152 | if(length(impute)>0){ 153 | MF[is.na(MF[,impute]),impute] <- pars$missing.pred #$impute 154 | MM <- model.matrix(f, MF) 155 | } 156 | parframe <- lapply(pars[parnames], function(x) return(x)) 157 | parframe[rj] <- lapply(parframe[rj], function(x) W%*%x) 158 | ExpV <- apply(sapply(1:length(parframe), function(x) parframe[[x]]*MM[,x+1]), 1, sum) 159 | return(ExpV) 160 | } 161 | } else { 162 | expFn <- function(pars, cache){ 163 | betaID <- .getTipMap(pars, cache) 164 | if(length(impute)>0){ 165 | MF[is.na(MF[,impute]),impute] <- pars$missing.pred #$impute 166 | MM <- model.matrix(f, MF) 167 | } 168 | parframe <- lapply(pars[parnames], function(x) return(x)) 169 | parframe[rj] <- lapply(parframe[rj], function(x) x[betaID]) 170 | ExpV <- apply(sapply(1:length(parframe), function(x) parframe[[x]]*MM[,x+1]), 1, sum) 171 | return(ExpV) 172 | } 173 | } 174 | } else { 175 | rjpars2 <- numeric(0) 176 | expFn <- function(pars, cache){ 177 | #betaID <- getTipMap(pars, cache) 178 | if(length(impute)>0){ 179 | MF[is.na(MF[,impute]),impute] <- pars$missing.pred #$impute 180 | MM <- model.matrix(f, MF) 181 | } 182 | parframe <- lapply(pars[parnames], function(x) return(x)) 183 | #parframe[rjpars] <- lapply(parframe[rjpars], function(x) x[betaID]) 184 | ExpV <- apply(sapply(1:length(parframe), function(x) parframe[[x]]*MM[,x+1]), 1, sum) 185 | return(ExpV) 186 | } 187 | } 188 | varnames <- switch(model, "OU"=c("alpha","sig2"), "OUrepar"=c("halflife", "Vy"), "QG"=c("h2", "P", "Ne", "w2")) 189 | if(model=="OU"){ 190 | varTransform <- function(pars) return(pars) 191 | } 192 | if(model=="OUrepar"){ 193 | varTransform <- function(pars){ 194 | repar <- OU.repar(pars) 195 | pars$alpha <- repar$alpha 196 | pars$sig2 <- repar$sig2 197 | return(pars) 198 | } 199 | } 200 | if(model=="QG"){ 201 | varTransform <- function(pars){ 202 | pars$alpha <- QG.alpha(pars) 203 | pars$sig2 <- QG.sig2(pars) 204 | return(pars) 205 | } 206 | } 207 | likFn <- function(pars, cache, X, model="Custom"){ 208 | n <- cache$n 209 | X <- cache$dat 210 | pred <- cache$pred 211 | ## Permit alternative OU parameterizations 212 | pars <- varTransform(pars) 213 | ## Specify the model here 214 | X = X - expFn(pars, cache) 215 | cache$dat <- X 216 | ### The part below mostly does not change 217 | pars2 <- pars 218 | if(slopechange=="fullPGLS"){pars2$alpha = 1e10} 219 | X.c <- C_weightmatrix(cache, pars2)$resid 220 | transf.phy <- C_transf_branch_lengths(cache, 1, X.c, pars$alpha) 221 | transf.phy$edge.length[cache$externalEdge] <- transf.phy$edge[cache$externalEdge] + cache$SE[cache$phy$edge[cache$externalEdge, 2]]^2*(2*pars$alpha)/pars$sig2 222 | comp <- C_threepoint(list(n=n, N=cache$N, anc=cache$phy$edge[, 1], des=cache$phy$edge[, 2], diagMatrix=transf.phy$diagMatrix, P=X.c, root=transf.phy$root.edge, len=transf.phy$edge.length)) 223 | if(pars$alpha==0){ 224 | inv.yVy <- comp$PP/pars$sig2 225 | detV <- comp$logd + n*log(pars$sig2) 226 | } else { 227 | inv.yVy <- comp$PP*(2*pars$alpha)/(pars$sig2) 228 | detV <- comp$logd+n*log(pars$sig2/(2*pars$alpha)) 229 | } 230 | llh <- -0.5*(n*log(2*pi)+detV+inv.yVy) 231 | return(list(loglik=llh, theta=pars$theta,resid=X.c, comp=comp, transf.phy=transf.phy)) 232 | } 233 | monitorFn <- function(i, lik, pr, pars, accept, accept.type, j){ 234 | names <- c("gen", "lnL", "prior", varnames, parnames, "rtheta", "k") 235 | format <- c("%-8i",rep("%-8.2f",4), rep("%-8.2f", length(parnames)), "%-8.2f","%-8i") 236 | acceptratios <- unlist(accept/accept.type) #tapply(accept, accept.type, mean) 237 | names <- c(names, names(acceptratios)) 238 | if(j==0){ 239 | cat(sprintf("%-7.7s", names), "\n", sep=" ") 240 | } 241 | item <- c(i, lik, pr, pars[[varnames[1]]], pars[[varnames[2]]], sapply(pars[parnames], function(x) x[1]), pars$theta[1], pars$k) 242 | cat(sapply(1:length(item), function(x) sprintf(format[x], item[x])), sprintf("%-8.2f", acceptratios),"\n", sep="") 243 | } 244 | rdists <- .getSimDists(prior) 245 | ## Set default moves if not specified. 246 | if(length(rjpars) > 0){ 247 | if(is.null(moves)){ 248 | moves = c(switch(model, "OU" = list(alpha=".multiplierProposal", sig2=".multiplierProposal"), 249 | "OUrepar" = list(halflife=".jointHalflifeVyProposal", Vy=".jointHalflifeVyProposal")), 250 | as.list(setNames(rep(".vectorSlidingWindowSplit", length(parnames)), parnames)), 251 | c(theta=".vectorSlidingWindowSplit", k=".splitmergePrior", slide=".slide2")) 252 | } 253 | if(is.null(control.weights)){ 254 | control.weights <- setNames(rep(1, length(parnames)+5), c(varnames, parnames, "k", "theta", "slide")) 255 | control.weights[c(varnames[1], parnames)] <- 2 256 | control.weights[c("theta", parnames[rj])] <- 10 257 | control.weights["k"] <- 5 258 | control.weights <- as.list(control.weights) 259 | } 260 | 261 | if(is.null(D)){ 262 | D <- lapply(rdists[!(names(rdists) %in% shiftpars)], function(x) sd(x(1000))/50) 263 | D$k <- rep(1, length(rjpars)) 264 | D$slide <- 1 265 | } 266 | { 267 | parorder <- c(varnames, parnames,"theta", "k","ntheta") 268 | rjord <- which(parorder %in% rjpars2) 269 | fixed <- names(attributes(prior)$fixed) 270 | if(length(rjord > 0)){ 271 | parorder <- c(parorder[-rjord], fixed , parorder[rjord]) 272 | } else { 273 | parorder <- c(parorder, fixed) 274 | } 275 | parorder <- parorder[!duplicated(parorder) & !(parorder %in% shiftpars)] 276 | 277 | } 278 | if(is.null(startpar)){ 279 | startpar <- priorSim(prior, cache$phy, shiftpars=rjpars2)$pars[[1]] 280 | startpar <- startpar[c(parorder, shiftpars)] 281 | #simdists <- rdists[parorder[!(parorder %in% c(rjpars2,shiftpars, "ntheta"))]] 282 | #if(length(attributes(prior)$fixed)>0){ 283 | # simdists[names(attributes(prior)$fixed)] <- lapply(1:length(attributes(prior)$fixed), function(x) function(n) attributes(prior)$fixed[[x]]) 284 | # fixed.pars <- attributes(prior)$fixed 285 | # fixed <- TRUE 286 | #} else {fixed <- FALSE} 287 | #simdists <- simdists[!is.na(names(simdists))] 288 | #startpar <- lapply(simdists, function(x) x(1)) 289 | #startpar$ntheta <- startpar$k+1 290 | #startpar[parorder[(parorder %in% c(rjpars2))]] <- lapply(rdists[parorder[(parorder %in% c(rjpars2))]], function(x) x(startpar$ntheta)) 291 | #startpar <- c(startpar, list(sb=sample(1:length(cache$bdesc), startpar$k, replace=FALSE, prob = sapply(cache$bdesc, length)), loc=rep(0, startpar$k), t2=2:startpar$ntheta)) 292 | #startpar <- startpar[c(parorder, shiftpars)] 293 | } 294 | } else { 295 | rj <- numeric(0) 296 | if(is.null(moves)){ 297 | moves = c(switch(model, "OU" = list(alpha=".multiplierProposal", sig2=".multiplierProposal"), 298 | "OUrepar" = list(halflife=".jointHalflifeVyProposal", Vy=".jointHalflifeVyProposal")), 299 | as.list(setNames(rep(".vectorSlidingWindowSplit", length(parnames)), parnames)), 300 | c(theta=".vectorSlidingWindowSplit")) 301 | } 302 | if(is.null(control.weights)){ 303 | control.weights <- setNames(rep(1, length(parnames)+5), c(varnames, parnames, "k", "theta", "slide")) 304 | control.weights[c(varnames[1], parnames)] <- 2 305 | control.weights[c("theta", parnames[rj])] <- 6 306 | control.weights[c("k","slide")] <- 0 307 | control.weights <- as.list(control.weights) 308 | } 309 | if(is.null(D)){ 310 | D <- lapply(rdists[!(names(rdists) %in% shiftpars)], function(x) sd(x(1000))/50) 311 | D$k <- 1 312 | D$slide <- 1 313 | } 314 | { 315 | parorder <- c(varnames, parnames,"theta", "k","ntheta") 316 | rjord <- which(parorder %in% rjpars2) 317 | fixed <- names(attributes(prior)$fixed) 318 | if(length(rjord > 0)){ 319 | parorder <- c(parorder[-rjord], fixed , parorder[rjord]) 320 | } else { 321 | parorder <- c(parorder, fixed) 322 | } 323 | parorder <- parorder[!duplicated(parorder) & !(parorder %in% shiftpars)] 324 | } 325 | if(is.null(startpar)){ 326 | startpar <- priorSim(prior, cache$phy, shiftpars = rjpars2)$pars[[1]] 327 | startpar <- startpar[c(parorder, shiftpars)] 328 | #simdists <- rdists[parorder[!(parorder %in% c(rjpars2,shiftpars, "ntheta"))]] 329 | #if(length(attributes(prior)$fixed)>0){ 330 | # simdists[names(attributes(prior)$fixed)] <- lapply(1:length(attributes(prior)$fixed), function(x) function(n) attributes(prior)$fixed[[x]]) 331 | # fixed.pars <- attributes(prior)$fixed 332 | #} 333 | #simdists <- simdists[!is.na(names(simdists))] 334 | #startpar <- lapply(simdists, function(x) x(1)) 335 | #if(!("k" %in% fixed)){ 336 | # startpar$k <- 0 337 | # startpar$ntheta <- startpar$k+1 338 | # if(startpar$k==0) startpar$t2 <- numeric(0) else startpar$t2 <- 2:(startpar$ntheta) 339 | #} else { 340 | # startpar$ntheta <- startpar$k+1 341 | # if(startpar$k==0) startpar$t2 <- numeric(0) else startpar$t2 <- 2:(startpar$ntheta) 342 | #} 343 | #startpar <- startpar[c(parorder, shiftpars)] 344 | } 345 | } 346 | rjpars[!(rjpars %in% "theta")] <- paste("beta",rjpars[!(rjpars %in% "theta")], sep="_") 347 | model <- list(moves=moves, control.weights=control.weights, D=D, rjpars=rjpars, parorder=parorder, shiftpars=shiftpars, monitor.fn=monitorFn, call=f, expFn=expFn, lik.fn=likFn) 348 | if(length(impute)>0){ 349 | missing <- which(is.na(cache$pred[,impute])) #$impute 350 | pv <- getPreValues(cache, impute) #$impute 351 | model$moves$missing.pred <- ".imputePredBM" 352 | model$control.weights$missing.pred <- 1 353 | model$D$missing.pred <- 1 354 | startpar <- .imputePredBM(cache, startpar, d=1, NULL, ct=NULL, prevalues=pv)$pars#$impute 355 | bp <- which(names(startpar)=="pred.root") 356 | model$parorder <- c(parorder[1:bp], "missing.pred", if(length(parorder)>bp)parorder[(bp+1):length(parorder)] else NULL) 357 | startpar <- startpar[c(parorder, names(startpar)[!names(startpar) %in% parorder])] 358 | model$prevalues <- pv 359 | } 360 | 361 | #try(prior(startpar)) 362 | #try(likFn(startpar, cache, cache$dat)) 363 | return(list(model=model, startpar=startpar)) 364 | } 365 | 366 | 367 | .getSimDists <- function(prior){ 368 | dists <- attributes(prior)$dist 369 | fixed <- which(attributes(prior)$dist=="fixed") 370 | notfixed <- which(attributes(prior)$dist!="fixed") 371 | dists <- dists[notfixed] 372 | prior.params <- attributes(prior)$param 373 | rdists <- lapply(dists,function(x) gsub('^[a-zA-Z]',"r",x)) 374 | prior.params <- lapply(prior.params,function(x) x[-which(names(x)=="log")]) 375 | rdists.fx <- lapply(rdists,get) 376 | rdists.fx <- lapply(1:length(rdists.fx),function(x) .set.defaults(rdists.fx[[x]],defaults=prior.params[[x]])) 377 | names(rdists.fx) <- gsub('^[a-zA-Z]',"",names(rdists)) 378 | return(rdists.fx) 379 | } --------------------------------------------------------------------------------