├── .Rbuildignore ├── .gitignore ├── .lintr ├── .travis.yml ├── Codecov.png ├── DESCRIPTION ├── LICENSE ├── NAMESPACE ├── R ├── annotatedTreeReader.R ├── calc_act.R ├── calc_ess.R ├── calc_esses.R ├── drop_tip_write_annot_tree.R ├── is_posterior.R ├── is_trees_posterior.R ├── newCode.R ├── parse_beast_log.R ├── parse_beast_posterior.R ├── parse_beast_state.R ├── parse_beast_trees.R ├── plotStackedAreas.R ├── plot_glm.R ├── read_beast2_trees.R ├── remove_burn_in.R └── remove_burn_ins.R ├── RBeast.Rproj ├── README.md ├── TravisCI.png ├── inst ├── extdata │ ├── beast2_example_output.log │ ├── beast2_example_output.trees │ ├── beast2_example_output.xml │ ├── beast2_example_output.xml.state │ ├── beast_glm_example.log │ └── read_beast2_trees_example.trees └── java │ └── beast.jar ├── man ├── calc_act.Rd ├── calc_act_r.Rd ├── calc_ess.Rd ├── calc_esses.Rd ├── is_posterior.Rd ├── is_trees_posterior.Rd ├── parse_beast_log.Rd ├── parse_beast_posterior.Rd ├── parse_beast_state_operators.Rd ├── parse_beast_trees.Rd ├── plot_glm.Rd ├── plot_simple_glm.Rd ├── read_beast2_trees.Rd ├── remove_burn_in.Rd ├── remove_burn_ins.Rd └── runBeast.Rd ├── tests ├── testthat.R └── testthat │ ├── test-calc_act.R │ ├── test-calc_ess.R │ ├── test-calc_esses.R │ ├── test-is_posterior.R │ ├── test-is_trees_posterior.R │ ├── test-parse_beast_log.R │ ├── test-parse_beast_state_operators.R │ ├── test-parse_beast_trees.R │ ├── test-read_beast2_trees.R │ ├── test-remove_burn_in.R │ └── test-remove_burn_ins.R └── vignettes ├── GLM_plot.Rmd ├── demo_estimate_effective_sample_size.R ├── demo_estimate_effective_sample_size.Rmd ├── demo_estimate_effective_sample_size.html ├── profile_calc_act.R ├── profile_calc_act.Rmd ├── profile_calc_act.html ├── profile_calc_esses.R ├── profile_calc_esses.Rmd ├── profile_calc_esses.html ├── read_beast2_trees.R ├── read_beast2_trees.Rmd └── read_beast2_trees.html /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis.yml$ 4 | ^.lintr$ 5 | ^Codecov\.png$ 6 | ^TravisCI\.png$ -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | inst/doc 5 | -------------------------------------------------------------------------------- /.lintr: -------------------------------------------------------------------------------- 1 | linters: with_defaults( 2 | camel_case_linter = NULL, 3 | snake_case_linter = NULL, 4 | commented_code_linter = NULL, 5 | NULL) 6 | exclusions: list("R/newCode.R", "R/plotStackedAreas.R") 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | cache: packages 3 | 4 | r_github_packages: 5 | - jimhester/covr 6 | - jimhester/lintr 7 | - richelbilderbeek/tracerer 8 | - MangoTheCat/goodpractice 9 | 10 | after_success: 11 | - Rscript -e 'lintr::lint_package()' 12 | - Rscript -e 'covr::codecov()' 13 | - Rscript -e 'goodpractice::gp()' 14 | 15 | after_failure: 16 | - Rscript -e 'lintr::lint_package()' 17 | - Rscript -e 'covr::codecov()' 18 | - Rscript -e 'goodpractice::gp()' 19 | - cat /home/travis/build/beast-dev/RBeast/..Rcheck/00install.out 20 | - cat /home/travis/build/beast-dev/RBeast/..Rcheck/00check.log 21 | -------------------------------------------------------------------------------- /Codecov.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beast-dev/RBeast/1e9ba811a1ac328dc4ee9209bb0c68c19fa3e43e/Codecov.png -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: RBeast 2 | Type: Package 3 | Title: Create BEAST and BEAST2 input files and parse their output 4 | Version: 0.1.0 5 | Author: Nuno Faria [aut, cre], 6 | Marc A. Suchard [aut, cre] 7 | Maintainer: Marc A. Suchard 8 | Description: 9 | BEAST and BEAST2 are tools for Bayesian phylogenetic inference. 10 | This package allows to create input parameter files from R, 11 | and to parse their output files. 12 | License: file LICENSE 13 | LazyData: TRUE 14 | Imports: 15 | tracerer, 16 | jsonlite, 17 | rJava 18 | Suggests: 19 | ape, 20 | coda, 21 | ggplot2, 22 | knitr, 23 | phangorn, 24 | OutbreakTools, 25 | geiger, 26 | rbenchmark, 27 | reshape2, 28 | rmarkdown, 29 | testit, 30 | testthat 31 | Remotes: 32 | jimhester/covr, 33 | jimhester/lintr, 34 | richelbilderbeek/tracerer, 35 | MangoTheCat/goodpractice 36 | VignetteBuilder: knitr 37 | RoxygenNote: 6.1.1 38 | URL: https://github.com/beast-dev/RBeast 39 | BugReports: https://github.com/beast-dev/RBeast/issues 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 Marc A. Suchard, Nuno Faria, Richel J.C. Bilderbeek 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(calc_act) 4 | export(calc_act_r) 5 | export(calc_ess) 6 | export(calc_esses) 7 | export(is_posterior) 8 | export(is_trees_posterior) 9 | export(parse_beast_log) 10 | export(parse_beast_posterior) 11 | export(parse_beast_state_operators) 12 | export(parse_beast_trees) 13 | export(plot_glm) 14 | export(plot_simple_glm) 15 | export(read_beast2_trees) 16 | export(remove_burn_in) 17 | export(remove_burn_ins) 18 | export(runBeast) 19 | -------------------------------------------------------------------------------- /R/annotatedTreeReader.R: -------------------------------------------------------------------------------- 1 | ## 2 | ## @author Marc A. Suchard 3 | ## 4 | ## A class for reading Newick formatted trees with BEAST-style annotations 5 | ## 6 | 7 | .strip.annotations <- function(text) { 8 | annotations <- list() 9 | end <- 1 10 | 11 | # Merge node and branch annotations 12 | text <- gsub("\\[&(.*?)\\]:\\[&(.*?)\\]", ":\\[&\\1,\\2\\]", text) 13 | text <- gsub("\\[&(.*?)\\]:", ":\\[&\\1]", text) 14 | 15 | pattern = "\\[&.*?\\]" 16 | 17 | repeat { 18 | match = regexpr(pattern=pattern,text=text) 19 | if (!(match[1] > 0)) { 20 | break 21 | } 22 | annotations[[end]] = regmatches(text, match) 23 | text = sub(pattern,paste("[",end,"]",sep=""), text) 24 | end = end + 1 25 | } 26 | return(list(annotations=annotations,tree=text)) 27 | } 28 | 29 | .split.tree.names <- function(text) { 30 | text = gsub(pattern="\\[.*?\\]=",x=text,replacement="") 31 | text = gsub(pattern="^tree",x=text,replacement="") 32 | return(text) 33 | } 34 | 35 | .split.tree.traits <- function(text) { 36 | 37 | ## Pull out annotation 38 | text = regmatches(text,regexpr(pattern="\\[.*?\\]",text)) 39 | ## Remove leading and trailing delimitors 40 | text = substring(text,3,nchar(text)-1) 41 | return(text) 42 | } 43 | 44 | .parse.value <- function(text) { 45 | value = text 46 | if (length(grep("^\\{",value))) { ## starts with { 47 | save = value 48 | value = substring(value, 2, nchar(value)-1) 49 | 50 | depth = 0 51 | r = regexpr(pattern="\\{+",value,perl=TRUE) 52 | match.length = attr(r, "match.length") 53 | 54 | if (match.length > 0) { 55 | depth = match.length 56 | } 57 | 58 | if (depth == 0) { 59 | split = "," 60 | } else { 61 | split = paste( 62 | "(?<=",rep("\\}",depth),")", 63 | ",", 64 | "(?=" ,rep("\\{",depth),")", 65 | sep="") 66 | } 67 | 68 | if (depth >= 1) { 69 | return(save) # TODO Still error in recursion 70 | } 71 | 72 | part = strsplit(value, split, perl=TRUE)[[1]] 73 | value = list() 74 | for (i in 1:length(part)) { 75 | value[[i]] = .parse.value(part[i]) 76 | } 77 | ## TODO Unlist when simple array? 78 | } else { 79 | if (!is.na(suppressWarnings(as.numeric(value)))) { # is a number 80 | value = as.numeric(value) 81 | } else { # is a string 82 | value <- gsub("\\\"","", value) 83 | } 84 | } 85 | return(value) 86 | } 87 | 88 | .parse.traits <- function(text, header=FALSE) { 89 | 90 | if (header == TRUE) { 91 | text = substring(text,3,nchar(text)-1) 92 | } 93 | 94 | pattern <- "(\"[^\"]*\"+|[^,=\\s]+)\\s*(=\\s*(\\{[^=]*\\}|\"[^\"]*\"+|[^,]+))?" 95 | 96 | rgx <- gregexpr(pattern,text,perl=TRUE) 97 | n <- length(attr(rgx[[1]],"match.length")) 98 | traits <- list() 99 | start <- attr(rgx[[1]],"capture.start") 100 | names <- attr(rgx[[1]],"capture.names") 101 | length <- attr(rgx[[1]],"capture.length") 102 | names <- attr(rgx[[1]],"capture.names") 103 | for (i in 1:n) { 104 | s <- start[i,3] 105 | e <- s + length[i,3] - 1 106 | value <- substring(text,s,e) 107 | 108 | s <- start[i,1] 109 | e <- s + length[i,1] - 1 110 | key <- substring(text,s,e) 111 | 112 | traits[[key]] <- .parse.value(value) 113 | } 114 | 115 | return(traits) 116 | } 117 | 118 | .annotated.clado.build <- function(tp) { 119 | stop(paste("Annotated clado.build is not yet implemented.\n")) 120 | } 121 | 122 | ## THE CODE BELOW COMES FROM 'ape'. MY GOAL IS TO DERIVE FROM THIS TO READ IN BEAST-STYLE ANNOTATIONS 123 | 124 | .annotated.tree.build <- function(tp){ 125 | 126 | add.internal <- function() { 127 | edge[j, 1] <<- current.node 128 | edge[j, 2] <<- current.node <<- node <<- node + 1L 129 | index[node] <<- j 130 | j <<- j + 1L 131 | } 132 | add.terminal <- function() { 133 | edge[j, 1] <<- current.node 134 | edge[j, 2] <<- tip 135 | index[tip] <<- j 136 | X <- unlist(strsplit(new.tpc[k], ":")) 137 | tip.label[tip] <<- X[1] 138 | index <- length(X) 139 | edge.length[j] <<- as.numeric(X[index]) 140 | 141 | if (length(annotations) > 0) { 142 | permute[[j]] <<- annotations[[as.numeric(X[2])]] ## permute traits 143 | } 144 | 145 | k <<- k + 1L 146 | tip <<- tip + 1L 147 | j <<- j + 1L 148 | } 149 | go.down <- function() { 150 | l <- index[current.node] 151 | X <- unlist(strsplit(new.tpc[k], ":")) 152 | node.label[current.node - nb.tip] <<- X[1] 153 | index <- length(X) 154 | edge.length[l] <<- as.numeric(X[index]) 155 | 156 | if (length(annotations) > 0) { 157 | permute[[l]] <<- annotations[[as.numeric(X[2])]] ## permute traits 158 | } 159 | 160 | k <<- k + 1L 161 | current.node <<- edge[l, 1] 162 | } 163 | if (!length(grep(",", tp))) { 164 | obj <- list(edge = matrix(c(2L, 1L), 1, 2)) 165 | tp <- unlist(strsplit(tp, "[\\(\\):;]")) 166 | obj$edge.length <- as.numeric(tp[3]) 167 | obj$Nnode <- 1L 168 | obj$tip.label <- tp[2] 169 | if (tp[4] != "") 170 | obj$node.label <- tp[4] 171 | class(obj) <- "phylo" 172 | return(obj) 173 | } 174 | 175 | result = .strip.annotations(tp) 176 | annotations = result$annotations 177 | new.tp.stripped = result$tree 178 | 179 | # patched for 0.0 root branch length from BEAST2 (not confirmed) 180 | new.tp.stripped <- gsub("\\]0.0;", "\\];", new.tp.stripped) 181 | 182 | root.annotation.number <- NULL 183 | m <- regexpr("\\[\\d+\\];", new.tp.stripped) 184 | if (m != -1) { 185 | root.annotation.number <- as.numeric( 186 | gsub("\\[(\\d+)\\];", "\\1", regmatches(new.tp.stripped, m))) 187 | } 188 | 189 | annotations = lapply(annotations, .parse.traits, header=TRUE) 190 | 191 | tp.stripped = gsub("\\[.*?\\]","",tp) 192 | tpc <- unlist(strsplit(tp.stripped, "[\\(\\),;]")) 193 | tpc <- tpc[nzchar(tpc)] 194 | 195 | new.tp.stripped <- gsub("\\[\\d+\\];", ";", new.tp.stripped) 196 | new.tp.stripped <- gsub("\\[(\\d+)\\]","\\1:", new.tp.stripped) 197 | new.tpc <- unlist(strsplit(new.tp.stripped, "[\\(\\),;]")) 198 | new.tpc <- new.tpc[nzchar(new.tpc)] 199 | 200 | tsp <- unlist(strsplit(tp.stripped, NULL)) 201 | skeleton <- tsp[tsp %in% c("(", ")", ",", ";")] 202 | nsk <- length(skeleton) 203 | nb.node <- sum(skeleton == ")") 204 | nb.tip <- sum(skeleton == ",") + 1 205 | nb.edge <- nb.node + nb.tip 206 | 207 | node.label <- character(nb.node) 208 | tip.label <- character(nb.tip) 209 | edge.length <- numeric(nb.edge) 210 | edge <- matrix(0L, nb.edge, 2) 211 | current.node <- node <- as.integer(nb.tip + 1) 212 | edge[nb.edge, 2] <- node 213 | index <- numeric(nb.edge + 1) 214 | index[node] <- nb.edge 215 | j <- k <- tip <- 1L 216 | 217 | permute = list() 218 | 219 | for (i in 2:nsk) { 220 | if (skeleton[i] == "(") { 221 | add.internal() 222 | } 223 | if (skeleton[i] == ",") { 224 | if (skeleton[i - 1] != ")") { 225 | add.terminal() 226 | } 227 | } 228 | if (skeleton[i] == ")") { 229 | if (skeleton[i - 1] == ",") { 230 | add.terminal() 231 | go.down() 232 | } 233 | if (skeleton[i - 1] == ")") { 234 | go.down() 235 | } 236 | } 237 | } 238 | 239 | edge <- edge[-nb.edge, ] 240 | obj <- list(edge = edge, Nnode = nb.node, tip.label = tip.label) 241 | root.edge <- edge.length[nb.edge] 242 | edge.length <- edge.length[-nb.edge] 243 | if (!all(is.na(edge.length))) 244 | obj$edge.length <- edge.length 245 | if (is.na(node.label[1])) 246 | node.label[1] <- "" 247 | if (any(nzchar(node.label))) 248 | obj$node.label <- node.label 249 | if (!is.na(root.edge)) 250 | obj$root.edge <- root.edge 251 | class(obj) <- "phylo" 252 | attr(obj, "order") <- "cladewise" 253 | 254 | if (!is.null(root.annotation.number)) { 255 | obj$root.annotation <- annotations[[root.annotation.number]] 256 | } 257 | 258 | obj$annotations = permute 259 | obj 260 | } 261 | 262 | read.annotated.tree <- function (file = "", text = NULL, tree.names = NULL, skip = 0, 263 | comment.char = "#", keep.multi = FALSE, ...) 264 | { 265 | unname <- function(treetext) { 266 | nc <- nchar(treetext) 267 | tstart <- 1 268 | while (substr(treetext, tstart, tstart) != "(" && tstart <= 269 | nc) tstart <- tstart + 1 270 | if (tstart > 1) 271 | return(c(substr(treetext, 1, tstart - 1), substr(treetext, 272 | tstart, nc))) 273 | return(c("", treetext)) 274 | } 275 | 276 | if (!is.null(text)) { 277 | if (!is.character(text)) 278 | stop("argument `text' must be of mode character") 279 | tree <- text 280 | } 281 | else { 282 | tree <- scan(file = file, what = "", sep = "\n", quiet = TRUE, 283 | skip = skip, comment.char = comment.char, ...) 284 | } 285 | if (identical(tree, character(0))) { 286 | warning("empty character string.") 287 | return(NULL) 288 | } 289 | 290 | tree <- gsub("[ \n\t]", "", tree) 291 | tree <- gsub("\\[&R\\]", "", tree) 292 | tree <- unlist(strsplit(tree, NULL)) 293 | y <- which(tree == ";") 294 | Ntree <- length(y) 295 | x <- c(1, y[-Ntree] + 1) 296 | if (is.na(y[1])) 297 | return(NULL) 298 | STRING <- character(Ntree) 299 | for (i in 1:Ntree) STRING[i] <- paste(tree[x[i]:y[i]], sep = "", 300 | collapse = "") 301 | 302 | tmp <- unlist(lapply(STRING, unname)) 303 | tmpnames <- tmp[c(TRUE, FALSE)] 304 | STRING <- tmp[c(FALSE, TRUE)] 305 | if (is.null(tree.names) && any(nzchar(tmpnames))) 306 | tree.names <- tmpnames 307 | colon <- grep(":", STRING) 308 | 309 | if (!is.null(tree.names)) { 310 | traits.text = lapply(tree.names, .split.tree.traits) 311 | tree.names = lapply(tree.names, .split.tree.names) 312 | tree.traits = lapply(traits.text, .parse.traits) 313 | } 314 | 315 | if (!length(colon)) { 316 | stop(paste("Annotated clado.build is not yet implemented.\n")) 317 | obj <- lapply(STRING, .annotated.clado.build) 318 | } 319 | else if (length(colon) == Ntree) { 320 | obj <- lapply(STRING, .annotated.tree.build) 321 | } 322 | else { 323 | obj <- vector("list", Ntree) 324 | obj[colon] <- lapply(STRING[colon], .annotated.tree.build) 325 | nocolon <- (1:Ntree)[!1:Ntree %in% colon] 326 | obj[nocolon] <- lapply(STRING[nocolon], clado.build) 327 | } 328 | for (i in 1:Ntree) { 329 | ROOT <- length(obj[[i]]$tip.label) + 1 330 | if (sum(obj[[i]]$edge[, 1] == ROOT) == 1 && dim(obj[[i]]$edge)[1] > 331 | 1) 332 | stop(paste("The tree has apparently singleton node(s): cannot read tree file.\n Reading Newick file aborted at tree no.", 333 | i)) 334 | } 335 | if (Ntree == 1 && !keep.multi) 336 | obj <- obj[[1]] 337 | else { 338 | if (!is.null(tree.names)) { 339 | names(obj) <- tree.names 340 | } 341 | class(obj) <- "multiPhylo" 342 | } 343 | obj 344 | } 345 | 346 | 347 | read.annotated.nexus <- function (file, tree.names = NULL) { 348 | X <- scan(file = file, what = "", sep = "\n", quiet = TRUE) 349 | LEFT <- grep("\\[", X) 350 | RIGHT <- grep("\\]", X) 351 | 352 | ## browser() 353 | ## 354 | ## if (length(LEFT)) { 355 | ## w <- LEFT == RIGHT 356 | ## if (any(w)) { 357 | ## s <- LEFT[w] 358 | ## X[s] <- gsub("\\[[^]]*\\]", "", X[s]) 359 | ## } 360 | ## w <- !w 361 | ## if (any(w)) { 362 | ## s <- LEFT[w] 363 | ## X[s] <- gsub("\\[.*", "", X[s]) 364 | ## sb <- RIGHT[w] 365 | ## X[sb] <- gsub(".*\\]", "", X[sb]) 366 | ## if (any(s < sb - 1)) 367 | ## X <- X[-unlist(mapply(":", (s + 1), (sb - 1)))] 368 | ## } 369 | ## } 370 | 371 | endblock <- grep("END;|ENDBLOCK;", X, ignore.case = TRUE) 372 | semico <- grep(";", X) 373 | i1 <- grep("BEGIN TREES;", X, ignore.case = TRUE) 374 | i2 <- grep("TRANSLATE", X, ignore.case = TRUE) 375 | translation <- if (length(i2) == 1 && i2 > i1) 376 | TRUE 377 | else FALSE 378 | if (translation) { 379 | end <- semico[semico > i2][1] 380 | x <- X[(i2 + 1):end] 381 | x <- unlist(strsplit(x, "[,; \t]")) 382 | x <- x[nzchar(x)] 383 | TRANS <- matrix(x, ncol = 2, byrow = TRUE) 384 | TRANS[, 2] <- gsub("['\"]", "", TRANS[, 2]) 385 | n <- dim(TRANS)[1] 386 | } 387 | start <- if (translation) 388 | semico[semico > i2][1] + 1 389 | else semico[semico > i1][1] 390 | end <- endblock[endblock > i1][1] - 1 391 | tree <- X[start:end] 392 | 393 | ## browser() 394 | 395 | rm(X) 396 | tree <- tree[tree != ""] 397 | semico <- grep(";", tree) 398 | Ntree <- length(semico) 399 | if (Ntree == 1 && length(tree) > 1) 400 | STRING <- paste(tree, collapse = "") 401 | else { 402 | if (any(diff(semico) != 1)) { 403 | STRING <- character(Ntree) 404 | s <- c(1, semico[-Ntree] + 1) 405 | j <- mapply(":", s, semico) 406 | if (is.list(j)) { 407 | for (i in 1:Ntree) STRING[i] <- paste(tree[j[[i]]],collapse = "") 408 | } 409 | else { 410 | for (i in 1:Ntree) STRING[i] <- paste(tree[j[,i]], collapse = "") 411 | } 412 | } 413 | else STRING <- tree 414 | } 415 | rm(tree) 416 | 417 | ## browser() 418 | 419 | STRING <- STRING[grep("^[[:blank:]]*tree.*= *", STRING, ignore.case = TRUE)] 420 | Ntree <- length(STRING) 421 | 422 | STRING <- gsub("\\[&R\\]", "", STRING) 423 | 424 | ## TODO Parse out tree-level traits 425 | nms.annontations.trees <- sub(" * = *.*", "", STRING) 426 | nms.annontations.trees <- sub("^ *tree *", "", nms.annontations.trees, ignore.case = TRUE) 427 | 428 | nms.trees <- sub("\\s+\\[&.*?\\]", "", nms.annontations.trees) 429 | 430 | if (any(nms.trees != nms.annontations.trees)) { # There are tree-level annontations 431 | annotations.trees <- sub(".*\\[&", "\\[&", nms.annontations.trees) 432 | annotations.trees = lapply(annotations.trees, .parse.traits, header=TRUE) 433 | } else { 434 | annotations.trees <- NULL 435 | } 436 | 437 | STRING <- sub("^.*? = *", "", STRING) 438 | STRING <- gsub("\\s", "", STRING) 439 | 440 | ## browser() 441 | 442 | colon <- grep(":", STRING) 443 | if (!length(colon)) { 444 | stop(".annotated.clado.build is not yet implemented.\n") 445 | trees <- lapply(STRING, .annotated.clado.build) 446 | } else if (length(colon) == Ntree) { 447 | ## trees <- if (translation) { 448 | ## browser() 449 | ## stop("treeBuildWithTokens is not yet implemented.\n") 450 | ## lapply(STRING, .treeBuildWithTokens) 451 | ## } 452 | ## else lapply(STRING, .annotated.tree.build) 453 | trees <- lapply(STRING, .annotated.tree.build) 454 | ## browser() 455 | } else { 456 | ## trees <- vector("list", Ntree) 457 | ## trees[colon] <- lapply(STRING[colon], .annotated.tree.build) 458 | ## nocolon <- (1:Ntree)[!1:Ntree %in% colon] 459 | ## trees[nocolon] <- lapply(STRING[nocolon], .annotated.clado.build) 460 | ## if (translation) { 461 | ## for (i in 1:Ntree) { 462 | ## tr <- trees[[i]] 463 | ## for (j in 1:n) { 464 | ## ind <- which(tr$tip.label[j] == TRANS[, 1]) 465 | ## tr$tip.label[j] <- TRANS[ind, 2] 466 | ## } 467 | ## if (!is.null(tr$node.label)) { 468 | ## for (j in 1:length(tr$node.label)) { 469 | ## ind <- which(tr$node.label[j] == TRANS[, 470 | ## 1]) 471 | ## tr$node.label[j] <- TRANS[ind, 2] 472 | ## } 473 | ## } 474 | ## trees[[i]] <- tr 475 | ## } 476 | ## translation <- FALSE 477 | ## } 478 | stop("Unknown error in read.annotated.nexus.\n") 479 | } 480 | for (i in 1:Ntree) { 481 | tr <- trees[[i]] 482 | if (!translation) 483 | n <- length(tr$tip.label) 484 | ROOT <- n + 1 485 | if (sum(tr$edge[, 1] == ROOT) == 1 && dim(tr$edge)[1] > 486 | 1) { 487 | stop(paste("The tree has apparently singleton node(s): cannot read tree file.\n Reading NEXUS file aborted at tree no.", 488 | i, sep = "")) 489 | } 490 | } 491 | if (Ntree == 1) { 492 | trees <- trees[[1]] 493 | if (translation) { 494 | trees$tip.label <- # if (length(colon)) { 495 | # TRANS[, 2] 496 | #} else { 497 | TRANS[, 2][as.numeric(trees$tip.label)] 498 | #} 499 | } 500 | } 501 | else { 502 | if (!is.null(tree.names)) 503 | names(trees) <- tree.names 504 | if (translation) { 505 | # if (length(colon) == Ntree) 506 | # attr(trees, "TipLabel") <- TRANS[, 2] 507 | #else { 508 | for (i in 1:Ntree) trees[[i]]$tip.label <- TRANS[, 2][as.numeric(trees[[i]]$tip.label)] 509 | trees <- .compressTipLabel(trees) 510 | #} 511 | } 512 | class(trees) <- "multiPhylo" 513 | if (!all(nms.trees == "")) 514 | names(trees) <- nms.trees 515 | } 516 | 517 | # Add tree-level annotations back on 518 | if (!is.null(annotations.trees)) { 519 | if (Ntree == 1) { 520 | trees$tree.annotations <- annotations.trees[[1]] 521 | } else { 522 | for (i in 1:Ntree) { 523 | trees[[i]]$tree.annotations <- annotations.trees[[i]] 524 | } 525 | } 526 | } 527 | 528 | trees 529 | } # end read.annotated.nexus 530 | 531 | -------------------------------------------------------------------------------- /R/calc_act.R: -------------------------------------------------------------------------------- 1 | #' Calculate the auto-correlation time using only R. Consider using calc_act 2 | #' instead, as it is orders of magnitude faster 3 | #' @param trace the values 4 | #' @param sample_interval the interval in timesteps between samples 5 | #' @return the auto_correlation time 6 | #' @examples 7 | #' trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 100)) 8 | #' act <- RBeast::calc_act_r( 9 | #' trace = trace, 10 | #' sample_interval = 1 11 | #' ) 12 | #' testthat::expect_equal(object = act, expected = 38.18202, tolerance = 0.01) 13 | #' @export 14 | #' @seealso Java code can be found here: \url{https://github.com/CompEvol/beast2/blob/9f040ed0357c4b946ea276a481a4c654ad4fff36/src/beast/core/util/ESS.java#L161} 15 | #' @author The original Java version of the algorithm was from Remco Bouckaert, 16 | #' ported to R and adapted by Richel J.C. Bilderbeek 17 | calc_act_r <- function(trace, sample_interval) { 18 | tracerer::calc_act_r(trace, sample_interval) 19 | } 20 | 21 | #' Calculate the auto-correlation time, alternative implementation 22 | #' @param trace the values 23 | #' @param sample_interval the interval in timesteps between samples 24 | #' @return the auto_correlation time 25 | #' @export 26 | #' @examples 27 | #' trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 100)) 28 | #' act <- RBeast::calc_act( 29 | #' trace = trace, 30 | #' sample_interval = 1 31 | #' ) 32 | #' testthat::expect_equal(object = act, expected = 38.18202, tolerance = 0.01) 33 | #' @seealso Java code can be found here: \url{https://github.com/CompEvol/beast2/blob/9f040ed0357c4b946ea276a481a4c654ad4fff36/src/beast/core/util/ESS.java#L161} 34 | #' @author The original Java version of the algorithm was from Remco Bouckaert, 35 | #' ported to R and adapted by Richel J.C. Bilderbeek 36 | calc_act <- function(trace, sample_interval) { 37 | tracerer::calc_act(trace, sample_interval) 38 | } 39 | -------------------------------------------------------------------------------- /R/calc_ess.R: -------------------------------------------------------------------------------- 1 | #' Calculates the Effective Sample Size 2 | #' @param trace the values without burn-in 3 | #' @param sample_interval the interval in timesteps between samples 4 | #' @return the effective sample size 5 | #' @examples 6 | #' filename <- system.file( 7 | #' "extdata", "beast2_example_output.log", package = "RBeast" 8 | #' ) 9 | #' 10 | #' # Parse the file as-is and conclude the sampling interval 11 | #' df <- RBeast::parse_beast_log( 12 | #' filename = filename 13 | #' ) 14 | #' sample_interval <- df$Sample[2] - df$Sample[1] 15 | #' 16 | #' # Only keep the parameter estimates, do not care about the sampling times anymore 17 | #' estimates <- subset(df, select = -Sample) 18 | #' 19 | #' esses <- rep(NA, ncol(estimates)) 20 | #' burn_in_fraction <- 0.1 21 | #' for (i in seq_along(estimates)) { 22 | #' # Trace with the burn-in still present 23 | #' trace_raw <- as.numeric(t(estimates[i])) 24 | #' 25 | #' # Trace with the burn-in removed 26 | #' trace <- RBeast::remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 27 | #' 28 | #' # Store the effectice sample size 29 | #' esses[i] <- RBeast::calc_ess(trace, sample_interval = sample_interval) 30 | #' } 31 | #' 32 | #' # Use the values that TRACER shows 33 | #' expected_esses <- c(10, 10, 10, 10, 7, 10, 9, 6) 34 | #' testit::assert(all(expected_esses - esses < 0.5)) 35 | #' @export 36 | #' @author Richel J.C. Bilderbeek 37 | calc_ess <- function(trace, sample_interval) { 38 | tracerer::calc_ess(trace, sample_interval) 39 | } 40 | -------------------------------------------------------------------------------- /R/calc_esses.R: -------------------------------------------------------------------------------- 1 | #' Calculates the Effective Sample Sizes from a parsed BEAST2 log file 2 | #' @param traces a dataframe with traces with removed burn-in 3 | #' @param sample_interval the interval in timesteps between samples 4 | #' @return the effective sample sizes 5 | #' @examples 6 | #' 7 | #' # Obtain an example log file its name 8 | #' filename <- system.file( 9 | #' "extdata", "beast2_example_output.log", package = "RBeast" 10 | #' ) 11 | #' 12 | #' # Parse that log file 13 | #' beast_log_full <- parse_beast_log(filename = filename) 14 | #' 15 | #' # Remove the burn-in 16 | #' beast_log <- remove_burn_ins( 17 | #' beast_log_full, 18 | #' burn_in_fraction = 0.1 19 | #' ) 20 | #' 21 | #' # Calculates the effective sample sizes of all parameter estimates 22 | #' esses <- calc_esses(beast_log, sample_interval = 1000) 23 | #' 24 | #' # Round off values to nearest integers 25 | #' esses <- as.integer(esses[1, ] + 0.5) 26 | #' expected <- c(10, 10, 10, 10, 7, 10, 9, 6) 27 | #' testit::assert(all(esses == expected)) 28 | #' 29 | #' @export 30 | #' @author Richel J.C. Bilderbeek 31 | calc_esses <- function(traces, sample_interval) { 32 | if (!is.data.frame(traces)) { 33 | stop("traces must be a data.frame") 34 | } 35 | if (sample_interval < 1) { 36 | stop("sample interval must be at least one") 37 | } 38 | 39 | # Remove warning: no visible binding for global variable 'Sample' 40 | Sample <- NULL; rm(Sample) 41 | # Remove the Sample column from the dataframe 42 | traces <- subset(traces, select = -c(Sample )) 43 | 44 | esses <- rep(NA, ncol(traces)) 45 | 46 | for (i in seq_along(traces)) { 47 | trace <- as.numeric(t(traces[i])) 48 | esses[i] <- RBeast::calc_ess( 49 | trace, sample_interval = sample_interval 50 | ) 51 | } 52 | 53 | df <- traces[1, ] 54 | df[1, ] <- esses 55 | testit::assert(nrow(df) == 1) 56 | testit::assert(names(df) == names(traces)) 57 | df 58 | } 59 | -------------------------------------------------------------------------------- /R/drop_tip_write_annot_tree.R: -------------------------------------------------------------------------------- 1 | .hide_until_formatted_properly <- function() { 2 | 3 | ########### 4 | # PURPOSE # 5 | ########### 6 | # Read BEAST-style annotated tree, drop tip(s), and write back to file 7 | # 8 | # Builds on function posted by Liam Revell at 9 | # http://blog.phytools.org/2011/07/writing-phylo-object-to-newick-string.html, 10 | # APE's drop.tip function and parts of the write.nexus function from APE are 11 | # used for writing to file. 12 | # 13 | # This script comes with no guarantees. Test carefully and use at own risk. But feel free to 14 | # treat me on a beer should we ever meet. 15 | # 16 | # Happy using, 17 | # Bram Vrancken 18 | 19 | ############ 20 | # PACKAGES # 21 | ############ 22 | library(OutbreakTools) 23 | library(geiger) 24 | library(ape) 25 | 26 | ################## 27 | # USER SPECIFIED # 28 | ################## 29 | #toy example: 30 | setwd("...") 31 | inTREE = "example.tre" 32 | outTREE <- "example_out.tre" 33 | 34 | toDropTip <- "XXX" 35 | 36 | ############ 37 | # FUNCTION # 38 | ############ 39 | 40 | drop.tip.annotated.tree <- function(phy, tipNames, trim.internal = TRUE, root.edge = 0, subtree = FALSE) { 41 | 42 | if (!inherits(phy, "phylo")) {stop('object "phy" is not of class "phylo"')} 43 | 44 | Ntip <- length(phy$tip.label) 45 | ## find the tips to drop: 46 | if (is.character(tipNames)){ 47 | tip <- which(phy$tip.label %in% tipNames) 48 | } else { 49 | stop('tips must be of type CHARACTER') 50 | } 51 | if (any(tip > Ntip)){ 52 | stop("some tip numbers were higher than the number of tips") 53 | } 54 | 55 | rooted = ape::is.rooted(phy) 56 | if (!rooted && subtree) { 57 | phy <- ape::root(phy, (1:Ntip)[-tip][1]) 58 | root.edge <- 0 59 | } 60 | 61 | phy <- reorder(phy) # ensure it is in cladewise order 62 | NEWROOT <- ROOT <- Ntip + 1 63 | Nnode <- phy$Nnode 64 | Nedge <- dim(phy$edge)[1] 65 | 66 | wbl <- !is.null(phy$edge.length) # test for at at least 2 taxa 67 | edge1 <- phy$edge[, 1] # local copies 68 | edge2 <- phy$edge[, 2] # 69 | keep <- !logical(Nedge) 70 | #phy$root.annotation perhaps needs an update! 71 | parentNodeNrIndex <- which(phy$edge[,2] == tip) 72 | parentNode <- phy$edge[parentNodeNrIndex,1] 73 | rootUpdate <- geiger::is.root(node = parentNode, phy = phy) 74 | 75 | if(rootUpdate){ 76 | #new root: 77 | firstNodeEdgeIndexes <- which(phy$edge[,1] == parentNode) 78 | newRootNodeEdgeIndex <- firstNodeEdgeIndexes[which(!(firstNodeEdgeIndexes %in% parentNodeNrIndex))] 79 | 80 | rootAnnots <- names(phy$root.annotation) 81 | nodeAnnots <- names(phy$annotation[[newRootNodeEdgeIndex]]) 82 | indexes <- which(nodeAnnots %in% rootAnnots) 83 | 84 | for (a in 1:length(indexes)){ 85 | currentAnnot <- nodeAnnots[indexes[a]] 86 | phy$root.annotation[[currentAnnot]] <- phy$annotations[[newRootNodeEdgeIndex]][currentAnnot][[1]] 87 | } 88 | } 89 | 90 | 91 | ## delete the terminal edges given by `tip', and also use for annotations: 92 | keep[match(tip, edge2)] <- FALSE 93 | 94 | if (trim.internal) { 95 | ints <- edge2 > Ntip 96 | ## delete the internal edges that do not have anymore 97 | ## descendants (ie, they are in the 2nd col of `edge' but 98 | ## not in the 1st one) 99 | repeat { 100 | sel <- !(edge2 %in% edge1[keep]) & ints & keep 101 | if (!sum(sel)) break 102 | keep[sel] <- FALSE 103 | } 104 | if (subtree) { 105 | ## keep the subtending edge(s): 106 | subt <- edge1 %in% edge1[keep] & edge1 %in% edge1[!keep] 107 | keep[subt] <- TRUE 108 | } 109 | if (root.edge && wbl) { 110 | degree <- tabulate(edge1[keep]) 111 | if (degree[ROOT] == 1) { 112 | j <- integer(0) # will store the indices of the edges below the new root 113 | repeat { 114 | i <- which(edge1 == NEWROOT & keep) 115 | j <- c(i, j) 116 | NEWROOT <- edge2[i] 117 | degree <- tabulate(edge1[keep]) 118 | if (degree[NEWROOT] > 1) break 119 | } 120 | keep[j] <- FALSE 121 | if (length(j) > root.edge) j <- 1:root.edge 122 | NewRootEdge <- sum(phy$edge.length[j]) 123 | if (length(j) < root.edge && !is.null(phy$root.edge)) 124 | NewRootEdge <- NewRootEdge + phy$root.edge 125 | phy$root.edge <- NewRootEdge 126 | } 127 | } 128 | } 129 | 130 | if (!root.edge) phy$root.edge <- NULL 131 | 132 | ## drop the edges and annotations: 133 | phy$edge <- phy$edge[keep, ] 134 | 135 | if (wbl){ 136 | phy$edge.length <- phy$edge.length[keep] 137 | } #end if(wbl) 138 | 139 | ## find the new terminal edges (works whatever 'subtree' and 'trim.internal'): 140 | TERMS <- !(phy$edge[, 2] %in% phy$edge[, 1]) 141 | 142 | ## get the old No. of the nodes and tips that become tips: 143 | oldNo.ofNewTips <- phy$edge[TERMS, 2] 144 | 145 | #drop the annotations: use the copy of the old edge matrix, edge2 146 | toKeepAnnotations <- which(edge2 %in% oldNo.ofNewTips) 147 | phy$annotations <- phy$annotations[toKeepAnnotations] 148 | 149 | ## in case some tips are dropped but kept because of 'subtree = TRUE': 150 | if (subtree) { 151 | i <- which(tip %in% oldNo.ofNewTips) 152 | if (length(i)) { 153 | phy$tip.label[tip[i]] <- "[1_tip]" 154 | tip <- tip[-i] 155 | } 156 | } 157 | 158 | n <- length(oldNo.ofNewTips) # the new number of tips in the tree 159 | 160 | ## the tips may not be sorted in increasing order in the 161 | ## 2nd col of edge, so no need to reorder $tip.label 162 | phy$edge[TERMS, 2] <- rank(phy$edge[TERMS, 2]) 163 | phy$tip.label <- phy$tip.label[-tip] 164 | 165 | ## make new tip labels if necessary: 166 | if (subtree || !trim.internal) { 167 | ## get the numbers of the nodes that become tips: 168 | node2tip <- oldNo.ofNewTips[oldNo.ofNewTips > Ntip] 169 | new.tip.label <- if (subtree) { 170 | paste("[", N[node2tip], "_tips]", sep = "") 171 | } else { 172 | if (is.null(phy$node.label)) rep("NA", length(node2tip)) 173 | else phy$node.label[node2tip - Ntip] 174 | } 175 | if (!is.null(phy$node.label)) 176 | phy$node.label <- phy$node.label[-(node2tip - Ntip)] 177 | phy$tip.label <- c(phy$tip.label, new.tip.label) 178 | } 179 | 180 | ## update node.label if needed: 181 | if (!is.null(phy$node.label)) 182 | phy$node.label <- phy$node.label[sort(unique(phy$edge[, 1])) - Ntip] 183 | 184 | phy$Nnode <- dim(phy$edge)[1] - n + 1L # update phy$Nnode 185 | 186 | ## The block below renumbers the nodes so that they conform 187 | ## to the "phylo" format -- same as in root() 188 | newNb <- integer(n + phy$Nnode) 189 | newNb[NEWROOT] <- n + 1L 190 | sndcol <- phy$edge[, 2] > n 191 | ## executed from right to left, so newNb is modified before phy$edge: 192 | phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] <- 193 | (n + 2):(n + phy$Nnode) 194 | phy$edge[, 1] <- newNb[phy$edge[, 1]] 195 | storage.mode(phy$edge) <- "integer" 196 | ape::collapse.singles(phy) 197 | 198 | #for testing purposes: 199 | # f <- ape::collapse.singles(phy) 200 | 201 | 202 | } 203 | 204 | #get the newick string with annotations: 205 | get.annotated.newick.string<-function(tree){ 206 | tree<-ape::reorder.phylo(tree,"cladewise") 207 | n<-length(tree$tip) 208 | #prepare for writing: 209 | string<-vector(); string[1]<-"(" 210 | j<-2 211 | 212 | for(i in 1:nrow(tree$edge)){ # 3 213 | 214 | nodeNr <- tree$edge[i,2] 215 | 216 | if (nodeNr<=n){ #test whether we start from a tip 217 | 218 | #for NEXUS format: need to replace the taxon name with the corresponding node nr 219 | #string[j]<-tree$tip.label[tree$edge[i,2]] 220 | string[j]<-nodeNr 221 | j<-j+1 222 | 223 | #insert colon and start of annotation info: 224 | string[j]<-paste(":[&", collapse=""); j<-j+1 225 | #fetch annotations 226 | traitIndex <- i 227 | annotCount <- length(tree$annotations[[i]]) 228 | 229 | for (a in 1:annotCount){ 230 | annotName <- names(tree$annotations[[i]])[a] 231 | annotValue <- tree$annotations[[i]][a][[1]] 232 | if(is.numeric(annotValue)){ 233 | string[j]<-paste(annotName, "=", annotValue ,collapse="") 234 | } else { 235 | string[j]<-paste(annotName, '="', annotValue, '"' ,collapse="") 236 | } 237 | j<-j+1 238 | if (a < annotCount){ 239 | string[j]<-paste("," ,collapse="") 240 | j<-j+1 241 | } 242 | } 243 | 244 | #plug in branch length info 245 | string[j]<-paste(c("]",round(tree$edge.length[i],10)), collapse="") 246 | j<-j+1 247 | 248 | #fetch the annot info up to the root 249 | v<-which(tree$edge[,1]==tree$edge[i,1]); k<-i 250 | 251 | while(length(v)>0&&k==v[length(v)]){ 252 | 253 | string[j]<-")"; j<-j+1 254 | 255 | if(!(geiger::is.root(node = tree$edge[k,1], phy = tree))){ 256 | w<-which(tree$edge[,2]==tree$edge[k,1]) 257 | 258 | #when immediately landing at root: w = integer(0) 259 | #text <- paste("i:", i, " k:", k, " w:", w, sep="") 260 | #print(text) 261 | 262 | 263 | nodeNr <- tree$edge[w,2] 264 | #insert colon and start of annotation info: 265 | string[j]<-paste(":[&", collapse=""); j<-j+1 266 | 267 | #fetch annotations: 268 | annotCount <- length(tree$annotations[[w]]) 269 | 270 | for (a in 1:annotCount){ 271 | annotName <- names(tree$annotations[[w]])[a] 272 | annotValue <- tree$annotations[[w]][a][[1]] 273 | if(is.numeric(annotValue)){ 274 | string[j]<-paste(annotName, "=", annotValue ,collapse="") 275 | } else { 276 | string[j]<-paste(annotName, '="', annotValue, '"' ,collapse="") 277 | } 278 | j<-j+1 279 | } 280 | #plug in branch length info 281 | string[j]<-paste(c("]",round(tree$edge.length[w],10)), collapse="") 282 | j<-j+1 283 | 284 | } # k not root node 285 | v<-which(tree$edge[,1]==tree$edge[w,1]); k<-w 286 | } 287 | string[j]<-","; j<-j+1 288 | } else if(tree$edge[i,2]>=n){ 289 | string[j]<-"("; j<-j+1 290 | } 291 | } 292 | 293 | #still need to plug in the root node annotations and end with semicolon: 294 | 295 | if(is.null(tree$edge.length)){ 296 | 297 | #remove redundant komma from end of string and open root node annotation: 298 | string<-c(string[1:(length(string)-1)], "[&") 299 | j <- length(string) + 1 300 | 301 | annotCount <- length(tree$root.annotation) 302 | for (a in 1:annotCount){ 303 | annotName <- names(tree$root.annotation)[a] 304 | annotValue <- tree$root.annotation[a][[1]] 305 | if(is.numeric(annotValue)){ 306 | string[j]<-paste(annotName, "=", annotValue ,collapse="") 307 | } else { 308 | string[j]<-paste(annotName, '="', annotValue, '"' ,collapse="") 309 | } 310 | j<-j+1 311 | if (a < annotCount){ 312 | string[j]<-paste("," ,collapse="") 313 | j<-j+1 314 | } 315 | } 316 | #close annot info: 317 | string[j]<-paste("];", collapse="") 318 | 319 | } else { 320 | 321 | #as above: remove redundant stuff from end and open root node annotation: 322 | string<-c(string[1:(length(string)-1)],"[&") 323 | j <- length(string) + 1 324 | 325 | annotCount <- length(tree$root.annotation) 326 | for (a in 1:annotCount){ 327 | annotName <- names(tree$root.annotation)[a] 328 | annotValue <- tree$root.annotation[a][[1]] 329 | if(is.numeric(annotValue)){ 330 | string[j]<-paste(annotName, "=", annotValue ,collapse="") 331 | } else { 332 | string[j]<-paste(annotName, '="', annotValue, '"' ,collapse="") 333 | } 334 | j<-j+1 335 | if (a < annotCount){ 336 | string[j]<-paste("," ,collapse="") 337 | j<-j+1 338 | } 339 | } 340 | #close annot info and end tree: 341 | string[j]<-paste("];", collapse="") 342 | 343 | } 344 | string<-paste(string,collapse="") 345 | return(string) 346 | } 347 | 348 | ################################# 349 | # WRITE TO FILE IN NEXUS FORMAT # 350 | ################################# 351 | #read tree: 352 | tree <- OutbreakTools::read.annotated.nexus(file = inTREE) 353 | apeTree <- ape::read.nexus(file = inTREE) 354 | 355 | #remove a tip: 356 | tree2 <- drop.tip.annotated.tree(phy = tree, tipNames = toDropTip) 357 | apeTree2 <- ape::drop.tip(phy = apeTree, tip = toDropTip) # Unsure if ape's or geiger's drop.tip 358 | 359 | #write to file: 360 | cat("#NEXUS\n", file = outTREE) 361 | cat(paste("[based on write.nexus function from R-package APE and a function by Liam Revell at http://blog.phytools.org/]\n\n", sep = ""), file = outTREE, append = TRUE) 362 | cat("BEGIN TAXA;\n", file = outTREE, append = TRUE) 363 | N <- length(apeTree$tip.label) 364 | cat(paste("\tDIMENSIONS NTAX = ", N, ";\n", sep = ""), file = outTREE, append = TRUE) 365 | cat("\tTAXLABELS\n", file = outTREE, append = TRUE) 366 | cat(paste("\t\t", apeTree$tip.label, sep = ""), sep = "\n", file = outTREE, append = TRUE) 367 | cat("\t;\n", file = outTREE, append = TRUE) 368 | cat("END;\n\n", file = outTREE, append = TRUE) 369 | cat("BEGIN TREES;\n", file = outTREE, append = TRUE) 370 | cat("\tTRANSLATE\n", file = outTREE, append = TRUE) 371 | tmp <- ape::checkLabel(apeTree$tip.label) 372 | X <- paste("\t\t", 1:N, "\t", tmp, ",", sep = "") 373 | ## We remove the last comma: 374 | X[length(X)] <- gsub(",", "", X[length(X)]) 375 | cat(X, file = outTREE, append = TRUE, sep = "\n") 376 | cat("\t;\n", file = outTREE, append = TRUE) 377 | #token <- as.character(1:N) 378 | #names(token) <- apeTree$tip.label 379 | #apeTree$tip.label <- token 380 | #create newick string for writing to file: 381 | tr <- get.annotated.newick.string(tree2) 382 | #remove spaces before writing to file: 383 | tr <- gsub(pattern = " ", replacement = "", x = tr) 384 | if (ape::is.rooted(apeTree)){ 385 | cat("\tTREE * UNTITLED = [&R] ", file = outTREE, append = TRUE) 386 | cat(tr, "\n", sep = "", file = outTREE, append = TRUE) 387 | } else { 388 | cat("\tTREE * UNTITLED = [&U] ", file = outTREE, append = TRUE) 389 | cat(tr, "\n", sep = "", file = outTREE, append = TRUE) 390 | } 391 | cat("END;\n", file = outTREE, append = TRUE) 392 | 393 | ######################################## THE END ######################################## 394 | 395 | } 396 | -------------------------------------------------------------------------------- /R/is_posterior.R: -------------------------------------------------------------------------------- 1 | #' Determines if the input is a BEAST2 posterior 2 | #' @param x the input 3 | #' @return TRUE or FALSE 4 | #' @author Richel J.C. Bilderbeek 5 | #' @examples 6 | #' trees_filename <- system.file( 7 | #' "extdata", "beast2_example_output.trees", package = "RBeast" 8 | #' ) 9 | #' log_filename <- system.file( 10 | #' "extdata", "beast2_example_output.log", package = "RBeast" 11 | #' ) 12 | #' posterior <- parse_beast_posterior( 13 | #' trees_filename = trees_filename, 14 | #' log_filename = log_filename 15 | #' ) 16 | #' testit::assert(is_posterior(posterior)) 17 | #' @export 18 | is_posterior <- function(x) { 19 | 20 | tracerer::is_posterior(x) 21 | } 22 | -------------------------------------------------------------------------------- /R/is_trees_posterior.R: -------------------------------------------------------------------------------- 1 | #' Determines if the input is a BEAST2 posterior, 2 | #' as parsed by parse_beast_trees 3 | #' @param x the input 4 | #' @return TRUE or FALSE 5 | #' @author Richel J.C. Bilderbeek 6 | #' @export 7 | is_trees_posterior <- function(x) { 8 | tracerer::is_trees_posterior(x) 9 | } 10 | -------------------------------------------------------------------------------- /R/newCode.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ###################################################################### 4 | #### functions for package 5 | 6 | readInputData <- function(file, sep) { 7 | inputData <- 8 | utils::read.csv( 9 | file, 10 | header = TRUE, 11 | stringsAsFactors = FALSE, 12 | sep = sep , 13 | check.names = FALSE 14 | ) 15 | cat(paste( 16 | "Have read table with", 17 | nrow(inputData), 18 | "lines and", 19 | ncol(inputData), 20 | "columns.\n" 21 | )) 22 | return(as.data.frame(inputData)) 23 | } 24 | 25 | 26 | addTimeScaleToData <- function(iT, fT, data) { 27 | time <- seq(iT, fT, length.out = nrow(data)) 28 | data <- cbind(time = time, data) 29 | cat(paste( 30 | "Have added a time scale ", 31 | iT, 32 | "-", 33 | fT, 34 | "(", 35 | nrow(data), 36 | "steps )\n" 37 | )) 38 | return(data) 39 | } 40 | 41 | 42 | 43 | demo <- function() { 44 | ###################################################################### 45 | #### user code 46 | 47 | #sorting out data 48 | 49 | filename <- "~/Desktop/Trinidad/LTT/fractionOfPopsize2.txt" 50 | separator <- "\t" 51 | itime <- 1920 52 | ftime <- 2008 53 | 54 | data <- readInputData(file = filename, sep = separator) 55 | data <- addTimeScaleToData(iT = itime, fT = ftime, data = data) 56 | nDataCols <- 57 | ncol(data) - 1 #how many data columns we have, excluding time 58 | 59 | # source("~/Desktop/Trinidad/LTT/plotStackedAreas.R") 60 | 61 | #examples of plotting 62 | 63 | #normal plot, little options 64 | plotStackedAreas(data, 65 | stacked100 = FALSE, 66 | ylab = "variable", 67 | xlab = "time") 68 | 69 | #stacked plot, little options 70 | plotStackedAreas(data, 71 | stacked100 = TRUE, 72 | ylab = "relative variable", 73 | xlab = "time") 74 | 75 | ### Load the package or install if not present 76 | # if (!require("RColorBrewer")) { 77 | # install.packages("RColorBrewer") 78 | # library(RColorBrewer) 79 | # } 80 | 81 | #stacked plot, working with options 82 | #myColours= brewer.pal(8,"Set1") 83 | myColours = (grDevices::rainbow(nDataCols, start = 0.11)) 84 | plotStackedAreas( 85 | data, 86 | stacked100 = TRUE, 87 | ylab = "relative variable", 88 | xlab = "time", 89 | colours = myColours, 90 | #choose colours 91 | areaBorderCol = myColours #use area colours to hide borders 92 | ) 93 | 94 | 95 | #stacked plot, working with options 96 | myColours = grDevices::rainbow(nDataCols, start = 0.11) 97 | plotStackedAreas( 98 | data, 99 | stacked100 = TRUE, 100 | ylab = "relative variable", 101 | xlab = "time", 102 | colours = myColours, 103 | #choose colours 104 | areaBorderCol = myColours, 105 | #use area colours to hide borders 106 | addAxisSpace = TRUE, 107 | #add white area around? 108 | main = "with axis margins" 109 | ) 110 | 111 | #stacked plot, working with options 112 | myColours = grDevices::rainbow(nDataCols, start = 0.11) 113 | myOrder = sample(1:nDataCols, nDataCols) #random selection of data columns 114 | plotStackedAreas( 115 | data, 116 | stacked100 = TRUE, 117 | ylab = "relative variable", 118 | xlab = "time", 119 | colours = myColours, 120 | #choose colours 121 | areaBorderCol = myColours, 122 | #use area colours to hide borders 123 | addAxisSpace = FALSE, 124 | #add white area around? 125 | order = myOrder, 126 | #choose order to plot data 127 | main = "with data using random order" 128 | ) 129 | 130 | #stacked plot, working with options 131 | myColours = grDevices::rainbow(nDataCols, start = 0.11) 132 | plotStackedAreas( 133 | data, 134 | stacked100 = TRUE, 135 | ylab = "relative variable", 136 | xlab = "time", 137 | colours = myColours, 138 | #choose colours 139 | areaBorderCol = myColours, 140 | #use area colours to hide borders 141 | addAxisSpace = FALSE, 142 | #add white area around? 143 | main = "playing with legends", 144 | #add title 145 | addLegend = "topright" #add a legend to it by giving position to use 146 | ) 147 | 148 | #stacked plot, working with options 149 | myColours = grDevices::rainbow(nDataCols, start = 0.11) 150 | plotStackedAreas( 151 | data, 152 | stacked100 = TRUE, 153 | ylab = "relative variable", 154 | xlab = "time", 155 | colours = myColours, 156 | #choose colours 157 | areaBorderCol = myColours, 158 | #use area colours to hide borders 159 | addAxisSpace = FALSE, 160 | #add white area around? 161 | main = "playing with legends", 162 | #add title 163 | addLegend = "topright", 164 | #add a legend to it 165 | legend.cex = 0.85 #edit legend: change font size 166 | ) 167 | 168 | #stacked plot, working with options 169 | myColours = grDevices::rainbow(nDataCols, start = 0.11) 170 | plotStackedAreas( 171 | data, 172 | stacked100 = TRUE, 173 | ylab = "relative variable", 174 | xlab = "time", 175 | colours = myColours, 176 | #choose colours 177 | areaBorderCol = myColours, 178 | #use area colours to hide borders 179 | addAxisSpace = FALSE, 180 | #add white area around? 181 | main = "playing with legends", 182 | #add title 183 | boxlwd = 2, 184 | #add a nice border to the entire plot 185 | addLegend = "topright", 186 | #add a legend to it 187 | legend.cex = 0.85, 188 | #edit legend: change font size 189 | legend.bg = "white" #edit legend: bg colour 190 | ) 191 | 192 | #stacked plot, working with options 193 | myColours = grDevices::rainbow(nDataCols, start = 0.11) 194 | plotStackedAreas( 195 | data, 196 | stacked100 = TRUE, 197 | ylab = "relative variable", 198 | xlab = "time", 199 | colours = myColours, 200 | #choose colours 201 | areaBorderCol = myColours, 202 | #use area colours to hide borders 203 | addAxisSpace = FALSE, 204 | #add white area around? 205 | main = "playing with legends", 206 | #add title 207 | boxlwd = 2, 208 | #add a nice border to the entire plot 209 | addLegend = "topright", 210 | #add a legend to it 211 | legend.cex = 0.85, 212 | #edit legend: change font size 213 | legend.bg = "white", 214 | #edit legend: bg colour 215 | file = "myoutoutfilename", 216 | #choose to export this plot to a PDF file 217 | pdfW = 5.5, 218 | #choose width of PDF 219 | pdfH = 5 #choose height of PDF 220 | ) 221 | 222 | #stacked plot, working with options 223 | myColours = grDevices::rainbow(nDataCols, start = 0.11) 224 | myColours[length(myColours)] = "white" 225 | plotStackedAreas( 226 | data, 227 | stacked100 = TRUE, 228 | ylab = "relative variable", 229 | xlab = "time", 230 | colours = myColours, 231 | #choose colours 232 | areaBorderCol = myColours, 233 | #use area colours to hide borders 234 | addAxisSpace = FALSE, 235 | #add white area around? 236 | main = "final example", 237 | #add title 238 | boxlwd = 2, 239 | #add a nice border to the entire plot 240 | addLegend = "topright", 241 | #add a legend to it 242 | legend.cex = 0.85, 243 | #edit legend: change font size 244 | legend.bg = "white", 245 | #edit legend: bg colour 246 | legend.pt.cex = 1.5, 247 | #scalling of points in legend 248 | file = "myoutoutfilename", 249 | #choose to export this plot to a PDF file 250 | pdfW = 5.5, 251 | #choose width of PDF 252 | pdfH = 5 #choose height of PDF 253 | ) 254 | 255 | } 256 | -------------------------------------------------------------------------------- /R/parse_beast_log.R: -------------------------------------------------------------------------------- 1 | #' Parses a BEAST2 .log output file 2 | #' @param filename name of the BEAST2 .log output file 3 | #' @return data frame with all the parameter estimates 4 | #' @export 5 | #' @examples 6 | #' log_filename <- system.file( 7 | #' "extdata", "beast2_example_output.log", package = "RBeast" 8 | #' ) 9 | #' estimates <- parse_beast_log(filename = log_filename) 10 | #' expected_names <- c( 11 | #' "Sample", "posterior", "likelihood", 12 | #' "prior", "treeLikelihood", "TreeHeight", 13 | #' "BirthDeath", "birthRate2", "relativeDeathRate2" 14 | #' ) 15 | #' testit::assert(names(estimates) == expected_names) 16 | #' @author Richel J.C. Bilderbeek 17 | parse_beast_log <- function(filename) { 18 | tracerer::parse_beast_log(filename) 19 | } 20 | -------------------------------------------------------------------------------- /R/parse_beast_posterior.R: -------------------------------------------------------------------------------- 1 | #' Parses BEAST2 output files to a posterior 2 | #' @param trees_filename name of the BEAST2 .trees output file 3 | #' @param log_filename name of the BEAST2 .trees output file 4 | #' @return a posterior 5 | #' @export 6 | #' @examples 7 | #' trees_filename <- system.file( 8 | #' "extdata", "beast2_example_output.trees", package = "RBeast" 9 | #' ) 10 | #' log_filename <- system.file( 11 | #' "extdata", "beast2_example_output.log", package = "RBeast" 12 | #' ) 13 | #' posterior <- parse_beast_posterior( 14 | #' trees_filename = trees_filename, 15 | #' log_filename = log_filename 16 | #' ) 17 | #' testit::assert(is_posterior(posterior)) 18 | #' @author Richel J.C. Bilderbeek 19 | parse_beast_posterior <- function(trees_filename, log_filename) { 20 | 21 | tracerer::parse_beast_posterior(trees_filename, log_filename) 22 | } 23 | -------------------------------------------------------------------------------- /R/parse_beast_state.R: -------------------------------------------------------------------------------- 1 | #' Parses a BEAST2 .xml.state output file to get only the operators 2 | #' acceptances 3 | #' @param filename name of the BEAST2 .xml.state output file 4 | #' @return data frame with all the operators' success rates 5 | #' @export 6 | #' @examples 7 | #' xml_state_filename <- system.file( 8 | #' "extdata", "beast2_example_output.xml.state", package = "RBeast" 9 | #' ) 10 | #' estimates <- parse_beast_state_operators(filename = xml_state_filename) 11 | #' expected_names <- c("operator", "p", "accept", "reject", "acceptFC", 12 | #' "rejectFC", "rejectIv", "rejectOp") 13 | #' expected_operator <- c("treeScaler.t", "treeRootScaler.t", 14 | #' "UniformOperator.t", "SubtreeSlide.t", "narrow.t", "wide.t", 15 | #' "WilsonBalding.t", "BirthRateScaler.t", "DeathRateScaler.t") 16 | #' testit::assert(names(estimates) == expected_names) 17 | #' #testit::assert(estimates$operator == expected_operators) 18 | #' @author Richel J.C. Bilderbeek 19 | parse_beast_state_operators <- function( 20 | filename = system.file("extdata", "beast2_example_output.xml.state", 21 | package = "RBeast") 22 | ) { 23 | tracerer::parse_beast_state_operators(filename) 24 | } 25 | -------------------------------------------------------------------------------- /R/parse_beast_trees.R: -------------------------------------------------------------------------------- 1 | #' Parses a BEAST2 .trees output file 2 | #' @param filename name of the BEAST2 .trees output file 3 | #' @return the phylogenies in the posterior 4 | #' @export 5 | #' @examples 6 | #' trees_filename <- system.file( 7 | #' "extdata", "beast2_example_output.trees", package = "RBeast" 8 | #' ) 9 | #' posterior <- parse_beast_trees( 10 | #' filename = trees_filename 11 | #' ) 12 | #' testit::assert(is_trees_posterior(posterior)) 13 | #' @author Richel J.C. Bilderbeek 14 | parse_beast_trees <- function(filename) { 15 | 16 | tracerer::parse_beast_trees(filename) 17 | } 18 | -------------------------------------------------------------------------------- /R/plotStackedAreas.R: -------------------------------------------------------------------------------- 1 | 2 | .onLoad <- function(libname, pkgname) { 3 | rJava::.jpackage(pkgname, lib.loc = libname) 4 | } 5 | 6 | 7 | #' @title 8 | #' runBeast 9 | #' 10 | #' @description 11 | #' \code{runBeast} spins up BEAST 12 | #' 13 | #' @details 14 | #' This function executes BEAST through rJava. 15 | #' 16 | #' @param commandLine Command-line string to pass to BEAST 17 | #' 18 | #' @examples 19 | #' runBeast() 20 | #' @export 21 | runBeast <- function(commandLine = "") { 22 | strings <- rJava::.jarray(commandLine) 23 | 24 | tryCatch( 25 | rJava::J("dr.app.beast.RBeastMain")$main(strings), 26 | error = function(msg) { 27 | print(paste0("runBeast: ", msg)) 28 | } 29 | ) 30 | } 31 | 32 | plotStackedAreas <- function( 33 | data, 34 | stacked100=TRUE, 35 | boxlwd=1.5, 36 | order = NA, 37 | ylab="", xlab="", 38 | areaBorderWidth= NA, 39 | areaBorderCol="black", 40 | colours= NA, 41 | addAxisSpace=FALSE, 42 | addLegend=NA, 43 | legend.cex=1, 44 | legend.bg=NA, 45 | main="", 46 | file=NA, 47 | pdfW=7, 48 | pdfH=5, 49 | legend.pt.cex=1, 50 | ... 51 | ){ 52 | 53 | #extract time scale 54 | X= data$time 55 | #normalize data to maximum? (stacked 100% plot) 56 | if(stacked100){ 57 | sumDataCols<- function(X){ 58 | return(sum(X[2:length(X)])) 59 | } 60 | dataSums= apply(data, MARGIN=1, FUN=sumDataCols) 61 | Y= data[,2:ncol(data)]/dataSums 62 | }else{ 63 | Y= data[,2:ncol(data)] 64 | } 65 | ndatacols= ncol(Y) 66 | 67 | #make some checks before it breaks 68 | if(sum(Y<0)>=1) stop("Data columns can not have negative values.") 69 | if(sum(X<0)>=1) stop("Time scale can not have negative values.") 70 | if(nrow(Y)==0) stop("Data columns appear to be empty.") 71 | if(length(X)==0) stop("Time scale appears to be empty.") 72 | 73 | #work on default parameters 74 | if(is.na(areaBorderWidth)) areaBorderWidth<- 1 75 | if(length(colours)==1){ 76 | if(is.na(colours)) colours <- grDevices::rainbow(ndatacols) 77 | } 78 | areaBorderCol <- as.vector(matrix(areaBorderCol, nrow=ndatacols, ncol=1)) 79 | colours <- as.vector(matrix(colours, nrow=ndatacols, ncol=1)) 80 | areaBorderWidth <- as.vector(matrix(areaBorderWidth, nrow=ndatacols, ncol=1)) 81 | 82 | if(length(order)>1) { 83 | if(length(order)!=ndatacols) stop("Order array must be the length of data columns.") 84 | Y <- Y[, order] 85 | colours <- colours[order] 86 | areaBorderWidth <- areaBorderWidth[order] 87 | areaBorderCol<- areaBorderCol[order] 88 | } 89 | 90 | upperPrevious <- X*0 91 | areas <- vector(mode="list", ndatacols) 92 | for(i in seq(areas)){ 93 | upperThis <- upperPrevious + Y[,i] 94 | areas[[i]] <- list(x=c(X, rev(X)), y=c(upperPrevious, rev(upperThis))) 95 | upperPrevious <- upperThis 96 | } 97 | 98 | xaxs="r" 99 | yaxs="r" 100 | if(!addAxisSpace){ 101 | xaxs="i" 102 | yaxs="i" 103 | } 104 | 105 | if(!is.na(file)){ 106 | file=paste(file,".pdf",sep="") 107 | grDevices::pdf(file, width = pdfW, height = pdfH, bg="white") 108 | } 109 | 110 | graphics::layout(matrix(1, ncol=1, byrow=TRUE)) 111 | graphics::par(mar=c(4, 4, 2, 2), cex=0.9) 112 | 113 | ylim <- range(sapply(areas, function(x) range(x$y, na.rm=TRUE)), na.rm=TRUE) 114 | graphics::plot(X,Y[,1], ylab=ylab, xlab=xlab, ylim=ylim, t="n", xaxs=xaxs, yaxs=yaxs, main=main) 115 | for(i in seq(areas)){ 116 | graphics::polygon(areas[[i]], border=areaBorderCol[i], col=colours[i], lwd=areaBorderWidth[i]) 117 | } 118 | 119 | if(!is.na(addLegend)){ 120 | names= colnames(Y) 121 | graphics::legend(addLegend, legend=names, pch=22, col="black", pt.bg=colours, pt.cex=legend.pt.cex, pt.lwd=1, lwd=0, lty=NA, box.lwd=NA, bg=legend.bg, cex=legend.cex) 122 | } 123 | 124 | graphics::box(lwd=boxlwd) 125 | 126 | if(!is.na(file)){ 127 | a <- grDevices::dev.off() 128 | } 129 | 130 | } 131 | -------------------------------------------------------------------------------- /R/plot_glm.R: -------------------------------------------------------------------------------- 1 | #' Calculates the Effective Sample Sizes from a parsed BEAST2 log file 2 | #' @param traces a dataframe with traces with removed burn-in 3 | #' @param sample_interval the interval in timesteps between samples 4 | #' @return the effective sample sizes 5 | #' @examples 6 | #' 7 | #' # Obtain an example log file its name 8 | #' filename <- system.file( 9 | #' "extdata", "genetic_glm.log", package = "RBeast" 10 | #' ) 11 | #' 12 | #' # Parse that log file 13 | #' beast_log_full <- parse_beast_log(filename = filename) 14 | #' 15 | #' # Remove the burn-in 16 | #' beast_log <- remove_burn_ins( 17 | #' beast_log_full, 18 | #' burn_in_fraction = 0.1 19 | #' ) 20 | #' 21 | #' # Calculates the effective sample sizes of all parameter estimates 22 | #' esses <- calc_esses(beast_log, sample_interval = 1000) 23 | #' 24 | #' # Round off values to nearest integers 25 | #' esses <- as.integer(esses[1, ] + 0.5) 26 | #' expected <- c(10, 10, 10, 10, 7, 10, 9, 6) 27 | #' testit::assert(all(esses == expected)) 28 | #' 29 | #' @export 30 | #' @author Luiz Max Carvalho/Philippe Lemey/Nuno Faria 31 | .conditional_betas_BEAST <- function(betas, inds) { 32 | if (ncol(betas) != ncol(inds)) 33 | stop("Coefficients and indicators are not the same dimension") 34 | K <- ncol(betas) 35 | result <- data.frame(matrix(NA, ncol = 3, nrow = K)) 36 | names(result) <- c("lwr", "mean", "upr") 37 | for (k in 1:K) { 38 | pos <- which(inds[, k] == 1) 39 | if(length(pos) == 0){ 40 | result[k, ] <- data.frame(lwr = 0.0, mean = 0.0, upr = 0.0) 41 | }else{ 42 | result[k, ] <- .get_summary(betas[, k][pos]) 43 | } 44 | } 45 | return(result) 46 | } 47 | .split_log <- function(dt, burninP = 0.2) { 48 | ## get indicators and coefficients while discarding burn-in 'Product' is whether coefficients should be delta*beta 49 | ## (default) or just beta 50 | res <- vector(2, mode = "list") 51 | names(res) <- c("Indicators", "Coefficients") 52 | init <- round(burninP * nrow(dt)) 53 | dt.b <- dt[init:nrow(dt), ] 54 | res[[1]] <- dt.b[, grep("coefIndicator", names(dt.b))] 55 | res[[2]] <- dt.b[, grep("glmCoefficients", names(dt.b))] 56 | return(res) 57 | } 58 | # could be skipped with a little of extra work... TODO 59 | .list2df <- function(ll) { 60 | N <- length(ll) 61 | dt <- data.frame(matrix(NA, nrow = N, ncol = 4)) 62 | names(dt) <- c("parameter", "lwr", "mean", "upr") 63 | dt$parameter <- names(ll) 64 | for (i in 1:N) dt[i, 2:4] <- ll[[i]] 65 | return(dt) 66 | } 67 | # 68 | .get_summary <- function(x, alpha = 0.95) { 69 | return(data.frame(lwr = quantile(x, probs = (1 - alpha)/2), 70 | mean = mean(x), 71 | upr = quantile(x, probs = (1 + alpha)/2))) 72 | } 73 | # 74 | .get_parameter_estimates <- function(Names, Log, Burnin, alpha, conditional, intercept) { 75 | Pars <- .split_log(Log, burninP = Burnin) 76 | if (intercept) { 77 | if (!ncol(Pars$Indicators) == (length(Names) + 1)) 78 | stop("Model probably doesn't have intercept") 79 | Pars <- lapply(Pars, function(x) x[, -ncol(x)]) 80 | } 81 | Summaries <- lapply(Pars, function(d) apply(d, 2, .get_summary, alpha = alpha)) 82 | SumDf <- lapply(Summaries, .list2df) 83 | if (conditional) { 84 | SumDf$Coefficients <- data.frame(parameter = SumDf$Coefficients$parameter, .conditional_betas_BEAST(Pars$Coefficients, 85 | Pars$Indicators)) 86 | } 87 | return(SumDf) 88 | } 89 | .make_dt_forplot <- function(summaryObj, p = 0.5) { 90 | ans <- data.frame(inclusionProbs = summaryObj$Indicators$mean, BFs = (summaryObj$Indicators$mean)/(1 - summaryObj$Indicators$mean)/(p)/(1 - 91 | p), meanCeffects = summaryObj$Coefficients$mean, lowerQuantile = summaryObj$Coefficients$lwr, upperQuantile = summaryObj$Coefficients$upr) 92 | return(ans) 93 | } 94 | # 95 | plot_simple_glm <- function(Names, 96 | Log, 97 | prob_zero = 0.5, 98 | BF = 3, 99 | burnin = 0.2, 100 | export = TRUE, 101 | file_name = "simple_GLM_plot", 102 | title = "", 103 | alpha = 0.95, 104 | intercept = FALSE, 105 | conditional = TRUE) { 106 | require(ggplot2) 107 | require(repr) 108 | require(scales) 109 | require(grid) 110 | summary_df <- .get_parameter_estimates(Names = Names, Log = Log, Burnin = burnin, alpha = alpha, conditional = conditional, 111 | intercept = intercept) 112 | 113 | inclusion.probabilities <- data.frame(p.mean = summary_df$Indicators$mean, p.lwr = summary_df$Indicators$lwr, p.upr = summary_df$Indicators$upr, 114 | predictor = Names) 115 | # 116 | regression.coefficients <- data.frame(predictor = Names, b = summary_df$Coefficients) 117 | # 118 | npred <- length(Names) 119 | q <- 1 - ((prob_zero)^(1/npred)) 120 | bf <- BF 121 | cutoff <- (q * bf)/(q * (bf - 1) + 1) 122 | # 123 | p0 <- ggplot(regression.coefficients, aes(x = predictor, y = b.mean)) + geom_pointrange(aes(ymin = b.lwr, ymax = b.upr), 124 | position = position_dodge(0.5)) + coord_flip() + scale_y_continuous("Coefficient", expand = c(0, 0)) + scale_x_discrete("Predictor") + 125 | geom_hline(yintercept = 0, linetype = "solid", color = "black", size = 0.5) + theme_bw() 126 | p0 <- p0 + theme(legend.position = "none") 127 | 128 | p1 <- ggplot(inclusion.probabilities, aes(x = predictor, y = p.mean)) + geom_bar(stat = "identity") + coord_flip() + 129 | scale_y_continuous("Inclusion probability", expand = c(0, 0)) + scale_x_discrete("Predictor") + geom_hline(yintercept = cutoff, 130 | linetype = "dashed", colour = "black", size = 0.7) + geom_hline(yintercept = q, linetype = "solid", colour = "green", 131 | size = 0.2) + ggtitle(title) + theme_bw() 132 | p1 <- p1 + guides(fill = guide_legend(reverse = TRUE)) + theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(), 133 | axis.title.y = element_blank()) 134 | if (export) { 135 | pdf(paste(file_name, ".pdf", sep = "")) 136 | } 137 | options(repr.plot.width = 10, repr.plot.height = 5) 138 | grid.draw(cbind(ggplotGrob(p0), ggplotGrob(p1), size = "first")) 139 | if (export) { 140 | dev.off() 141 | } 142 | } 143 | # 144 | plot_glm <- function(Names, Log, prob_zero = 0.5, BFs = c(3, 50), 145 | burnin = 0.2, export = TRUE, file_name = "GLM_plot", 146 | title = "", alpha = 0.95, intercept = FALSE, conditional = TRUE) { 147 | require(ggplot2) 148 | require(repr) 149 | require(scales) 150 | require(grid) 151 | require(gridExtra) 152 | # auxiliary functions 153 | .layOut <- function(...) { 154 | x <- list(...) 155 | n <- max(sapply(x, function(x) max(x[[2]]))) 156 | p <- max(sapply(x, function(x) max(x[[3]]))) 157 | pushViewport(viewport(layout = grid.layout(n, p))) 158 | for (i in seq_len(length(x))) { 159 | print(x[[i]][[1]], vp = viewport(layout.pos.row = x[[i]][[2]], layout.pos.col = x[[i]][[3]])) 160 | } 161 | } 162 | # 163 | .add_annotations <- function(data, predictors, labels) { 164 | data$rowname = labels 165 | data$x = rep(0, predictors) 166 | data$y = c(1:predictors) 167 | data$start = seq(0.5, (predictors - 0.5), by = 1) 168 | data$end = seq(1.5, (predictors + 0.5), by = 1) 169 | # 170 | cols = rep(c("lavender", "white"), predictors/2) 171 | odd <- predictors%%2 172 | if (odd != 0) 173 | cols <- c(cols, "lavender") 174 | data$color <- cols 175 | # 176 | return(data) 177 | } 178 | # 179 | .make_labels <- function() { 180 | p <- ggplot() 181 | p <- p + geom_rect(aes(NULL, NULL, xmin = -0.1, xmax = 0.65, ymin = start, ymax = end, fill = color), alpha = 0.4, 182 | data = data1) 183 | p <- p + scale_fill_manual(values = gs.pal(2)) 184 | p <- p + geom_text(aes(x = x, y = y, label = rowname), 185 | hjust = 0, size = 3.5, data = data1) 186 | theme <- theme_update(axis.text.y = element_blank(), axis.line.y = element_blank(), axis.ticks.y = element_blank(), 187 | axis.text.x = element_text(colour = "white"), axis.line.x = element_blank(), axis.ticks.x = element_line(colour = "white"), 188 | panel.border = element_rect(fill = NA, colour = "white"), panel.background = element_rect(size = 1, fill = "white", 189 | colour = NA), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), legend.position = "none") 190 | p <- p + theme_set(theme) 191 | p <- p + scale_y_reverse() 192 | p <- p + xlab("") 193 | p <- p + ylab(NULL) 194 | return(p) 195 | } 196 | # 197 | .make_barplot <- function(data, postOdds1, postOdds2) { 198 | p <- ggplot() 199 | p <- p + geom_rect(aes(NULL, NULL, ymin = 0, ymax = 1, xmin = start, xmax = end, fill = color), alpha = 0.4, 200 | data = data) 201 | p <- p + scale_fill_manual(values = gs.pal(2)) 202 | p <- p + geom_hline(aes(yintercept = postOdds1), color = "black", size = 0.5) 203 | p <- p + geom_hline(aes(yintercept = postOdds2), color = "black", size = 0.7) 204 | p <- p + geom_bar(aes(y = inclusionProbs, x = y), stat = "identity", color = "black", width = 0.3, fill = "navyblue", 205 | data = data) 206 | theme <- theme_update(axis.text.y = element_blank(), axis.line.y = element_blank(), axis.ticks.y = element_blank(), 207 | axis.text.x = element_text(colour = "black"), axis.line.x = element_blank(), axis.ticks.x = element_line(colour = "black"), 208 | panel.border = element_rect(fill = NA, colour = "black"), panel.background = element_rect(size = 1, fill = "white", 209 | colour = NA), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), legend.position = "none") 210 | p <- p + theme_set(theme) 211 | p <- p + xlab(NULL) 212 | p <- p + ylab("Inclusion probability") 213 | p <- p + ylab(bquote(paste("Inclusion probability ", "(E[", delta, "])", sep = " "))) 214 | p <- p + coord_flip() 215 | p <- p + scale_x_reverse() 216 | return(p) 217 | } 218 | # 219 | .make_linerange <- function(data) { 220 | lims <- seq(-5, 5, by = 0.5) 221 | Min = min(data$lowerQuantile) 222 | Max = max(data$upperQuantile) 223 | ylim1 = lims[max(which(lims < Min))] 224 | ylim2 = lims[min(which(lims > Max))] 225 | limits1 = seq(from = 0, to = ylim1, length.out = 5) 226 | limits2 = seq(from = 0, to = ylim2, length.out = 5) 227 | limits = sort(unique(c(limits1, limits2))) 228 | breaks1 = limits[seq(from = 1, to = length(limits), by = 2)] 229 | assign("ylim1", ylim1, envir = .GlobalEnv) 230 | assign("ylim2", ylim2, envir = .GlobalEnv) 231 | assign("limits1", limits1, envir = .GlobalEnv) 232 | assign("limits2", limits2, envir = .GlobalEnv) 233 | assign("limits", limits, envir = .GlobalEnv) 234 | assign("breaks1", breaks1, envir = .GlobalEnv) 235 | p <- ggplot() 236 | p <- p + geom_rect(aes(NULL, NULL, ymin = ylim1, ymax = ylim2, xmin = start, xmax = end, fill = color), alpha = 0.4, 237 | data = data) 238 | p <- p + scale_fill_manual(values = gs.pal(2)) 239 | p <- p + geom_hline(aes(yintercept = 0), color = "black", size = 0.7) 240 | p <- p + geom_hline(aes(yintercept = limits), color = "black", size = 0.5, linetype = "dotted") 241 | p <- p + geom_linerange(aes(ymin = lowerQuantile, ymax = upperQuantile, x = y), size = 0.5, na.rm = TRUE, data = data) 242 | p <- p + geom_point(aes(x = y, y = meanCeffects), color = "black", fill = "skyblue", size = 3.2, pch = 21, 243 | na.rm = TRUE, data = data) 244 | theme <- theme_update(axis.text.y = element_blank(), axis.line.y = element_blank(), axis.ticks.y = element_blank(), 245 | axis.text.x = element_text(colour = "black"), axis.line.x = element_blank(), axis.ticks.x = element_line(colour = "black"), 246 | panel.border = element_rect(fill = NA, colour = "black"), panel.background = element_rect(size = 1, fill = "white", 247 | colour = NA), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), legend.position = "none") 248 | p <- p + theme_set(theme) 249 | p <- p + xlab(NULL) 250 | p <- p + ylab(bquote(paste("In coefficient ", "(", beta, "I", delta, "=1)", sep = " "))) 251 | 252 | p <- p + coord_flip() 253 | p <- p + scale_x_reverse() 254 | 255 | p <- p + scale_y_continuous(breaks = breaks1, limits = c(ylim1, ylim2)) 256 | rm(ylim1, ylim2, limits1, limits2, limits, breaks1) 257 | return(p) 258 | } 259 | # 260 | BF1 <- BFs[1] 261 | BF2 <- BFs[2] 262 | npred <- length(Names) 263 | prior_inclusion_prob <- 1 - prob_zero^(1/npred) 264 | 265 | summary_df <- .get_parameter_estimates(Names = Names, Log = Log, Burnin = burnin, alpha = alpha, conditional = conditional, 266 | intercept = intercept) 267 | 268 | prior_odss <- prior_inclusion_prob/(1 - prior_inclusion_prob) 269 | post_odds1 <- BF1 * prior_odss/(1 + (BF1 * prior_odss)) 270 | post_odds2 <- BF2 * prior_odss/(1 + (BF2 * prior_odss)) 271 | 272 | predata <- .make_dt_forplot(summaryObj = summary_df, p = prior_inclusion_prob) 273 | data1 <- .add_annotations(data = predata, predictors = npred, labels = Names) 274 | 275 | gs.pal <- colorRampPalette(c("lavender", "white")) 276 | 277 | suppressWarnings(p1 <- .make_labels()) 278 | suppressWarnings(p2 <- .make_barplot(data1, post_odds1, post_odds2)) 279 | suppressWarnings(p3 <- .make_linerange(data1)) 280 | if (export) { 281 | pdf(paste(file_name, ".pdf", sep = "")) 282 | } 283 | suppressWarnings(.layOut(list(p1, 1, 1), list(p2, 1, 2), list(p3, 1, 3))) 284 | if (export) { 285 | dev.off() 286 | } 287 | } 288 | -------------------------------------------------------------------------------- /R/read_beast2_trees.R: -------------------------------------------------------------------------------- 1 | #' Extract a list of phylogenies from a BEAST2 posterior file 2 | #' @param filename name of the BEAST2 posterior filename, usually ends with '.trees' 3 | #' @return a list of phylogenies of type 'phylo' 4 | #' @examples 5 | #' trees_file <- system.file( 6 | #' "extdata", "read_beast2_trees_example.trees", package = "RBeast" 7 | #' ) 8 | #' testit::assert(file.exists(trees_file)) 9 | #' posterior <- read_beast2_trees(trees_file) 10 | #' testit::assert(length(posterior) == 11) 11 | #' testit::assert(class(posterior[[1]]) == "phylo") 12 | #' @export 13 | #' @author Richel J.C. Bilderbeek 14 | read_beast2_trees <- function(filename) { 15 | tracerer::parse_beast_trees(filename) 16 | } 17 | -------------------------------------------------------------------------------- /R/remove_burn_in.R: -------------------------------------------------------------------------------- 1 | #' Removed the burn-in from a trace 2 | #' @param trace the values 3 | #' @param burn_in_fraction the fraction that needs to be removed, must be [0,1> 4 | #' @return the values with the burn-in removed 5 | #' @export 6 | #' @examples 7 | #' # Create a trace from one to and including ten 8 | #' v <- seq(1, 10) 9 | #' 10 | #' # Remove the first ten percent of its values, 11 | #' # in this case removes the first value, which is one 12 | #' w <- remove_burn_in(trace = v, burn_in_fraction = 0.1) 13 | #' 14 | #' # Check that the result goes from two to ten 15 | #' testit::assert(w == seq(2, 10)) 16 | #' @author Richel J.C. Bilderbeek 17 | remove_burn_in <- function(trace, burn_in_fraction) { 18 | 19 | tracerer::remove_burn_in(trace, burn_in_fraction) 20 | } 21 | -------------------------------------------------------------------------------- /R/remove_burn_ins.R: -------------------------------------------------------------------------------- 1 | #' Removed the burn-ins from a data frame 2 | #' @param traces a data frame with traces 3 | #' @param burn_in_fraction the fraction that needs to be removed, must be [0,1> 4 | #' @return the data frame with the burn-in removed 5 | #' @export 6 | #' @author Richel J.C. Bilderbeek 7 | remove_burn_ins <- function(traces, burn_in_fraction) { 8 | 9 | tracerer::remove_burn_ins(traces, burn_in_fraction) 10 | } 11 | -------------------------------------------------------------------------------- /RBeast.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace,vignette 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # RBeast 2 | 3 | Branch|[![Travis CI logo](TravisCI.png)](https://travis-ci.org)|[![Codecov logo](Codecov.png)](https://www.codecov.io) 4 | ---|---|--- 5 | master|[![Build Status](https://travis-ci.org/beast-dev/RBeast.svg?branch=master)](https://travis-ci.org/beast-dev/RBeast)|[![codecov.io](https://codecov.io/github/beast-dev/RBeast/coverage.svg?branch=master)](https://codecov.io/github/beast-dev/RBeast/branch/master) 6 | develop|[![Build Status](https://travis-ci.org/beast-dev/RBeast.svg?branch=develop)](https://travis-ci.org/beast-dev/RBeast)|[![codecov.io](https://codecov.io/github/beast-dev/RBeast/coverage.svg?branch=develop)](https://codecov.io/github/beast-dev/RBeast/branch/develop) 7 | 8 | R package for working with BEAST and BEAST2. 9 | 10 | Use [beautier](https://github.com/richelbilderbeek/beautier) to create BEAST2 input (`.xml`) files. 11 | 12 | Use [beastier](https://github.com/richelbilderbeek/beastier) to run BEAST2. 13 | 14 | Use [tracerer](https://github.com/richelbilderbeek/tracerer) to parse BEAST2 output (`.log`, `.trees`, etc) files. 15 | 16 | Use [BEASTmasteR](https://github.com/nmatzke/BEASTmasteR) for tip-dating analyses using fossils as dated terminal taxa. 17 | 18 | ## Example 19 | 20 | ``` 21 | library(RBeast) 22 | 23 | # Obtain an example log file its name 24 | filename <- system.file( 25 | "extdata", "beast2_example_output.log", package = "RBeast" 26 | ) 27 | 28 | # Parse that log file 29 | beast_log_full <- parse_beast_log(filename) 30 | 31 | # Remove the burn-in 32 | beast_log <- remove_burn_ins( 33 | beast_log_full, 34 | burn_in_fraction = 0.1 35 | ) 36 | 37 | # Calculates the effective sample sizes of all parameter estimates 38 | esses <- calc_esses(beast_log, sample_interval = 1000) 39 | ``` 40 | 41 | ## Instructions 42 | 43 | To install `RBeast` in `R`: 44 | 45 | ```{r} 46 | install.packages("devtools") 47 | devtools::install_github("beast-dev/RBeast") 48 | ``` 49 | 50 | ## Acknowledgements 51 | 52 | * This project is supported in part through the National Science Foundation grant DMS 1264153. 53 | 54 | -------------------------------------------------------------------------------- /TravisCI.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beast-dev/RBeast/1e9ba811a1ac328dc4ee9209bb0c68c19fa3e43e/TravisCI.png -------------------------------------------------------------------------------- /inst/extdata/beast2_example_output.log: -------------------------------------------------------------------------------- 1 | # 2 | #model: 3 | # 4 | # 5 | # 6 | # 7 | # 0.5 8 | # 1.0 9 | # 10 | # 11 | # 12 | # 13 | # 14 | # 15 | # 16 | # 17 | # 18 | # 19 | # 20 | # 21 | # 22 | # 23 | # 24 | # 1.0 25 | # 1.0 26 | # 0.0 27 | # 28 | # 29 | # 30 | # 1.0 31 | # 32 | # 33 | # 34 | # 35 | # 36 | Sample posterior likelihood prior treeLikelihood TreeHeight BirthDeath birthRate2 relativeDeathRate2 37 | 0 -76.40152367865795 -66.56126085440302 -9.840262824254928 -66.56126085440302 0.6383792476140522 -2.9325075452727924 1.0 0.5 38 | 1000 -68.68522943015078 -60.11852833278908 -8.5667010973617 -60.11852833278908 0.7003758494767539 -1.658945818379563 2.804120785949103 0.49527653913985065 39 | 2000 -70.06839047661876 -58.93807154054928 -11.130318936069484 -58.93807154054928 1.408518197972766 -4.222563657087347 0.7901276334052576 0.3674312994250379 40 | 3000 -69.03989901570205 -58.908337646526604 -10.131561369175442 -58.908337646526604 0.9220334275239339 -3.2238060901933046 1.8637475780382835 0.24962239003989578 41 | 4000 -74.15268200979204 -59.98231670859387 -14.17036530119818 -59.98231670859387 1.815995819500523 -7.262610022216043 1.7823070405053383 0.3519154520550704 42 | 5000 -71.17163347186911 -61.56657103682397 -9.605062435045134 -61.56657103682397 0.7408031787176825 -2.697307156062997 1.784950391046604 0.7085961206445538 43 | 6000 -69.64175919436143 -58.7371283874309 -10.904630806930529 -58.7371283874309 1.0967406331819989 -3.996875527948392 1.118246617131637 0.37026052508174184 44 | 7000 -71.9254632299824 -61.43600200867863 -10.489461221303767 -61.43600200867863 1.008807793060718 -3.581705942321631 1.2610805655688475 0.40085741953348314 45 | 8000 -69.59440660430789 -58.893813736024974 -10.700592868282925 -58.893813736024974 0.8291478974191432 -3.7928375893007873 0.3909075824291657 0.5845426497411835 46 | 9000 -69.69113214841606 -62.40903887903621 -7.2820932693798435 -62.40903887903621 0.4529636701249372 -0.37433799039770677 1.1123237661541558 0.6983194230410139 47 | 10000 -71.86883594126418 -60.73520027244354 -11.133635668820638 -60.73520027244354 0.7693617408342179 -4.2258803898385 1.5626755883603614 0.7107459018616334 48 | -------------------------------------------------------------------------------- /inst/extdata/beast2_example_output.trees: -------------------------------------------------------------------------------- 1 | #NEXUS 2 | 3 | Begin taxa; 4 | Dimensions ntax=5; 5 | Taxlabels 6 | t1 7 | t5 8 | t3 9 | t4 10 | t2 11 | ; 12 | End; 13 | Begin trees; 14 | Translate 15 | 1 t1, 16 | 2 t5, 17 | 3 t3, 18 | 4 t4, 19 | 5 t2 20 | ; 21 | tree STATE_0 = ((1:0.4796940031825733,4:0.4796940031825733):0.15868524443147886,(2:0.47305110906182046,(3:0.43063449002200127,5:0.43063449002200127):0.04241661903981919):0.16532813855223172):0.0; 22 | tree STATE_1000 = (((1:0.17583864031422916,2:0.17583864031422916):0.07410328417626455,(3:0.013670604559071051,4:0.013670604559071051):0.23627131993142267):0.4504339249862602,5:0.7003758494767539):0.0; 23 | tree STATE_2000 = (((1:0.21227997331669035,2:0.21227997331669035):0.8168630720867999,(3:0.11266616016419563,4:0.11266616016419563):0.9164768852392946):0.3793751525692757,5:1.408518197972766):0.0; 24 | tree STATE_3000 = (((1:0.40233137759752147,(3:0.07214303203300969,4:0.07214303203300969):0.33018834556451176):0.1478561385081657,5:0.5501875161056872):0.37184591141824674,2:0.9220334275239339):0.0; 25 | tree STATE_4000 = (((1:0.5668662672002919,5:0.5668662672002919):0.0857065164052856,2:0.6525727836055775):1.1634230358949456,(3:0.048765523645314446,4:0.048765523645314446):1.7672302958552086):0.0; 26 | tree STATE_5000 = (((1:0.2843597014403346,2:0.2843597014403346):0.1082343306643671,5:0.39259403210470173):0.3482091466129808,(3:0.006746346947705954,4:0.006746346947705954):0.7340568317699766):0.0; 27 | tree STATE_6000 = (((1:0.6693276063477953,(3:0.03981380432299871,4:0.03981380432299871):0.6295138020247966):0.08092720614183935,5:0.7502548124896347):0.3464858206923642,2:1.0967406331819989):0.0; 28 | tree STATE_7000 = (((1:0.24494355012790703,5:0.24494355012790703):0.7367914630990596,(3:0.06452243075256824,4:0.06452243075256824):0.9172125824743984):0.027072779833751337,2:1.008807793060718):0.0; 29 | tree STATE_8000 = (1:0.8291478974191432,((2:0.7608640351177596,5:0.7608640351177596):0.006217429452784806,(3:0.052826647942534374,4:0.052826647942534374):0.71425481662801):0.06206643284859881):0.0; 30 | tree STATE_9000 = (((1:0.2090056271345508,2:0.2090056271345508):0.04985571367790104,5:0.2588613408124518):0.1941023293124854,(3:0.07366441485382572,4:0.07366441485382572):0.3792992552711115):0.0; 31 | tree STATE_10000 = (1:0.7693617408342179,(2:0.6138287429830985,((3:0.11136214949831788,4:0.11136214949831788):0.22798021162858859,5:0.33934236112690647):0.27448638185619206):0.1555329978511194):0.0; 32 | End; -------------------------------------------------------------------------------- /inst/extdata/beast2_example_output.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | beast.math.distributions.Uniform 23 | beast.math.distributions.Exponential 24 | beast.math.distributions.LogNormalDistributionModel 25 | beast.math.distributions.Normal 26 | beast.math.distributions.Beta 27 | beast.math.distributions.Gamma 28 | beast.math.distributions.LaplaceDistribution 29 | beast.math.distributions.Prior 30 | beast.math.distributions.InverseGamma 31 | beast.math.distributions.OneOnX 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 1.0 42 | 0.5 43 | 44 | 45 | 46 | 47 | 1.0 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 1.0 65 | 1.0 66 | 0.0 67 | 68 | 69 | 70 | 1.0 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | -------------------------------------------------------------------------------- /inst/extdata/beast2_example_output.xml.state: -------------------------------------------------------------------------------- 1 | 2 | (0:0.7693617408342179,(1:0.6138287429830985,((2:0.11136214949831788,3:0.11136214949831788)5:0.22798021162858859,4:0.33934236112690647)7:0.27448638185619206)6:0.1555329978511194)8:0.0 3 | birthRate2.t:test-alignment_to_beast_posterior[1 1] (0.0,10000.0): 1.5626755883603614 4 | relativeDeathRate2.t:test-alignment_to_beast_posterior[1 1] (0.0,1.0): 0.7107459018616334 5 | 6 | 19 | -------------------------------------------------------------------------------- /inst/extdata/read_beast2_trees_example.trees: -------------------------------------------------------------------------------- 1 | #NEXUS 2 | 3 | Begin taxa; 4 | Dimensions ntax=9; 5 | Taxlabels 6 | Outgroup 7 | S4-4-5 8 | S2-2-4 9 | S5-5-9 10 | S6-6-7 11 | S3-3-3 12 | S8-8-12 13 | S11-11-14 14 | S9-9-16 15 | ; 16 | End; 17 | Begin trees; 18 | Translate 19 | 1 Outgroup, 20 | 2 S4-4-5, 21 | 3 S2-2-4, 22 | 4 S5-5-9, 23 | 5 S6-6-7, 24 | 6 S3-3-3, 25 | 7 S8-8-12, 26 | 8 S11-11-14, 27 | 9 S9-9-16 28 | ; 29 | tree STATE_0 = ((((1:0.024852555146404526,(3:0.009788415459828687,7:0.009788415459828687):0.015064139686575839):0.07850131631638291,5:0.10335387146278743):0.5034657123339316,((4:0.057122092898438115,6:0.057122092898438115):0.10869223760866148,9:0.1658143305070996):0.44100525328961937):1.6656103075807691,(2:0.23761498824935767,8:0.23761498824935767):2.0348149031281304):0.0; 30 | tree STATE_1000 = (1:0.06030773122722403,(((2:0.020382842116821787,(3:0.010787256415556693,(4:0.00982471483987505,5:0.00982471483987505):9.625415756816438E-4):0.009595585701265093):6.102631335228072E-4,6:0.020993105250344594):0.02365093203406526,(7:0.03618974446708955,(8:0.006822022854008168,9:0.006822022854008168):0.029367721613081384):0.008454292817320304):0.015663693942814173):0.0; 31 | tree STATE_2000 = ((1:0.045678940967505285,(7:0.032645636247870154,(8:0.004077721473668053,9:0.004077721473668053):0.0285679147742021):0.013033304719635132):7.432789648864346E-4,((2:0.021030379455140955,6:0.021030379455140955):5.429250377382323E-4,(3:0.010128912154108247,(4:0.007694878343805154,5:0.007694878343805154):0.0024340338103030932):0.01144439233877094):0.024848915439512533):0.0; 32 | tree STATE_3000 = (1:0.04682759995287279,((2:0.021967521485903387,((3:0.011126182345734821,(4:0.010235983335370373,5:0.010235983335370373):8.901990103644484E-4):0.010601935231450341,6:0.021728117577185162):2.394039087182248E-4):0.023537502317463214,(7:0.03613581103769111,(8:0.002916961260620191,9:0.002916961260620191):0.03321884977707092):0.00936921276567549):0.001322576149506191):0.0; 33 | tree STATE_4000 = (1:0.04484244468181724,(((2:0.019063730937979705,(3:0.012030536397975454,(4:0.011688402287114173,5:0.011688402287114173):3.421341108612811E-4):0.007033194540004251):0.0014523995184000035,6:0.02051613045637971):0.023472301973278663,(7:0.030841484996212063,(8:0.0027349172260654037,9:0.0027349172260654037):0.02810656777014666):0.01314694743344631):8.540122521588644E-4):0.0; 34 | tree STATE_5000 = ((1:0.049448156773662495,(7:0.037076820833280046,(8:0.0036461361821263027,9:0.0036461361821263027):0.033430684651153744):0.01237133594038245):0.0024329184901895964,((2:0.02350230043706296,6:0.02350230043706296):2.8012856594862925E-4,(3:0.009132523349639982,(4:0.007054625667876917,5:0.007054625667876917):0.002077897681763065):0.014649905653371606):0.028098646260840503):0.0; 35 | tree STATE_6000 = ((1:0.04976072358713854,(7:0.035072518172974416,(8:0.002807423217721904,9:0.002807423217721904):0.03226509495525251):0.014688205414164122):0.007804531901946507,(2:0.025161074686101917,((3:0.015355083125456238,(4:0.01137702266944512,5:0.01137702266944512):0.003978060456011118):0.008105282297269794,6:0.02346036542272603):0.0017007092633758852):0.03240418080298313):0.0; 36 | tree STATE_7000 = (1:0.04799183697218584,(((2:0.01986001957368299,(3:0.011389863202821426,(4:0.007566982559682504,5:0.007566982559682504):0.003822880643138922):0.008470156370861563):2.2335387749743835E-4,6:0.020083373451180428):0.025274324411577218,(7:0.033455882818770884,(8:0.006020159749603111,9:0.006020159749603111):0.02743572306916777):0.011901815043986762):0.0026341391094281963):0.0; 37 | tree STATE_8000 = ((1:0.05055543812909785,(7:0.03652636964512963,(8:0.0017275694988637034,9:0.0017275694988637034):0.03479880014626593):0.014029068483968218):0.008347636828009326,((2:0.022602752607200512,6:0.022602752607200512):3.959468678311519E-4,(3:0.009418384559071718,(4:0.008101730809404453,5:0.008101730809404453):0.001316653749667265):0.013580314915959946):0.035904375482075514):0.0; 38 | tree STATE_9000 = ((1:0.0494725769366864,(2:0.02062823755595883,((3:0.011849204712348294,(4:0.007555151449150979,5:0.007555151449150979):0.004294053263197315):0.008401970589801876,6:0.02025117530215017):3.770622538086625E-4):0.028844339380727568):5.698740676009159E-4,(7:0.038723716969915264,(8:0.004057239888503209,9:0.004057239888503209):0.03466647708141206):0.01131873403437205):0.0; 39 | tree STATE_10000 = (1:0.05216512528607446,(((2:0.020898605964460495,6:0.020898605964460495):9.575198634821473E-4,(3:0.010627203605947984,(4:0.009408964596375746,5:0.009408964596375746):0.0012182390095722383):0.011228922221994658):0.02288514710252127,(7:0.034917188779573435,(8:0.0025313999713354623,9:0.0025313999713354623):0.032385788808237975):0.009824084150890477):0.00742385235561055):0.0; 40 | End; -------------------------------------------------------------------------------- /inst/java/beast.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beast-dev/RBeast/1e9ba811a1ac328dc4ee9209bb0c68c19fa3e43e/inst/java/beast.jar -------------------------------------------------------------------------------- /man/calc_act.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/calc_act.R 3 | \name{calc_act} 4 | \alias{calc_act} 5 | \title{Calculate the auto-correlation time, alternative implementation} 6 | \usage{ 7 | calc_act(trace, sample_interval) 8 | } 9 | \arguments{ 10 | \item{trace}{the values} 11 | 12 | \item{sample_interval}{the interval in timesteps between samples} 13 | } 14 | \value{ 15 | the auto_correlation time 16 | } 17 | \description{ 18 | Calculate the auto-correlation time, alternative implementation 19 | } 20 | \examples{ 21 | trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 100)) 22 | act <- RBeast::calc_act( 23 | trace = trace, 24 | sample_interval = 1 25 | ) 26 | testthat::expect_equal(object = act, expected = 38.18202, tolerance = 0.01) 27 | } 28 | \seealso{ 29 | Java code can be found here: \url{https://github.com/CompEvol/beast2/blob/9f040ed0357c4b946ea276a481a4c654ad4fff36/src/beast/core/util/ESS.java#L161} 30 | } 31 | \author{ 32 | The original Java version of the algorithm was from Remco Bouckaert, 33 | ported to R and adapted by Richel J.C. Bilderbeek 34 | } 35 | -------------------------------------------------------------------------------- /man/calc_act_r.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/calc_act.R 3 | \name{calc_act_r} 4 | \alias{calc_act_r} 5 | \title{Calculate the auto-correlation time using only R. Consider using calc_act 6 | instead, as it is orders of magnitude faster} 7 | \usage{ 8 | calc_act_r(trace, sample_interval) 9 | } 10 | \arguments{ 11 | \item{trace}{the values} 12 | 13 | \item{sample_interval}{the interval in timesteps between samples} 14 | } 15 | \value{ 16 | the auto_correlation time 17 | } 18 | \description{ 19 | Calculate the auto-correlation time using only R. Consider using calc_act 20 | instead, as it is orders of magnitude faster 21 | } 22 | \examples{ 23 | trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 100)) 24 | act <- RBeast::calc_act_r( 25 | trace = trace, 26 | sample_interval = 1 27 | ) 28 | testthat::expect_equal(object = act, expected = 38.18202, tolerance = 0.01) 29 | } 30 | \seealso{ 31 | Java code can be found here: \url{https://github.com/CompEvol/beast2/blob/9f040ed0357c4b946ea276a481a4c654ad4fff36/src/beast/core/util/ESS.java#L161} 32 | } 33 | \author{ 34 | The original Java version of the algorithm was from Remco Bouckaert, 35 | ported to R and adapted by Richel J.C. Bilderbeek 36 | } 37 | -------------------------------------------------------------------------------- /man/calc_ess.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/calc_ess.R 3 | \name{calc_ess} 4 | \alias{calc_ess} 5 | \title{Calculates the Effective Sample Size} 6 | \usage{ 7 | calc_ess(trace, sample_interval) 8 | } 9 | \arguments{ 10 | \item{trace}{the values without burn-in} 11 | 12 | \item{sample_interval}{the interval in timesteps between samples} 13 | } 14 | \value{ 15 | the effective sample size 16 | } 17 | \description{ 18 | Calculates the Effective Sample Size 19 | } 20 | \examples{ 21 | filename <- system.file( 22 | "extdata", "beast2_example_output.log", package = "RBeast" 23 | ) 24 | 25 | # Parse the file as-is and conclude the sampling interval 26 | df <- RBeast::parse_beast_log( 27 | filename = filename 28 | ) 29 | sample_interval <- df$Sample[2] - df$Sample[1] 30 | 31 | # Only keep the parameter estimates, do not care about the sampling times anymore 32 | estimates <- subset(df, select = -Sample) 33 | 34 | esses <- rep(NA, ncol(estimates)) 35 | burn_in_fraction <- 0.1 36 | for (i in seq_along(estimates)) { 37 | # Trace with the burn-in still present 38 | trace_raw <- as.numeric(t(estimates[i])) 39 | 40 | # Trace with the burn-in removed 41 | trace <- RBeast::remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 42 | 43 | # Store the effectice sample size 44 | esses[i] <- RBeast::calc_ess(trace, sample_interval = sample_interval) 45 | } 46 | 47 | # Use the values that TRACER shows 48 | expected_esses <- c(10, 10, 10, 10, 7, 10, 9, 6) 49 | testit::assert(all(expected_esses - esses < 0.5)) 50 | } 51 | \author{ 52 | Richel J.C. Bilderbeek 53 | } 54 | -------------------------------------------------------------------------------- /man/calc_esses.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/calc_esses.R 3 | \name{calc_esses} 4 | \alias{calc_esses} 5 | \title{Calculates the Effective Sample Sizes from a parsed BEAST2 log file} 6 | \usage{ 7 | calc_esses(traces, sample_interval) 8 | } 9 | \arguments{ 10 | \item{traces}{a dataframe with traces with removed burn-in} 11 | 12 | \item{sample_interval}{the interval in timesteps between samples} 13 | } 14 | \value{ 15 | the effective sample sizes 16 | } 17 | \description{ 18 | Calculates the Effective Sample Sizes from a parsed BEAST2 log file 19 | } 20 | \examples{ 21 | 22 | # Obtain an example log file its name 23 | filename <- system.file( 24 | "extdata", "beast2_example_output.log", package = "RBeast" 25 | ) 26 | 27 | # Parse that log file 28 | beast_log_full <- parse_beast_log(filename = filename) 29 | 30 | # Remove the burn-in 31 | beast_log <- remove_burn_ins( 32 | beast_log_full, 33 | burn_in_fraction = 0.1 34 | ) 35 | 36 | # Calculates the effective sample sizes of all parameter estimates 37 | esses <- calc_esses(beast_log, sample_interval = 1000) 38 | 39 | # Round off values to nearest integers 40 | esses <- as.integer(esses[1, ] + 0.5) 41 | expected <- c(10, 10, 10, 10, 7, 10, 9, 6) 42 | testit::assert(all(esses == expected)) 43 | 44 | } 45 | \author{ 46 | Richel J.C. Bilderbeek 47 | } 48 | -------------------------------------------------------------------------------- /man/is_posterior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/is_posterior.R 3 | \name{is_posterior} 4 | \alias{is_posterior} 5 | \title{Determines if the input is a BEAST2 posterior} 6 | \usage{ 7 | is_posterior(x) 8 | } 9 | \arguments{ 10 | \item{x}{the input} 11 | } 12 | \value{ 13 | TRUE or FALSE 14 | } 15 | \description{ 16 | Determines if the input is a BEAST2 posterior 17 | } 18 | \examples{ 19 | trees_filename <- system.file( 20 | "extdata", "beast2_example_output.trees", package = "RBeast" 21 | ) 22 | log_filename <- system.file( 23 | "extdata", "beast2_example_output.log", package = "RBeast" 24 | ) 25 | posterior <- parse_beast_posterior( 26 | trees_filename = trees_filename, 27 | log_filename = log_filename 28 | ) 29 | testit::assert(is_posterior(posterior)) 30 | } 31 | \author{ 32 | Richel J.C. Bilderbeek 33 | } 34 | -------------------------------------------------------------------------------- /man/is_trees_posterior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/is_trees_posterior.R 3 | \name{is_trees_posterior} 4 | \alias{is_trees_posterior} 5 | \title{Determines if the input is a BEAST2 posterior, 6 | as parsed by parse_beast_trees} 7 | \usage{ 8 | is_trees_posterior(x) 9 | } 10 | \arguments{ 11 | \item{x}{the input} 12 | } 13 | \value{ 14 | TRUE or FALSE 15 | } 16 | \description{ 17 | Determines if the input is a BEAST2 posterior, 18 | as parsed by parse_beast_trees 19 | } 20 | \author{ 21 | Richel J.C. Bilderbeek 22 | } 23 | -------------------------------------------------------------------------------- /man/parse_beast_log.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/parse_beast_log.R 3 | \name{parse_beast_log} 4 | \alias{parse_beast_log} 5 | \title{Parses a BEAST2 .log output file} 6 | \usage{ 7 | parse_beast_log(filename) 8 | } 9 | \arguments{ 10 | \item{filename}{name of the BEAST2 .log output file} 11 | } 12 | \value{ 13 | data frame with all the parameter estimates 14 | } 15 | \description{ 16 | Parses a BEAST2 .log output file 17 | } 18 | \examples{ 19 | log_filename <- system.file( 20 | "extdata", "beast2_example_output.log", package = "RBeast" 21 | ) 22 | estimates <- parse_beast_log(filename = log_filename) 23 | expected_names <- c( 24 | "Sample", "posterior", "likelihood", 25 | "prior", "treeLikelihood", "TreeHeight", 26 | "BirthDeath", "birthRate2", "relativeDeathRate2" 27 | ) 28 | testit::assert(names(estimates) == expected_names) 29 | } 30 | \author{ 31 | Richel J.C. Bilderbeek 32 | } 33 | -------------------------------------------------------------------------------- /man/parse_beast_posterior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/parse_beast_posterior.R 3 | \name{parse_beast_posterior} 4 | \alias{parse_beast_posterior} 5 | \title{Parses BEAST2 output files to a posterior} 6 | \usage{ 7 | parse_beast_posterior(trees_filename, log_filename) 8 | } 9 | \arguments{ 10 | \item{trees_filename}{name of the BEAST2 .trees output file} 11 | 12 | \item{log_filename}{name of the BEAST2 .trees output file} 13 | } 14 | \value{ 15 | a posterior 16 | } 17 | \description{ 18 | Parses BEAST2 output files to a posterior 19 | } 20 | \examples{ 21 | trees_filename <- system.file( 22 | "extdata", "beast2_example_output.trees", package = "RBeast" 23 | ) 24 | log_filename <- system.file( 25 | "extdata", "beast2_example_output.log", package = "RBeast" 26 | ) 27 | posterior <- parse_beast_posterior( 28 | trees_filename = trees_filename, 29 | log_filename = log_filename 30 | ) 31 | testit::assert(is_posterior(posterior)) 32 | } 33 | \author{ 34 | Richel J.C. Bilderbeek 35 | } 36 | -------------------------------------------------------------------------------- /man/parse_beast_state_operators.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/parse_beast_state.R 3 | \name{parse_beast_state_operators} 4 | \alias{parse_beast_state_operators} 5 | \title{Parses a BEAST2 .xml.state output file to get only the operators 6 | acceptances} 7 | \usage{ 8 | parse_beast_state_operators(filename = system.file("extdata", 9 | "beast2_example_output.xml.state", package = "RBeast")) 10 | } 11 | \arguments{ 12 | \item{filename}{name of the BEAST2 .xml.state output file} 13 | } 14 | \value{ 15 | data frame with all the operators' success rates 16 | } 17 | \description{ 18 | Parses a BEAST2 .xml.state output file to get only the operators 19 | acceptances 20 | } 21 | \examples{ 22 | xml_state_filename <- system.file( 23 | "extdata", "beast2_example_output.xml.state", package = "RBeast" 24 | ) 25 | estimates <- parse_beast_state_operators(filename = xml_state_filename) 26 | expected_names <- c("operator", "p", "accept", "reject", "acceptFC", 27 | "rejectFC", "rejectIv", "rejectOp") 28 | expected_operator <- c("treeScaler.t", "treeRootScaler.t", 29 | "UniformOperator.t", "SubtreeSlide.t", "narrow.t", "wide.t", 30 | "WilsonBalding.t", "BirthRateScaler.t", "DeathRateScaler.t") 31 | testit::assert(names(estimates) == expected_names) 32 | #testit::assert(estimates$operator == expected_operators) 33 | } 34 | \author{ 35 | Richel J.C. Bilderbeek 36 | } 37 | -------------------------------------------------------------------------------- /man/parse_beast_trees.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/parse_beast_trees.R 3 | \name{parse_beast_trees} 4 | \alias{parse_beast_trees} 5 | \title{Parses a BEAST2 .trees output file} 6 | \usage{ 7 | parse_beast_trees(filename) 8 | } 9 | \arguments{ 10 | \item{filename}{name of the BEAST2 .trees output file} 11 | } 12 | \value{ 13 | the phylogenies in the posterior 14 | } 15 | \description{ 16 | Parses a BEAST2 .trees output file 17 | } 18 | \examples{ 19 | trees_filename <- system.file( 20 | "extdata", "beast2_example_output.trees", package = "RBeast" 21 | ) 22 | posterior <- parse_beast_trees( 23 | filename = trees_filename 24 | ) 25 | testit::assert(is_trees_posterior(posterior)) 26 | } 27 | \author{ 28 | Richel J.C. Bilderbeek 29 | } 30 | -------------------------------------------------------------------------------- /man/plot_glm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plot_glm.R 3 | \name{plot_glm} 4 | \alias{plot_glm} 5 | \title{Plots the results of a GLM analysis from BEAST} 6 | \usage{ 7 | plot_glm(Names, Log, prob_zero = 0.5, cutoffs = c(3, 50), 8 | intercept = FALSE, alpha = 0.95, conditional = TRUE, 9 | burnin = 0.2, title = "", export = TRUE, file_name = "GLM_plot") 10 | } 11 | \arguments{ 12 | \item{Names}{a character vector with the predictor names (labels)} 13 | 14 | \item{Log}{a dataframe with traces without burnin} 15 | 16 | \item{prob_zero}{a scalar specifying the probability that no predictors are included (default: 0.5)} 17 | 18 | \item{cutoffs}{a numeric vector with the Bayes factor cutoffs to be used (dotted lines in the plot, default: 3 and 50)} 19 | 20 | \item{intercept}{a boolean specifying whether the model has an intercept (default: FALSE)} 21 | 22 | \item{alpha}{a scalar with the credibility level to be used for credibility intervals (default:0.95)} 23 | 24 | \item{conditional}{a boolean specifying whether the coeffcients should be plotted conditionally} 25 | 26 | \item{burnin}{a scalar specifying the *proportion* of the samples to discard as burn-in/warm-up} 27 | 28 | \item{title}{a character with the title in the plot (default: none)} 29 | 30 | \item{export}{a boolean (default: TRUE)} 31 | 32 | \item{file_name}{a character specifying the name of the output PDF file. Ignored if export = FALSE.} 33 | } 34 | \value{ 35 | a (ggplot) plot object showing inclusion probabilities, Bayes factors and coefficient estimates 36 | } 37 | \description{ 38 | Plots the results of a GLM analysis from BEAST 39 | } 40 | \author{ 41 | Luiz Max Carvalho/Philippe Lemey/Nuno Faria 42 | } 43 | -------------------------------------------------------------------------------- /man/plot_simple_glm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plot_glm.R 3 | \name{plot_simple_glm} 4 | \alias{plot_simple_glm} 5 | \title{Plots the results of a GLM analysis from BEAST} 6 | \usage{ 7 | plot_simple_glm(Names, Log, prob_zero = 0.5, cutoffs = c(3, 50), 8 | intercept = FALSE, alpha = 0.95, conditional = TRUE, title = "", 9 | burnin = 0.2, export = TRUE, file_name = "GLM_plot") 10 | } 11 | \arguments{ 12 | \item{Names}{a character vector with the predictor names (labels)} 13 | 14 | \item{Log}{a dataframe with traces without burnin} 15 | 16 | \item{prob_zero}{a scalar specifying the probability that no predictors are included (default: 0.5)} 17 | 18 | \item{cutoffs}{a numeric vector with the Bayes factor cutoffs to be used (dotted lines in the plot, default: 3 and 50)} 19 | 20 | \item{intercept}{a boolean specifying whether the model has an intercept (default: FALSE)} 21 | 22 | \item{alpha}{a scalar with the credibility level to be used for credibility intervals (default:0.95)} 23 | 24 | \item{conditional}{a boolean specifying whether the coeffcients should be plotted conditionally} 25 | 26 | \item{title}{a character with the title in the plot (default: none)} 27 | 28 | \item{burnin}{a scalar specifying the *proportion* of the samples to discard as burn-in/warm-up} 29 | 30 | \item{export}{a boolean (default: TRUE)} 31 | 32 | \item{file_name}{a character specifying the name of the output PDF file. Ignored if export = FALSE.} 33 | } 34 | \value{ 35 | a (ggplot) plot object showing inclusion probabilities, Bayes factors and coefficient estimates 36 | } 37 | \description{ 38 | Plots the results of a GLM analysis from BEAST 39 | } 40 | \author{ 41 | Luiz Max Carvalho/Philippe Lemey/Nuno Faria 42 | } 43 | -------------------------------------------------------------------------------- /man/read_beast2_trees.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/read_beast2_trees.R 3 | \name{read_beast2_trees} 4 | \alias{read_beast2_trees} 5 | \title{Extract a list of phylogenies from a BEAST2 posterior file} 6 | \usage{ 7 | read_beast2_trees(filename) 8 | } 9 | \arguments{ 10 | \item{filename}{name of the BEAST2 posterior filename, usually ends with '.trees'} 11 | } 12 | \value{ 13 | a list of phylogenies of type 'phylo' 14 | } 15 | \description{ 16 | Extract a list of phylogenies from a BEAST2 posterior file 17 | } 18 | \examples{ 19 | trees_file <- system.file( 20 | "extdata", "read_beast2_trees_example.trees", package = "RBeast" 21 | ) 22 | testit::assert(file.exists(trees_file)) 23 | posterior <- read_beast2_trees(trees_file) 24 | testit::assert(length(posterior) == 11) 25 | testit::assert(class(posterior[[1]]) == "phylo") 26 | } 27 | \author{ 28 | Richel J.C. Bilderbeek 29 | } 30 | -------------------------------------------------------------------------------- /man/remove_burn_in.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/remove_burn_in.R 3 | \name{remove_burn_in} 4 | \alias{remove_burn_in} 5 | \title{Removed the burn-in from a trace} 6 | \usage{ 7 | remove_burn_in(trace, burn_in_fraction) 8 | } 9 | \arguments{ 10 | \item{trace}{the values} 11 | 12 | \item{burn_in_fraction}{the fraction that needs to be removed, must be [0,1>} 13 | } 14 | \value{ 15 | the values with the burn-in removed 16 | } 17 | \description{ 18 | Removed the burn-in from a trace 19 | } 20 | \examples{ 21 | # Create a trace from one to and including ten 22 | v <- seq(1, 10) 23 | 24 | # Remove the first ten percent of its values, 25 | # in this case removes the first value, which is one 26 | w <- remove_burn_in(trace = v, burn_in_fraction = 0.1) 27 | 28 | # Check that the result goes from two to ten 29 | testit::assert(w == seq(2, 10)) 30 | } 31 | \author{ 32 | Richel J.C. Bilderbeek 33 | } 34 | -------------------------------------------------------------------------------- /man/remove_burn_ins.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/remove_burn_ins.R 3 | \name{remove_burn_ins} 4 | \alias{remove_burn_ins} 5 | \title{Removed the burn-ins from a data frame} 6 | \usage{ 7 | remove_burn_ins(traces, burn_in_fraction) 8 | } 9 | \arguments{ 10 | \item{traces}{a data frame with traces} 11 | 12 | \item{burn_in_fraction}{the fraction that needs to be removed, must be [0,1>} 13 | } 14 | \value{ 15 | the data frame with the burn-in removed 16 | } 17 | \description{ 18 | Removed the burn-ins from a data frame 19 | } 20 | \author{ 21 | Richel J.C. Bilderbeek 22 | } 23 | -------------------------------------------------------------------------------- /man/runBeast.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotStackedAreas.R 3 | \name{runBeast} 4 | \alias{runBeast} 5 | \title{runBeast} 6 | \usage{ 7 | runBeast(commandLine = "") 8 | } 9 | \arguments{ 10 | \item{commandLine}{Command-line string to pass to BEAST} 11 | } 12 | \description{ 13 | \code{runBeast} spins up BEAST 14 | } 15 | \details{ 16 | This function executes BEAST through rJava. 17 | } 18 | \examples{ 19 | runBeast() 20 | } 21 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(RBeast) 3 | 4 | test_check("RBeast") 5 | -------------------------------------------------------------------------------- /tests/testthat/test-calc_act.R: -------------------------------------------------------------------------------- 1 | context("calc_act") 2 | 3 | test_that("calc_act use", { 4 | 5 | trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 100)) 6 | act <- RBeast::calc_act( 7 | trace = trace, 8 | sample_interval = 1 9 | ) 10 | testthat::expect_equal(object = act, expected = 38.18202, tolerance = 0.01) 11 | }) 12 | 13 | test_that("calc_act_r use", { 14 | 15 | trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 100)) 16 | act <- RBeast::calc_act_r( 17 | trace = trace, 18 | sample_interval = 1 19 | ) 20 | testthat::expect_equal(object = act, expected = 38.18202, tolerance = 0.01) 21 | }) 22 | 23 | 24 | test_that("calc_act abuse", { 25 | 26 | expect_error( 27 | calc_act(trace = "not numeric", sample_interval = 1), 28 | "trace must be numeric" 29 | ) 30 | 31 | expect_error( 32 | calc_act(trace = seq(1, 10), sample_interval = 0), 33 | "sample interval must be at least one" 34 | ) 35 | 36 | }) 37 | -------------------------------------------------------------------------------- /tests/testthat/test-calc_ess.R: -------------------------------------------------------------------------------- 1 | context("calc_ess") 2 | 3 | test_that("exanple usage", { 4 | 5 | filename <- system.file( 6 | "extdata", "beast2_example_output.log", package = "RBeast" 7 | ) 8 | 9 | # Parse the file as-is and conclude the sampling interval 10 | df <- RBeast::parse_beast_log( 11 | filename = filename 12 | ) 13 | sample_interval <- df$Sample[2] - df$Sample[1] 14 | 15 | # Only keep the parameter estimates, do not care about the sampling times anymore 16 | estimates <- subset(df, select = -Sample) 17 | 18 | esses <- rep(NA, ncol(estimates)) 19 | burn_in_fraction <- 0.1 20 | for (i in seq_along(estimates)) { 21 | # Trace with the burn-in still present 22 | trace_raw <- as.numeric(t(estimates[i])) 23 | 24 | # Trace with the burn-in removed 25 | trace <- RBeast::remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 26 | 27 | # Store the effectice sample size 28 | esses[i] <- RBeast::calc_ess(trace, sample_interval = sample_interval) 29 | } 30 | 31 | # Use the values that TRACER shows 32 | expected_esses <- c(10, 10, 10, 10, 7, 10, 9, 6) 33 | testthat::expect_true(all(expected_esses - esses < 0.5)) 34 | }) 35 | 36 | test_that("calc_ess: abuse", { 37 | 38 | expect_error( 39 | calc_ess(trace = "not numeric", sample_interval = 1), 40 | "trace must be numeric" 41 | ) 42 | 43 | expect_error( 44 | calc_ess(trace = seq(1, 10), sample_interval = 0), 45 | "sample interval must be at least one" 46 | ) 47 | 48 | }) 49 | -------------------------------------------------------------------------------- /tests/testthat/test-calc_esses.R: -------------------------------------------------------------------------------- 1 | context("calc_esses") 2 | 3 | test_that("calc_esses: use", { 4 | 5 | filename <- system.file( 6 | "extdata", "beast2_example_output.log", package = "RBeast" 7 | ) 8 | 9 | estimates_raw <- parse_beast_log( 10 | filename = filename 11 | ) 12 | 13 | # Remove burn-ins 14 | estimates <- remove_burn_ins( 15 | estimates_raw, 16 | burn_in_fraction = 0.1 17 | ) 18 | df <- calc_esses(estimates, sample_interval = 1000) 19 | 20 | df_expected <- df 21 | df_expected[1, ] <- c(10, 10, 10, 10, 7, 10, 9, 6) 22 | df[1, ] <- as.integer(df[1, ] + 0.5) # Round off 23 | 24 | 25 | expect_true(identical(df, df_expected)) 26 | }) 27 | 28 | test_that("calc_esses: abuse", { 29 | 30 | expect_error( 31 | calc_esses(traces = "not numeric", sample_interval = 1), 32 | "traces must be a data.frame" 33 | ) 34 | 35 | expect_error( 36 | calc_esses( 37 | traces = data.frame(x = seq(1, 10), y = seq(2, 11)), 38 | sample_interval = 0 39 | ), 40 | "sample interval must be at least one" 41 | ) 42 | 43 | }) 44 | -------------------------------------------------------------------------------- /tests/testthat/test-is_posterior.R: -------------------------------------------------------------------------------- 1 | context("is_posterior") 2 | 3 | test_that("detect posterior", { 4 | 5 | trees_filename <- system.file( 6 | "extdata", "beast2_example_output.trees", package = "RBeast" 7 | ) 8 | testit::assert(file.exists(trees_filename)) 9 | 10 | log_filename <- system.file( 11 | "extdata", "beast2_example_output.log", package = "RBeast" 12 | ) 13 | testit::assert(file.exists(log_filename)) 14 | 15 | posterior <- RBeast::parse_beast_posterior( 16 | trees_filename = trees_filename, 17 | log_filename = log_filename 18 | ) 19 | testthat::expect_true(is_posterior(posterior)) 20 | 21 | }) 22 | 23 | test_that("detect non-posteriors", { 24 | 25 | testthat::expect_false( 26 | RBeast::is_posterior("nonsense") 27 | ) 28 | 29 | testthat::expect_false( 30 | RBeast::is_posterior(list("estimates" = NA, "nonsense" = NA)) 31 | ) 32 | testthat::expect_false( 33 | RBeast::is_posterior(list("trees" = NA, "nonsense" = NA)) 34 | ) 35 | 36 | testthat::expect_true( 37 | RBeast::is_posterior(list("trees" = NA, "estimates" = NA)) 38 | ) 39 | 40 | }) 41 | -------------------------------------------------------------------------------- /tests/testthat/test-is_trees_posterior.R: -------------------------------------------------------------------------------- 1 | context("is_trees_posterior") 2 | 3 | test_that("can find is_trees_posterior_test.R", { 4 | filename <- system.file( 5 | "extdata", "beast2_example_output.trees", package = "RBeast" 6 | ) 7 | file_exists <- file.exists(filename) 8 | expect_true(file_exists) 9 | }) 10 | 11 | test_that("can create a posterior", { 12 | filename <- system.file( 13 | "extdata", "beast2_example_output.trees", package = "RBeast" 14 | ) 15 | posterior <- parse_beast_trees( 16 | filename 17 | ) 18 | expect_true(is_trees_posterior(posterior)) 19 | }) 20 | -------------------------------------------------------------------------------- /tests/testthat/test-parse_beast_log.R: -------------------------------------------------------------------------------- 1 | context("parse_beast_log") 2 | 3 | test_that("parse_beast_log: use", { 4 | 5 | filename <- system.file( 6 | "extdata", "beast2_example_output.log", package = "RBeast" 7 | ) 8 | 9 | estimates <- RBeast::parse_beast_log( 10 | filename = filename 11 | ) 12 | expected_names <- c( 13 | "Sample", "posterior", "likelihood", 14 | "prior", "treeLikelihood", "TreeHeight", 15 | "BirthDeath", "birthRate2", "relativeDeathRate2" 16 | ) 17 | testthat::expect_equal(names(estimates), expected_names) 18 | 19 | }) 20 | -------------------------------------------------------------------------------- /tests/testthat/test-parse_beast_state_operators.R: -------------------------------------------------------------------------------- 1 | context("parse_beast_state_operators") 2 | 3 | test_that("column names are correct", { 4 | 5 | xml_state_filename <- system.file( 6 | "extdata", "beast2_example_output.xml.state", package = "RBeast" 7 | ) 8 | estimates <- parse_beast_state_operators(filename = xml_state_filename) 9 | expected_names <- c("operator", "p", "accept", "reject", "acceptFC", 10 | "rejectFC", "rejectIv", "rejectOp") 11 | testthat::expect_equal(names(estimates), expected_names) 12 | }) 13 | -------------------------------------------------------------------------------- /tests/testthat/test-parse_beast_trees.R: -------------------------------------------------------------------------------- 1 | context("parse_beast_trees") 2 | 3 | test_that("parse_beast_trees: use", { 4 | 5 | filename <- system.file( 6 | "extdata", "beast2_example_output.trees", package = "RBeast" 7 | ) 8 | 9 | posterior <- parse_beast_trees( 10 | filename = filename 11 | ) 12 | expect_true(is_trees_posterior(posterior)) 13 | }) 14 | -------------------------------------------------------------------------------- /tests/testthat/test-read_beast2_trees.R: -------------------------------------------------------------------------------- 1 | context("read_beast2_trees") 2 | 3 | test_that("read_beast2_trees: use", { 4 | trees_file <- system.file( 5 | "extdata", "read_beast2_trees_example.trees", package = "RBeast" 6 | ) 7 | expect_true(file.exists(trees_file)) 8 | posterior <- read_beast2_trees(trees_file) 9 | expect_equal(length(posterior), 11) 10 | expect_equal(class(posterior[[1]]), "phylo") 11 | }) 12 | -------------------------------------------------------------------------------- /tests/testthat/test-remove_burn_in.R: -------------------------------------------------------------------------------- 1 | context("remove_burn_in") 2 | 3 | test_that("remove_burn_in: use", { 4 | 5 | # Remove first ten percent 6 | v <- seq(1, 10) 7 | w <- remove_burn_in(trace = v, burn_in_fraction = 0.1) 8 | expect_equal(w, seq(2, 10)) 9 | }) 10 | -------------------------------------------------------------------------------- /tests/testthat/test-remove_burn_ins.R: -------------------------------------------------------------------------------- 1 | context("remove_burn_ins") 2 | 3 | test_that("normal use", { 4 | 5 | # Remove first ten percent 6 | v <- data.frame(x = seq(1, 10), y = seq(11, 20)) 7 | w <- remove_burn_ins(trace = v, burn_in_fraction = 0.1) 8 | expected <- data.frame(x = seq(2, 10), y = seq(12, 20)) 9 | names(expected) <- names(w) 10 | 11 | expect_true(all(w == expected)) 12 | }) 13 | -------------------------------------------------------------------------------- /vignettes/GLM_plot.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Plotting the result of a GLM in BEAST" 3 | author: "Luiz Max Carvalho" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Reading a BEAST posterior} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | ## Load the package 12 | ```{r pkg} 13 | library(RBeast) 14 | ``` 15 | ## Load the data 16 | 17 | ```{r data} 18 | logfile <- system.file("extdata", "beast_glm_example.log", package = "RBeast") 19 | glm.log <- read.table(file = logfile, header = TRUE) 20 | ``` 21 | 22 | ## Making the plot 23 | 24 | ```{r glm1} 25 | predictor.names <- c("hostDistance", "rangeOverlap", "roostStructures", 26 | "wingAspectRatio", "wingLoading", "bodySize") 27 | ``` 28 | 29 | ```{r plot0, fig.align="center", fig.width=8, fig.asp = 0.6} 30 | plot_simple_glm(Names = predictor.names, Log = glm.log, intercept = FALSE, 31 | conditional = TRUE, export = FALSE) 32 | ``` 33 | 34 | ```{r plot1, fig.width=8, fig.asp = 0.6} 35 | plot_glm(Names = predictor.names, Log = glm.log, intercept = FALSE, 36 | conditional = TRUE, export = FALSE) 37 | ``` 38 | -------------------------------------------------------------------------------- /vignettes/demo_estimate_effective_sample_size.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | library(RBeast) 3 | library(coda) 4 | 5 | ## ------------------------------------------------------------------------ 6 | trees_file <- system.file( 7 | "extdata", "beast2_example_output.log", package = "RBeast" 8 | ) 9 | testit::assert(file.exists(trees_file)) 10 | estimates <- parse_beast_log( 11 | filename = trees_file 12 | ) 13 | 14 | knitr::kable(estimates) 15 | 16 | ## ------------------------------------------------------------------------ 17 | esses <- rep(NA, ncol(estimates)) 18 | burn_in_fraction <- 0.1 19 | for (i in seq_along(estimates)) { 20 | # Trace with the burn-in still present 21 | trace_raw <- as.numeric(t(estimates[i])) 22 | 23 | # Trace with the burn-in removed 24 | trace <- remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 25 | 26 | # Store the effectice sample size 27 | esses[i] <- calc_ess(trace, sample_interval = 1000) 28 | } 29 | 30 | # Note that the first value of three is nonsense: 31 | # it is the index of the sample. I keep it in 32 | # for simplicity of writing this code 33 | expected_esses <- c(3, 10, 10, 10, 10, 7, 10, 9, 6) 34 | testit::assert(all(expected_esses - esses < 0.5)) 35 | 36 | df_esses <- data.frame(esses) 37 | rownames(df_esses) <- names(estimates) 38 | knitr::kable(df_esses) 39 | 40 | ## ----fig.width = 7, fig.height = 7--------------------------------------- 41 | melted <- reshape2::melt(estimates, id.vars = c("Sample")) 42 | 43 | ggplot2::ggplot( 44 | melted, 45 | ggplot2::aes( 46 | x = melted$Sample, 47 | y = melted$value, 48 | color = as.factor(melted$variable) 49 | ) 50 | ) + ggplot2::geom_line() + 51 | ggplot2::ggtitle("Parameter estimates") 52 | 53 | -------------------------------------------------------------------------------- /vignettes/demo_estimate_effective_sample_size.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Demonstration of estimating the effective sample size of an MCMC" 3 | author: "Richel J.C. Bilderbeek" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Demonstration of estimating the effective sample size of an MCMC} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | 13 | 14 | ```{r} 15 | library(RBeast) 16 | library(coda) 17 | ``` 18 | 19 | ```{r} 20 | trees_file <- system.file( 21 | "extdata", "beast2_example_output.log", package = "RBeast" 22 | ) 23 | testit::assert(file.exists(trees_file)) 24 | estimates <- parse_beast_log( 25 | filename = trees_file 26 | ) 27 | 28 | knitr::kable(estimates) 29 | ``` 30 | 31 | Display the ESSes: 32 | 33 | ```{r} 34 | esses <- rep(NA, ncol(estimates)) 35 | burn_in_fraction <- 0.1 36 | for (i in seq_along(estimates)) { 37 | # Trace with the burn-in still present 38 | trace_raw <- as.numeric(t(estimates[i])) 39 | 40 | # Trace with the burn-in removed 41 | trace <- remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 42 | 43 | # Store the effectice sample size 44 | esses[i] <- calc_ess(trace, sample_interval = 1000) 45 | } 46 | 47 | # Note that the first value of three is nonsense: 48 | # it is the index of the sample. I keep it in 49 | # for simplicity of writing this code 50 | expected_esses <- c(3, 10, 10, 10, 10, 7, 10, 9, 6) 51 | testit::assert(all(expected_esses - esses < 0.5)) 52 | 53 | df_esses <- data.frame(esses) 54 | rownames(df_esses) <- names(estimates) 55 | knitr::kable(df_esses) 56 | ``` 57 | 58 | I will melt these, to plot all at once: 59 | 60 | ```{r fig.width = 7, fig.height = 7} 61 | melted <- reshape2::melt(estimates, id.vars = c("Sample")) 62 | 63 | ggplot2::ggplot( 64 | melted, 65 | ggplot2::aes( 66 | x = melted$Sample, 67 | y = melted$value, 68 | color = as.factor(melted$variable) 69 | ) 70 | ) + ggplot2::geom_line() + 71 | ggplot2::ggtitle("Parameter estimates") 72 | ``` 73 | -------------------------------------------------------------------------------- /vignettes/profile_calc_act.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | library(RBeast) 3 | 4 | ## ------------------------------------------------------------------------ 5 | trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 10)) 6 | 7 | ## ------------------------------------------------------------------------ 8 | n_sizes <- 6 9 | n_types <- 2 10 | elapseds <- data.frame( 11 | type = as.factor(rep(c("cpp", "r"), times = n_sizes)), 12 | size = rep(NA, times = n_sizes * n_types), 13 | t_sec = rep(NA, times = n_sizes * n_types) 14 | ) 15 | 16 | 17 | for (i in seq(1, n_sizes)) 18 | { 19 | # Duplicate input 20 | trace <- c(trace, trace) 21 | 22 | # Measure again 23 | t_r <- rbenchmark::benchmark( 24 | RBeast::calc_act_r(trace, sample_interval = 2), 25 | replications = 1, 26 | columns = c("elapsed") 27 | )$elapsed 28 | t_cpp <- rbenchmark::benchmark( 29 | RBeast::calc_act(trace, sample_interval = 2), 30 | replications = 1, 31 | columns = c("elapsed") 32 | )$elapsed 33 | 34 | elapseds$size[(i * 2) - 1] <- length(trace) 35 | elapseds$size[i * 2] <- length(trace) 36 | elapseds$t_sec[(i * 2) - 1] <- t_cpp 37 | elapseds$t_sec[i * 2] <- t_r 38 | } 39 | 40 | ## ------------------------------------------------------------------------ 41 | 42 | ggplot2::ggplot( 43 | data = elapseds, 44 | ggplot2::aes(x = size, y = t_sec, color = type) 45 | ) + ggplot2::geom_line() + 46 | ggplot2::geom_point() + 47 | ggplot2::ggtitle("cpp version is faster") 48 | 49 | -------------------------------------------------------------------------------- /vignettes/profile_calc_act.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Profile calc_act" 3 | author: "Richel J.C. Bilderbeek" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Profile calc_act} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | Goal if this vignette is to measure the run-time speed of `calc_act`, for 13 | [RBeast issue #10](https://github.com/beast-dev/RBeast/issues/10). 14 | 15 | ```{r} 16 | library(RBeast) 17 | ``` 18 | 19 | Create a trace: 20 | 21 | ```{r} 22 | trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 10)) 23 | ``` 24 | 25 | Every size, the size of `trace` is doubled. 26 | 27 | ```{r} 28 | n_sizes <- 6 29 | n_types <- 2 30 | elapseds <- data.frame( 31 | type = as.factor(rep(c("cpp", "r"), times = n_sizes)), 32 | size = rep(NA, times = n_sizes * n_types), 33 | t_sec = rep(NA, times = n_sizes * n_types) 34 | ) 35 | 36 | 37 | for (i in seq(1, n_sizes)) 38 | { 39 | # Duplicate input 40 | trace <- c(trace, trace) 41 | 42 | # Measure again 43 | t_r <- rbenchmark::benchmark( 44 | RBeast::calc_act_r(trace, sample_interval = 2), 45 | replications = 1, 46 | columns = c("elapsed") 47 | )$elapsed 48 | t_cpp <- rbenchmark::benchmark( 49 | RBeast::calc_act(trace, sample_interval = 2), 50 | replications = 1, 51 | columns = c("elapsed") 52 | )$elapsed 53 | 54 | elapseds$size[(i * 2) - 1] <- length(trace) 55 | elapseds$size[i * 2] <- length(trace) 56 | elapseds$t_sec[(i * 2) - 1] <- t_cpp 57 | elapseds$t_sec[i * 2] <- t_r 58 | } 59 | ``` 60 | 61 | In a plot: 62 | 63 | ```{r} 64 | 65 | ggplot2::ggplot( 66 | data = elapseds, 67 | ggplot2::aes(x = size, y = t_sec, color = type) 68 | ) + ggplot2::geom_line() + 69 | ggplot2::geom_point() + 70 | ggplot2::ggtitle("cpp version is faster") 71 | ``` 72 | 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /vignettes/profile_calc_act.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | Profile calc_act 18 | 19 | 20 | 21 | 22 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 |

Profile calc_act

72 |

Richel J.C. Bilderbeek

73 |

2017-12-21

74 | 75 | 76 | 77 |

Goal if this vignette is to measure the run-time speed of calc_act, for RBeast issue #10.

78 | 
library(RBeast)
79 |

Create a trace:

80 | 
trace <- sin(seq(from = 0.0, to = 2.0 * pi, length.out = 10))
81 |

Every size, the size of trace is doubled.

82 | 
n_sizes <- 6
 83 | n_types <- 2
 84 | elapseds <- data.frame(
 85 |   type = as.factor(rep(c("cpp", "r"), times = n_sizes)),
 86 |   size = rep(NA, times = n_sizes * n_types),
 87 |   t_sec = rep(NA, times = n_sizes * n_types)
 88 | )
 89 | 
 90 | 
 91 | for (i in seq(1, n_sizes))
 92 | {
 93 |   # Duplicate input
 94 |   trace <- c(trace, trace)
 95 |   
 96 |   # Measure again
 97 |   t_r <- rbenchmark::benchmark(
 98 |     RBeast::calc_act_r(trace, sample_interval = 2),
 99 |     replications = 1,
100 |     columns = c("elapsed")
101 |   )$elapsed
102 |   t_cpp <- rbenchmark::benchmark(
103 |     RBeast::calc_act(trace, sample_interval = 2),
104 |     replications = 1,
105 |     columns = c("elapsed")
106 |   )$elapsed
107 | 
108 |   elapseds$size[(i * 2) - 1] <- length(trace)  
109 |   elapseds$size[i * 2]  <- length(trace)
110 |   elapseds$t_sec[(i * 2) - 1] <- t_cpp  
111 |   elapseds$t_sec[i * 2] <- t_r
112 | }
113 |

In a plot:

114 | 
ggplot2::ggplot(
115 |  data = elapseds,
116 |  ggplot2::aes(x = size, y = t_sec, color = type)
117 | ) + ggplot2::geom_line() + 
118 |   ggplot2::geom_point() + 
119 |   ggplot2::ggtitle("cpp version is faster")
120 |

121 | 122 | 123 | 124 | 125 | 133 | 134 | 135 | 136 | -------------------------------------------------------------------------------- /vignettes/profile_calc_esses.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | library(RBeast) 3 | library(coda) 4 | 5 | ## ------------------------------------------------------------------------ 6 | trees_file <- system.file( 7 | "extdata", "beast2_example_output.log", package = "RBeast" 8 | ) 9 | testit::assert(file.exists(trees_file)) 10 | estimates <- parse_beast_log( 11 | filename = trees_file 12 | ) 13 | 14 | knitr::kable(estimates) 15 | 16 | ## ------------------------------------------------------------------------ 17 | esses <- rep(NA, ncol(estimates)) 18 | burn_in_fraction <- 0.1 19 | for (i in seq_along(estimates)) { 20 | # Trace with the burn-in still present 21 | trace_raw <- as.numeric(t(estimates[i])) 22 | 23 | # Trace with the burn-in removed 24 | trace <- remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 25 | 26 | # Store the effectice sample size 27 | esses[i] <- calc_ess(trace, sample_interval = 1000) 28 | } 29 | 30 | # Note that the first value of three is nonsense: 31 | # it is the index of the sample. I keep it in 32 | # for simplicity of writing this code 33 | expected_esses <- c(3, 10, 10, 10, 10, 7, 10, 9, 6) 34 | testit::assert(all(expected_esses - esses < 0.5)) 35 | 36 | df_esses <- data.frame(esses) 37 | rownames(df_esses) <- names(estimates) 38 | knitr::kable(df_esses) 39 | 40 | ## ------------------------------------------------------------------------ 41 | rprof_tmp_output <- "~/tmp_RBeast_rprof" 42 | Rprof(rprof_tmp_output) 43 | 44 | for (i in 1:1) { 45 | estimates <- rbind(estimates, estimates) 46 | } 47 | print(nrow(estimates)) 48 | 49 | esses <- rep(NA, ncol(estimates)) 50 | burn_in_fraction <- 0.1 51 | for (i in seq_along(estimates)) { 52 | # Trace with the burn-in still present 53 | trace_raw <- as.numeric(t(estimates[i])) 54 | 55 | # Trace with the burn-in removed 56 | trace <- remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 57 | 58 | # Store the effectice sample size 59 | esses[i] <- calc_ess(trace, sample_interval = 1000) 60 | } 61 | 62 | Rprof(NULL) 63 | summaryRprof(rprof_tmp_output) 64 | 65 | -------------------------------------------------------------------------------- /vignettes/profile_calc_esses.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Profile calc_esses" 3 | author: "Richel J.C. Bilderbeek" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Profile calc_esses} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | Goal if this vignette is to measure the big-O complexity 13 | of `calc_esses`, for 14 | [RBeast issue #10](https://github.com/beast-dev/RBeast/issues/10). 15 | 16 | It proves that `calc_esses`'s main speed is taken up by `calc_act` 17 | 18 | ```{r} 19 | library(RBeast) 20 | library(coda) 21 | ``` 22 | 23 | Starting point 24 | 25 | ```{r} 26 | trees_file <- system.file( 27 | "extdata", "beast2_example_output.log", package = "RBeast" 28 | ) 29 | testit::assert(file.exists(trees_file)) 30 | estimates <- parse_beast_log( 31 | filename = trees_file 32 | ) 33 | 34 | knitr::kable(estimates) 35 | ``` 36 | 37 | Display the ESSes: 38 | 39 | ```{r} 40 | esses <- rep(NA, ncol(estimates)) 41 | burn_in_fraction <- 0.1 42 | for (i in seq_along(estimates)) { 43 | # Trace with the burn-in still present 44 | trace_raw <- as.numeric(t(estimates[i])) 45 | 46 | # Trace with the burn-in removed 47 | trace <- remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 48 | 49 | # Store the effectice sample size 50 | esses[i] <- calc_ess(trace, sample_interval = 1000) 51 | } 52 | 53 | # Note that the first value of three is nonsense: 54 | # it is the index of the sample. I keep it in 55 | # for simplicity of writing this code 56 | expected_esses <- c(3, 10, 10, 10, 10, 7, 10, 9, 6) 57 | testit::assert(all(expected_esses - esses < 0.5)) 58 | 59 | df_esses <- data.frame(esses) 60 | rownames(df_esses) <- names(estimates) 61 | knitr::kable(df_esses) 62 | ``` 63 | 64 | Measuring run-time speed: 65 | 66 | ```{r} 67 | rprof_tmp_output <- "~/tmp_RBeast_rprof" 68 | Rprof(rprof_tmp_output) 69 | 70 | for (i in 1:1) { 71 | estimates <- rbind(estimates, estimates) 72 | } 73 | print(nrow(estimates)) 74 | 75 | esses <- rep(NA, ncol(estimates)) 76 | burn_in_fraction <- 0.1 77 | for (i in seq_along(estimates)) { 78 | # Trace with the burn-in still present 79 | trace_raw <- as.numeric(t(estimates[i])) 80 | 81 | # Trace with the burn-in removed 82 | trace <- remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1) 83 | 84 | # Store the effectice sample size 85 | esses[i] <- calc_ess(trace, sample_interval = 1000) 86 | } 87 | 88 | Rprof(NULL) 89 | summaryRprof(rprof_tmp_output) 90 | ``` 91 | -------------------------------------------------------------------------------- /vignettes/profile_calc_esses.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | Profile calc_esses 18 | 19 | 20 | 21 | 22 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 |

Profile calc_esses

72 |

Richel J.C. Bilderbeek

73 |

2017-12-21

74 | 75 | 76 | 77 |

Goal if this vignette is to measure the big-O complexity of calc_esses, for RBeast issue #10.

78 |

It proves that calc_esses’s main speed is taken up by calc_act

79 | 
library(RBeast)
 80 | library(coda)
81 |

Starting point

82 | 
trees_file <- system.file(
 83 |   "extdata", "beast2_example_output.log", package = "RBeast"
 84 | )
 85 | testit::assert(file.exists(trees_file))
 86 | estimates <- parse_beast_log(
 87 |   filename = trees_file
 88 | )
 89 | 
 90 | knitr::kable(estimates)
91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 |
SampleposteriorlikelihoodpriortreeLikelihoodTreeHeightBirthDeathbirthRate2relativeDeathRate2
0-76.40152-66.56126-9.840263-66.561260.6383792-2.9325071.00000000.5000000
1000-68.68523-60.11853-8.566701-60.118530.7003758-1.6589462.80412080.4952765
2000-70.06839-58.93807-11.130319-58.938071.4085182-4.2225640.79012760.3674313
3000-69.03990-58.90834-10.131561-58.908340.9220334-3.2238061.86374760.2496224
4000-74.15268-59.98232-14.170365-59.982321.8159958-7.2626101.78230700.3519155
5000-71.17163-61.56657-9.605062-61.566570.7408032-2.6973071.78495040.7085961
6000-69.64176-58.73713-10.904631-58.737131.0967406-3.9968751.11824660.3702605
7000-71.92546-61.43600-10.489461-61.436001.0088078-3.5817061.26108060.4008574
8000-69.59441-58.89381-10.700593-58.893810.8291479-3.7928380.39090760.5845426
9000-69.69113-62.40904-7.282093-62.409040.4529637-0.3743381.11232380.6983194
10000-71.86884-60.73520-11.133636-60.735200.7693617-4.2258801.56267560.7107459
229 |

Display the ESSes:

230 | 
esses <- rep(NA, ncol(estimates))
231 | burn_in_fraction <- 0.1
232 | for (i in seq_along(estimates)) {
233 |   # Trace with the burn-in still present
234 |   trace_raw <- as.numeric(t(estimates[i]))
235 | 
236 |   # Trace with the burn-in removed
237 |   trace <- remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1)
238 | 
239 |   # Store the effectice sample size
240 |   esses[i] <- calc_ess(trace, sample_interval = 1000)
241 | }
242 | 
243 | # Note that the first value of three is nonsense:
244 | # it is the index of the sample. I keep it in
245 | # for simplicity of writing this code
246 | expected_esses <- c(3, 10, 10, 10, 10, 7, 10, 9, 6)
247 | testit::assert(all(expected_esses - esses < 0.5))
248 | 
249 | df_esses <- data.frame(esses)
250 | rownames(df_esses) <- names(estimates)
251 | knitr::kable(df_esses)
252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | 266 | 267 | 268 | 269 | 270 | 271 | 272 | 273 | 274 | 275 | 276 | 277 | 278 | 279 | 280 | 281 | 282 | 283 | 284 | 285 | 286 | 287 | 288 | 289 | 290 | 291 | 292 | 293 | 294 | 295 | 296 | 297 |
esses
Sample2.668464
posterior10.000000
likelihood10.000000
prior10.000000
treeLikelihood10.000000
TreeHeight6.657254
BirthDeath10.000000
birthRate28.905181
relativeDeathRate26.217762
298 |

Measuring run-time speed:

299 | 
rprof_tmp_output <- "~/tmp_RBeast_rprof"
300 | Rprof(rprof_tmp_output)
301 | 
302 | for (i in 1:1) {
303 |   estimates <- rbind(estimates, estimates)
304 | }
305 | print(nrow(estimates))
306 | 
## [1] 22
307 | 
esses <- rep(NA, ncol(estimates))
308 | burn_in_fraction <- 0.1
309 | for (i in seq_along(estimates)) {
310 |   # Trace with the burn-in still present
311 |   trace_raw <- as.numeric(t(estimates[i]))
312 | 
313 |   # Trace with the burn-in removed
314 |   trace <- remove_burn_in(trace = trace_raw, burn_in_fraction = 0.1)
315 | 
316 |   # Store the effectice sample size
317 |   esses[i] <- calc_ess(trace, sample_interval = 1000)
318 | }
319 | 
320 | Rprof(NULL)
321 | summaryRprof(rprof_tmp_output)
322 | 
## $by.self
323 | ## [1] self.time  self.pct   total.time total.pct 
324 | ## <0 rows> (or 0-length row.names)
325 | ## 
326 | ## $by.total
327 | ## [1] total.time total.pct  self.time  self.pct  
328 | ## <0 rows> (or 0-length row.names)
329 | ## 
330 | ## $sample.interval
331 | ## [1] 0.02
332 | ## 
333 | ## $sampling.time
334 | ## [1] 0
335 | 336 | 337 | 338 | 339 | 347 | 348 | 349 | 350 | -------------------------------------------------------------------------------- /vignettes/read_beast2_trees.R: -------------------------------------------------------------------------------- 1 | ## ----message = FALSE----------------------------------------------------- 2 | library(RBeast) 3 | 4 | ## ------------------------------------------------------------------------ 5 | trees_file <- system.file( 6 | "extdata", "read_beast2_trees_example.trees", package = "RBeast" 7 | ) 8 | testit::assert(file.exists(trees_file)) 9 | 10 | ## ------------------------------------------------------------------------ 11 | 12 | posterior_trees <- read_beast2_trees(trees_file) 13 | 14 | ## ------------------------------------------------------------------------ 15 | names(posterior_trees) 16 | testit::assert(length(posterior_trees) == 11) 17 | 18 | ## ------------------------------------------------------------------------ 19 | testit::assert(class(posterior_trees[[1]]) == "phylo") 20 | 21 | ## ------------------------------------------------------------------------ 22 | for (p in posterior_trees) { 23 | graphics::plot(p) 24 | } 25 | 26 | ## ----fig.width = 7, fig.height = 7--------------------------------------- 27 | class(posterior_trees) <- "multiPhylo" 28 | phangorn::densiTree( 29 | posterior_trees, 30 | type = "cladogram", 31 | alpha = 1 32 | ) 33 | -------------------------------------------------------------------------------- /vignettes/read_beast2_trees.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Reading a BEAST posterior" 3 | author: "Richel J.C. Bilderbeek" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Reading a BEAST posterior} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | This vignette shows how to parse a BEAST2 posterior file using `RBeast`. 13 | 14 | Load the `RBeast` package: 15 | 16 | ```{r message = FALSE} 17 | library(RBeast) 18 | ``` 19 | 20 | 21 | ## Extracting the phylogenies from the .trees file 22 | 23 | Check if the example file can be found: 24 | 25 | ```{r} 26 | trees_file <- system.file( 27 | "extdata", "read_beast2_trees_example.trees", package = "RBeast" 28 | ) 29 | testit::assert(file.exists(trees_file)) 30 | ``` 31 | 32 | Parse the posterior: 33 | 34 | ```{r} 35 | 36 | posterior_trees <- read_beast2_trees(trees_file) 37 | ``` 38 | 39 | Investigating the posterior: 40 | 41 | ```{r} 42 | names(posterior_trees) 43 | testit::assert(length(posterior_trees) == 11) 44 | ``` 45 | 46 | We can see that the posterior has multiple states. 47 | 48 | Every state is a phylogeny: 49 | 50 | ```{r} 51 | testit::assert(class(posterior_trees[[1]]) == "phylo") 52 | ``` 53 | 54 | We can plot these all seperately: 55 | 56 | ```{r} 57 | for (p in posterior_trees) { 58 | graphics::plot(p) 59 | } 60 | ``` 61 | 62 | Or we plot all at once: 63 | 64 | ```{r fig.width = 7, fig.height = 7} 65 | class(posterior_trees) <- "multiPhylo" 66 | phangorn::densiTree( 67 | posterior_trees, 68 | type = "cladogram", 69 | alpha = 1 70 | ) 71 | ``` 72 | --------------------------------------------------------------------------------