Last updated on 2020-02-19 10:49:06 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 1.2.1 | 68.04 | 148.22 | 216.26 | WARN | |
| r-devel-linux-x86_64-debian-gcc | 1.2.1 | 47.74 | 114.17 | 161.91 | WARN | |
| r-devel-linux-x86_64-fedora-clang | 1.2.1 | 268.20 | WARN | |||
| r-devel-linux-x86_64-fedora-gcc | 1.2.1 | 253.08 | WARN | |||
| r-devel-windows-ix86+x86_64 | 1.2.1 | 90.00 | 192.00 | 282.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 1.2.1 | 149.00 | 209.00 | 358.00 | OK | |
| r-patched-linux-x86_64 | 1.2.1 | 47.31 | 128.10 | 175.41 | OK | |
| r-patched-solaris-x86 | 1.2.1 | 325.00 | OK | |||
| r-release-linux-x86_64 | 1.2.1 | 55.22 | 128.35 | 183.57 | OK | |
| r-release-windows-ix86+x86_64 | 1.2.1 | 98.00 | 187.00 | 285.00 | OK | |
| r-release-osx-x86_64 | 1.2.1 | NOTE | ||||
| r-oldrel-windows-ix86+x86_64 | 1.2.1 | 94.00 | 162.00 | 256.00 | OK | |
| r-oldrel-osx-x86_64 | 1.2.1 | NOTE |
Version: 1.2.1
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
...
--- re-building 'Intro_on_the_package.Rmd' using knitr
--- finished re-building 'Intro_on_the_package.Rmd'
--- re-building 'Making_prior_on_ratematrix.Rmd' using knitr
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
ratematrix
--- call from context ---
plotRatematrix(chain = post.unif.root, set.leg = c("trait_1",
"trait_2"), point.matrix = list(R), point.color = "red",
point.wd = 1.5)
--- call from argument ---
if (!class(point.matrix[[1]]) == "matrix") stop(" point.matrix need to be a list of matrices.")
--- R stacktrace ---
where 1: plotRatematrix(chain = post.unif.root, set.leg = c("trait_1",
"trait_2"), point.matrix = list(R), point.color = "red",
point.wd = 1.5)
where 2: eval(expr, envir, enclos)
where 3: eval(expr, envir, enclos)
where 4: withVisible(eval(expr, envir, enclos))
where 5: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 6: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 7: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 8: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 9: evaluate::evaluate(...)
where 10: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 11: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 12: block_exec(params)
where 13: call_block(x)
where 14: process_group.block(group)
where 15: process_group(group)
where 16: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 17: process_file(text, output)
where 18: knit(input, text = text, envir = envir, quiet = quiet)
where 19: knit2html(..., force_v1 = TRUE)
where 20: (if (grepl("\\.[Rr]md$", file)) knit2html_v1 else if (grepl("\\.[Rr]rst$",
file)) knit2pandoc else knit)(file, encoding = encoding,
quiet = quiet, envir = globalenv(), ...)
where 21: engine$weave(file, quiet = quiet, encoding = enc)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, classes, parentenv, handlers)
where 25: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
}, error = function(e) {
OK <<- FALSE
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 26: tools:::.buildOneVignette("Making_prior_on_ratematrix.Rmd", "/home/hornik/tmp/R.check/r-devel-clang/Work/PKGS/ratematrix.Rcheck/vign_test/ratematrix",
TRUE, FALSE, "Making_prior_on_ratematrix", "UTF-8", "/tmp/RtmpfdJq1Y/file6c002b231bb8.rds")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (chain, p = NULL, colors = NULL, set.xlim = NULL, set.leg = NULL,
l.cex = 0.7, ell.wd = 0.5, alphaOff = 1, alphaDiag = 1, alphaEll = 1,
hpd = 100, show.zero = FALSE, n.lines = 50, n.points = 200,
point.matrix = NULL, point.color = NULL, point.wd = 0.5)
{
ll_class <- length(class(chain))
if (ll_class == 1) {
correct_class <- grepl(pattern = "ratematrix", x = class(chain))
}
else {
correct_class <- any(sapply(class(chain), function(x) grepl(pattern = "ratematrix",
x = x)))
}
if (!correct_class)
stop("chain argument need to be a single MCMC chain. See 'mergePosterior' function to merge multiple MCMC chains together.")
if (is.null(chain$n_post_samples)) {
if (n.lines > nrow(chain[[1]])) {
n.lines <- nrow(chain[[1]])
}
}
else {
if (n.lines > chain$n_post_samples) {
n.lines <- chain$n_post_samples
}
}
if (is.null(p)) {
if (is.list(chain$matrix) & is.matrix(chain$matrix[[1]][[1]])) {
np <- length(chain$matrix)
p <- 1:np
}
else {
p <- 1
}
}
if (is.null(colors)) {
np <- length(p)
if (np > 9)
stop("Unable to generate colors for more than 9 regimes. Please define color vector using 'colors' argument.")
if (np == 1) {
colors <- "black"
}
else {
check <- c(np < 4, 3 < np && np < 6, np > 5)
cols <- list(c("#002244", "#69BE28", "#A5ACAF"),
c("#7fc97f", "#beaed4", "#fdc086", "#386cb0",
"#ffff99"), c("#bc80bd", "#d9d9d9", "#fccde5",
"#b3de69", "#fdb462", "#b3de69", "#fccde5",
"#d9d9d9", "#bc80bd"))
colors <- unlist(cols[check])[1:np]
}
}
if (is.null(set.leg)) {
if (is.null(chain$trait_names)) {
set.leg <- colnames(chain$root)
}
else {
set.leg <- chain$trait_names
}
}
if (length(p) == 1) {
if (is.list(chain$matrix) & is.matrix(chain$matrix[[p]][[1]])) {
cat("Plotting a single regime.", "\n")
dd <- ncol(chain$matrix[[p]][[1]])
ll <- length(chain$matrix[[p]])
if (class(chain) == "ratematrix_prior_sample") {
corr <- lapply(chain$matrix[[p]], decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[[p]][x, ]^2))
chain$matrix[[p]] <- rb.matrix
}
}
if (is.list(chain$matrix) & is.matrix(chain$matrix[[1]])) {
if (!p == 1)
stop("There is only one regime in the chain, then p need to be equal to 1.")
cat("Plotting a single regime.", "\n")
dd <- ncol(chain$matrix[[1]])
ll <- length(chain$matrix)
if (class(chain) == "ratematrix_prior_sample") {
corr <- lapply(chain$matrix, decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[x, ]^2))
chain$matrix <- rb.matrix
}
temp <- chain$matrix
rm(chain)
chain <- list()
chain$matrix <- list()
chain$matrix[[1]] <- temp
}
}
if (length(p) > 1) {
cat("Plotting multiple regimes.", "\n")
name.table <- rbind(names(chain$matrix)[p], colors)
cat("Table with regimes and colors (names or HEX):\n")
utils::write.table(format(name.table, justify = "right"),
row.names = F, col.names = F, quote = F)
check.mat <- vector()
check.length <- vector()
for (i in 1:length(p)) {
check.mat[i] <- ncol(chain$matrix[[p[i]]][[1]])
check.length[i] <- length(chain$matrix[[p[i]]])
}
equal.size <- sapply(2:length(p), function(x) check.mat[1] ==
check.mat[x])
equal.length <- sapply(2:length(p), function(x) check.length[1] ==
check.length[x])
if (!sum(equal.size) == (length(p) - 1))
stop("Matrix regimes do not have the same number of traits.")
if (!sum(equal.length) == (length(p) - 1))
stop("Chain for regimes do not have the same length.")
ll <- check.length[1]
dd <- check.mat[1]
if (class(chain) == "ratematrix_prior_sample") {
for (i in p) {
corr <- lapply(chain$matrix[[i]], decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[[i]][x, ]^2))
chain$matrix[[i]] <- rb.matrix
}
}
}
if (hpd < 100) {
frac <- (1 - (hpd/100))/2
prob <- c(frac, 1 - frac)
LL <- lapply(p, function(x) lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[x]],
function(x) x[y, ])))))
qq.list <- list()
for (w in 1:length(LL)) {
qq.list[[w]] <- list()
qq.count <- 1
for (i in 1:dd) {
for (j in i:dd) {
qq.list[[w]][[qq.count]] <- stats::quantile(x = LL[[w]][[i]][,
j], probs = prob)
qq.count <- qq.count + 1
}
}
}
if (ll < n.lines)
stop(" n.lines is larger than number of matrices in the chain.")
if (n.lines < 1)
stop(" n.lines need to be > 1.")
ss.list <- list()
sampled.LL <- list()
for (i in 1:length(p)) {
count <- 1
ss.list[[i]] <- vector()
while (count < n.lines) {
ss <- sample(1:ll, size = 1)
if (ss %in% ss.list[[i]])
next
if (checkHPD(chain$matrix[[p[i]]][[ss]], qq.list[[i]],
dd))
next
ss.list[[i]][count] <- ss
count <- count + 1
}
sampled.LL[[i]] <- lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[p[i]]][ss.list[[i]]],
function(x) x[y, ]))))
}
ell.data <- list()
for (w in 1:length(p)) {
ell.data.count <- 1
ell.data[[w]] <- list()
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.data[[w]][[ell.data.count]] <- getEllipseMatrix(mat = chain$matrix[[p[w]]][ss.list[[w]]],
traits = c(i, j), n.points = n.points)
ell.data.count <- ell.data.count + 1
}
}
}
if (!is.null(point.matrix)) {
if (!class(point.matrix) == "list")
stop(" point.matrix need to be a list of matrices.")
if (!length(point.matrix) == length(p))
stop("Lenght of point.matrix need to be equal to the number of regimes fitted to the tree.")
if (!class(point.matrix[[1]]) == "matrix")
stop(" point.matrix need to be a list of matrices.")
ell.point <- list()
for (w in 1:length(p)) {
ell.point[[w]] <- list()
ell.point.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.point[[w]][[ell.point.count]] <- getEllipseMatrix(mat = point.matrix[[w]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.point.count <- ell.point.count + 1
}
}
}
}
y.hist <- vector()
x.hist <- vector()
for (w in 1:length(p)) {
for (i in 1:dd) {
for (j in i:dd) {
x.hist <- c(min(x.hist[1], LL[[w]][[i]][, j],
na.rm = TRUE), max(x.hist[2], LL[[w]][[i]][,
j], na.rm = TRUE))
}
}
}
if (is.null(set.xlim)) {
wd <- (x.hist[2] - mean(x.hist))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(0, to = x.hist[2] + wd, by = wd)
xlim.hist <- x.hist
}
else {
wd <- (set.xlim[2] - mean(set.xlim))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- set.xlim
}
hists <- list()
ccat <- list()
for (w in 1:length(p)) {
hists[[w]] <- list()
ccat[[w]] <- list()
hist.count <- 1
for (i in 1:dd[1]) {
for (j in i:dd[1]) {
if (i == j) {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk.var)
ccat[[w]][[hist.count]] <- cut(hists[[w]][[hist.count]]$breaks,
c(-Inf, qq.list[[w]][[hist.count]][1],
qq.list[[w]][[hist.count]][2], Inf))
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
else {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk)
ccat[[w]][[hist.count]] <- cut(hists[[w]][[hist.count]]$breaks,
c(-Inf, qq.list[[w]][[hist.count]][1],
qq.list[[w]][[hist.count]][2], Inf))
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
}
}
}
ylim.hist <- c(0, y.hist)
ell.lim <- lapply(do.call(c, ell.data), function(x) x[[1]])
ell.lim <- do.call(rbind, ell.lim)
ell.lim <- apply(ell.lim, 2, range)
ell.lim.iso <- c(min(ell.lim[1, ]), max(ell.lim[2, ]))
old.par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(dd, dd))
graphics::par(cex = 0.6)
graphics::par(mar = c(0, 0, 0, 0), oma = c(2, 2, 2, 2))
graphics::par(tcl = -0.25)
graphics::par(mgp = c(2, 0.6, 0))
colOff <- grDevices::adjustcolor(col = colors, alpha.f = alphaOff)
colDiag <- grDevices::adjustcolor(col = colors, alpha.f = alphaDiag)
colEll <- grDevices::adjustcolor(col = colors, alpha.f = alphaEll)
if (is.null(point.color)) {
point.color <- colors
}
ell.plot.count <- 1
hist.plot.count <- 1
for (i in 1:dd) {
for (j in 1:dd) {
if (j >= i) {
graphics::plot(1, xlim = xlim.hist, ylim = ylim.hist,
axes = FALSE, type = "n", xlab = "", ylab = "")
mid <- mean(xlim.hist)
first.quart <- xlim.hist[1] + (mid - xlim.hist[1])/2
second.quart <- mid + (xlim.hist[2] - mid)/2
graphics::lines(x = c(mid, mid), y = ylim.hist,
type = "l", lty = 3, col = "grey")
graphics::lines(x = c(first.quart, first.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
graphics::lines(x = c(second.quart, second.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
if (show.zero == TRUE) {
graphics::lines(x = c(0, 0), y = ylim.hist,
type = "l", lty = 3, col = "blue")
}
graphics::box(col = "grey")
if (j != i) {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, border = "gray",
col = c("white", colOff[w], "white")[ccat[[w]][[hist.plot.count]]])
}
}
else {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, border = "black",
col = c("white", colDiag[w], "white")[ccat[[w]][[hist.plot.count]]])
}
if (i == dd[1]) {
graphics::axis(1, at = round(c(xlim.hist[1],
mean(xlim.hist), xlim.hist[2]), digits = 2))
}
}
if (i == 1) {
graphics::mtext(text = set.leg[j], side = 3,
cex = l.cex)
}
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
graphics::lines(x = c(point.matrix[[w]][i,
j], point.matrix[[w]][i, j]), y = ylim.hist,
type = "l", col = point.color[w], lwd = point.wd)
}
}
hist.plot.count <- hist.plot.count + 1
}
else {
graphics::plot(1, xlim = ell.lim.iso, ylim = ell.lim.iso,
axes = FALSE, type = "n", xlab = "", ylab = "")
graphics::box(col = "grey")
for (w in 1:length(p)) {
invisible(lapply(ell.data[[w]][[ell.plot.count]][[2]],
function(x) graphics::points(x, col = colEll[w],
type = "l", lwd = ell.wd)))
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
invisible(graphics::points(ell.point[[w]][[ell.plot.count]],
col = point.color[w], type = "l", lwd = point.wd))
}
}
ell.plot.count <- ell.plot.count + 1
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
}
}
}
graphics::par(old.par)
}
else {
LL <- lapply(p, function(x) lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[x]],
function(x) x[y, ])))))
ell.data <- list()
for (w in 1:length(p)) {
ell.data[[w]] <- list()
ell.data.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.data[[w]][[ell.data.count]] <- getEllipseMatrix(mat = chain$matrix[[p[w]]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.data.count <- ell.data.count + 1
}
}
}
if (!is.null(point.matrix)) {
if (!class(point.matrix) == "list")
stop(" point.matrix need to be a list of matrices.")
if (!length(point.matrix) == length(p))
stop("Lenght of point.matrix need to be equal to the number of regimes fitted to the tree.")
if (!class(point.matrix[[1]]) == "matrix")
stop(" point.matrix need to be a list of matrices.")
ell.point <- list()
for (w in 1:length(p)) {
ell.point[[w]] <- list()
ell.point.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.point[[w]][[ell.point.count]] <- getEllipseMatrix(mat = point.matrix[[w]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.point.count <- ell.point.count + 1
}
}
}
}
y.hist <- vector()
x.hist <- vector()
for (w in 1:length(p)) {
for (i in 1:dd) {
for (j in i:dd) {
x.hist <- c(min(x.hist[1], LL[[w]][[i]][, j],
na.rm = TRUE), max(x.hist[2], LL[[w]][[i]][,
j], na.rm = TRUE))
}
}
}
if (is.null(set.xlim)) {
wd <- (x.hist[2] - mean(x.hist))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- x.hist
}
else {
wd <- (set.xlim[2] - mean(set.xlim))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- set.xlim
}
hists <- list()
for (w in 1:length(p)) {
hists[[w]] <- list()
hist.count <- 1
for (i in 1:dd) {
for (j in i:dd) {
if (i == j) {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk.var)
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
else {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk)
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
}
}
}
ylim.hist <- c(0, y.hist)
ell.lim <- lapply(do.call(c, ell.data), function(x) x[[1]])
ell.lim <- do.call(rbind, ell.lim)
ell.lim <- apply(ell.lim, 2, range)
ell.lim.iso <- c(min(ell.lim[1, ]), max(ell.lim[2, ]))
old.par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(dd[1], dd[1]))
graphics::par(cex = 0.6)
graphics::par(mar = c(0, 0, 0, 0), oma = c(2, 2, 2, 2))
graphics::par(tcl = -0.25)
graphics::par(mgp = c(2, 0.6, 0))
colOff <- grDevices::adjustcolor(col = colors, alpha.f = alphaOff)
colDiag <- grDevices::adjustcolor(col = colors, alpha.f = alphaDiag)
colEll <- grDevices::adjustcolor(col = colors, alpha.f = alphaEll)
if (is.null(point.color)) {
point.color <- colors
}
ell.plot.count <- 1
hist.plot.count <- 1
for (i in 1:dd) {
for (j in 1:dd) {
if (j >= i) {
graphics::plot(1, xlim = xlim.hist, ylim = ylim.hist,
axes = FALSE, type = "n", xlab = "", ylab = "")
mid <- mean(xlim.hist)
first.quart <- xlim.hist[1] + (mid - xlim.hist[1])/2
second.quart <- mid + (xlim.hist[2] - mid)/2
graphics::lines(x = c(mid, mid), y = ylim.hist,
type = "l", lty = 3, col = "grey")
graphics::lines(x = c(first.quart, first.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
graphics::lines(x = c(second.quart, second.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
if (show.zero == TRUE) {
graphics::lines(x = c(0, 0), y = ylim.hist,
type = "l", lty = 3, col = "blue")
}
graphics::box(col = "grey")
if (j != i) {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, col = colOff[w],
border = "gray")
}
}
else {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, col = colDiag[w],
border = "black")
}
if (i == dd) {
graphics::axis(1, at = round(c(xlim.hist[1],
mean(xlim.hist), xlim.hist[2]), digits = 2))
}
}
if (i == 1) {
graphics::mtext(text = set.leg[j], side = 3,
cex = l.cex)
}
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
graphics::lines(x = c(point.matrix[[w]][i,
j], point.matrix[[w]][i, j]), y = ylim.hist,
type = "l", col = point.color[w], lwd = point.wd)
}
}
hist.plot.count <- hist.plot.count + 1
}
else {
graphics::plot(1, xlim = ell.lim.iso, ylim = ell.lim.iso,
axes = FALSE, type = "n", xlab = "", ylab = "")
graphics::box(col = "grey")
for (w in 1:length(p)) {
invisible(lapply(ell.data[[w]][[ell.plot.count]][[2]],
function(x) graphics::points(x, col = colEll[w],
type = "l", lwd = ell.wd)))
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
invisible(graphics::points(ell.point[[w]][[ell.plot.count]],
col = point.color[w], type = "l", lwd = point.wd))
}
}
ell.plot.count <- ell.plot.count + 1
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
}
}
}
graphics::par(old.par)
}
}
<bytecode: 0xf29eec8>
<environment: namespace:ratematrix>
--- function search by body ---
Function plotRatematrix in namespace ratematrix has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 186-188 (Making_prior_on_ratematrix.Rmd)
Error: processing vignette 'Making_prior_on_ratematrix.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building 'Making_prior_on_ratematrix.Rmd'
--- re-building 'Set_custom_starting_point.Rmd' using knitr
--- finished re-building 'Set_custom_starting_point.Rmd'
SUMMARY: processing the following file failed:
'Making_prior_on_ratematrix.Rmd'
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.2.1
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
...
--- re-building ‘Intro_on_the_package.Rmd’ using knitr
--- finished re-building ‘Intro_on_the_package.Rmd’
--- re-building ‘Making_prior_on_ratematrix.Rmd’ using knitr
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
ratematrix
--- call from context ---
plotRatematrix(chain = post.unif.root, set.leg = c("trait_1",
"trait_2"), point.matrix = list(R), point.color = "red",
point.wd = 1.5)
--- call from argument ---
if (!class(point.matrix[[1]]) == "matrix") stop(" point.matrix need to be a list of matrices.")
--- R stacktrace ---
where 1: plotRatematrix(chain = post.unif.root, set.leg = c("trait_1",
"trait_2"), point.matrix = list(R), point.color = "red",
point.wd = 1.5)
where 2: eval(expr, envir, enclos)
where 3: eval(expr, envir, enclos)
where 4: withVisible(eval(expr, envir, enclos))
where 5: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 6: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 7: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 8: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 9: evaluate::evaluate(...)
where 10: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 11: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 12: block_exec(params)
where 13: call_block(x)
where 14: process_group.block(group)
where 15: process_group(group)
where 16: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 17: process_file(text, output)
where 18: knit(input, text = text, envir = envir, quiet = quiet)
where 19: knit2html(..., force_v1 = TRUE)
where 20: (if (grepl("\\.[Rr]md$", file)) knit2html_v1 else if (grepl("\\.[Rr]rst$",
file)) knit2pandoc else knit)(file, encoding = encoding,
quiet = quiet, envir = globalenv(), ...)
where 21: engine$weave(file, quiet = quiet, encoding = enc)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, classes, parentenv, handlers)
where 25: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
}, error = function(e) {
OK <<- FALSE
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 26: tools:::.buildOneVignette("Making_prior_on_ratematrix.Rmd", "/home/hornik/tmp/R.check/r-devel-gcc/Work/PKGS/ratematrix.Rcheck/vign_test/ratematrix",
TRUE, FALSE, "Making_prior_on_ratematrix", "UTF-8", "/home/hornik/tmp/scratch/RtmpkxatGX/file35f25272e554.rds")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (chain, p = NULL, colors = NULL, set.xlim = NULL, set.leg = NULL,
l.cex = 0.7, ell.wd = 0.5, alphaOff = 1, alphaDiag = 1, alphaEll = 1,
hpd = 100, show.zero = FALSE, n.lines = 50, n.points = 200,
point.matrix = NULL, point.color = NULL, point.wd = 0.5)
{
ll_class <- length(class(chain))
if (ll_class == 1) {
correct_class <- grepl(pattern = "ratematrix", x = class(chain))
}
else {
correct_class <- any(sapply(class(chain), function(x) grepl(pattern = "ratematrix",
x = x)))
}
if (!correct_class)
stop("chain argument need to be a single MCMC chain. See 'mergePosterior' function to merge multiple MCMC chains together.")
if (is.null(chain$n_post_samples)) {
if (n.lines > nrow(chain[[1]])) {
n.lines <- nrow(chain[[1]])
}
}
else {
if (n.lines > chain$n_post_samples) {
n.lines <- chain$n_post_samples
}
}
if (is.null(p)) {
if (is.list(chain$matrix) & is.matrix(chain$matrix[[1]][[1]])) {
np <- length(chain$matrix)
p <- 1:np
}
else {
p <- 1
}
}
if (is.null(colors)) {
np <- length(p)
if (np > 9)
stop("Unable to generate colors for more than 9 regimes. Please define color vector using 'colors' argument.")
if (np == 1) {
colors <- "black"
}
else {
check <- c(np < 4, 3 < np && np < 6, np > 5)
cols <- list(c("#002244", "#69BE28", "#A5ACAF"),
c("#7fc97f", "#beaed4", "#fdc086", "#386cb0",
"#ffff99"), c("#bc80bd", "#d9d9d9", "#fccde5",
"#b3de69", "#fdb462", "#b3de69", "#fccde5",
"#d9d9d9", "#bc80bd"))
colors <- unlist(cols[check])[1:np]
}
}
if (is.null(set.leg)) {
if (is.null(chain$trait_names)) {
set.leg <- colnames(chain$root)
}
else {
set.leg <- chain$trait_names
}
}
if (length(p) == 1) {
if (is.list(chain$matrix) & is.matrix(chain$matrix[[p]][[1]])) {
cat("Plotting a single regime.", "\n")
dd <- ncol(chain$matrix[[p]][[1]])
ll <- length(chain$matrix[[p]])
if (class(chain) == "ratematrix_prior_sample") {
corr <- lapply(chain$matrix[[p]], decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[[p]][x, ]^2))
chain$matrix[[p]] <- rb.matrix
}
}
if (is.list(chain$matrix) & is.matrix(chain$matrix[[1]])) {
if (!p == 1)
stop("There is only one regime in the chain, then p need to be equal to 1.")
cat("Plotting a single regime.", "\n")
dd <- ncol(chain$matrix[[1]])
ll <- length(chain$matrix)
if (class(chain) == "ratematrix_prior_sample") {
corr <- lapply(chain$matrix, decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[x, ]^2))
chain$matrix <- rb.matrix
}
temp <- chain$matrix
rm(chain)
chain <- list()
chain$matrix <- list()
chain$matrix[[1]] <- temp
}
}
if (length(p) > 1) {
cat("Plotting multiple regimes.", "\n")
name.table <- rbind(names(chain$matrix)[p], colors)
cat("Table with regimes and colors (names or HEX):\n")
utils::write.table(format(name.table, justify = "right"),
row.names = F, col.names = F, quote = F)
check.mat <- vector()
check.length <- vector()
for (i in 1:length(p)) {
check.mat[i] <- ncol(chain$matrix[[p[i]]][[1]])
check.length[i] <- length(chain$matrix[[p[i]]])
}
equal.size <- sapply(2:length(p), function(x) check.mat[1] ==
check.mat[x])
equal.length <- sapply(2:length(p), function(x) check.length[1] ==
check.length[x])
if (!sum(equal.size) == (length(p) - 1))
stop("Matrix regimes do not have the same number of traits.")
if (!sum(equal.length) == (length(p) - 1))
stop("Chain for regimes do not have the same length.")
ll <- check.length[1]
dd <- check.mat[1]
if (class(chain) == "ratematrix_prior_sample") {
for (i in p) {
corr <- lapply(chain$matrix[[i]], decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[[i]][x, ]^2))
chain$matrix[[i]] <- rb.matrix
}
}
}
if (hpd < 100) {
frac <- (1 - (hpd/100))/2
prob <- c(frac, 1 - frac)
LL <- lapply(p, function(x) lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[x]],
function(x) x[y, ])))))
qq.list <- list()
for (w in 1:length(LL)) {
qq.list[[w]] <- list()
qq.count <- 1
for (i in 1:dd) {
for (j in i:dd) {
qq.list[[w]][[qq.count]] <- stats::quantile(x = LL[[w]][[i]][,
j], probs = prob)
qq.count <- qq.count + 1
}
}
}
if (ll < n.lines)
stop(" n.lines is larger than number of matrices in the chain.")
if (n.lines < 1)
stop(" n.lines need to be > 1.")
ss.list <- list()
sampled.LL <- list()
for (i in 1:length(p)) {
count <- 1
ss.list[[i]] <- vector()
while (count < n.lines) {
ss <- sample(1:ll, size = 1)
if (ss %in% ss.list[[i]])
next
if (checkHPD(chain$matrix[[p[i]]][[ss]], qq.list[[i]],
dd))
next
ss.list[[i]][count] <- ss
count <- count + 1
}
sampled.LL[[i]] <- lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[p[i]]][ss.list[[i]]],
function(x) x[y, ]))))
}
ell.data <- list()
for (w in 1:length(p)) {
ell.data.count <- 1
ell.data[[w]] <- list()
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.data[[w]][[ell.data.count]] <- getEllipseMatrix(mat = chain$matrix[[p[w]]][ss.list[[w]]],
traits = c(i, j), n.points = n.points)
ell.data.count <- ell.data.count + 1
}
}
}
if (!is.null(point.matrix)) {
if (!class(point.matrix) == "list")
stop(" point.matrix need to be a list of matrices.")
if (!length(point.matrix) == length(p))
stop("Lenght of point.matrix need to be equal to the number of regimes fitted to the tree.")
if (!class(point.matrix[[1]]) == "matrix")
stop(" point.matrix need to be a list of matrices.")
ell.point <- list()
for (w in 1:length(p)) {
ell.point[[w]] <- list()
ell.point.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.point[[w]][[ell.point.count]] <- getEllipseMatrix(mat = point.matrix[[w]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.point.count <- ell.point.count + 1
}
}
}
}
y.hist <- vector()
x.hist <- vector()
for (w in 1:length(p)) {
for (i in 1:dd) {
for (j in i:dd) {
x.hist <- c(min(x.hist[1], LL[[w]][[i]][, j],
na.rm = TRUE), max(x.hist[2], LL[[w]][[i]][,
j], na.rm = TRUE))
}
}
}
if (is.null(set.xlim)) {
wd <- (x.hist[2] - mean(x.hist))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(0, to = x.hist[2] + wd, by = wd)
xlim.hist <- x.hist
}
else {
wd <- (set.xlim[2] - mean(set.xlim))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- set.xlim
}
hists <- list()
ccat <- list()
for (w in 1:length(p)) {
hists[[w]] <- list()
ccat[[w]] <- list()
hist.count <- 1
for (i in 1:dd[1]) {
for (j in i:dd[1]) {
if (i == j) {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk.var)
ccat[[w]][[hist.count]] <- cut(hists[[w]][[hist.count]]$breaks,
c(-Inf, qq.list[[w]][[hist.count]][1],
qq.list[[w]][[hist.count]][2], Inf))
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
else {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk)
ccat[[w]][[hist.count]] <- cut(hists[[w]][[hist.count]]$breaks,
c(-Inf, qq.list[[w]][[hist.count]][1],
qq.list[[w]][[hist.count]][2], Inf))
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
}
}
}
ylim.hist <- c(0, y.hist)
ell.lim <- lapply(do.call(c, ell.data), function(x) x[[1]])
ell.lim <- do.call(rbind, ell.lim)
ell.lim <- apply(ell.lim, 2, range)
ell.lim.iso <- c(min(ell.lim[1, ]), max(ell.lim[2, ]))
old.par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(dd, dd))
graphics::par(cex = 0.6)
graphics::par(mar = c(0, 0, 0, 0), oma = c(2, 2, 2, 2))
graphics::par(tcl = -0.25)
graphics::par(mgp = c(2, 0.6, 0))
colOff <- grDevices::adjustcolor(col = colors, alpha.f = alphaOff)
colDiag <- grDevices::adjustcolor(col = colors, alpha.f = alphaDiag)
colEll <- grDevices::adjustcolor(col = colors, alpha.f = alphaEll)
if (is.null(point.color)) {
point.color <- colors
}
ell.plot.count <- 1
hist.plot.count <- 1
for (i in 1:dd) {
for (j in 1:dd) {
if (j >= i) {
graphics::plot(1, xlim = xlim.hist, ylim = ylim.hist,
axes = FALSE, type = "n", xlab = "", ylab = "")
mid <- mean(xlim.hist)
first.quart <- xlim.hist[1] + (mid - xlim.hist[1])/2
second.quart <- mid + (xlim.hist[2] - mid)/2
graphics::lines(x = c(mid, mid), y = ylim.hist,
type = "l", lty = 3, col = "grey")
graphics::lines(x = c(first.quart, first.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
graphics::lines(x = c(second.quart, second.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
if (show.zero == TRUE) {
graphics::lines(x = c(0, 0), y = ylim.hist,
type = "l", lty = 3, col = "blue")
}
graphics::box(col = "grey")
if (j != i) {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, border = "gray",
col = c("white", colOff[w], "white")[ccat[[w]][[hist.plot.count]]])
}
}
else {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, border = "black",
col = c("white", colDiag[w], "white")[ccat[[w]][[hist.plot.count]]])
}
if (i == dd[1]) {
graphics::axis(1, at = round(c(xlim.hist[1],
mean(xlim.hist), xlim.hist[2]), digits = 2))
}
}
if (i == 1) {
graphics::mtext(text = set.leg[j], side = 3,
cex = l.cex)
}
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
graphics::lines(x = c(point.matrix[[w]][i,
j], point.matrix[[w]][i, j]), y = ylim.hist,
type = "l", col = point.color[w], lwd = point.wd)
}
}
hist.plot.count <- hist.plot.count + 1
}
else {
graphics::plot(1, xlim = ell.lim.iso, ylim = ell.lim.iso,
axes = FALSE, type = "n", xlab = "", ylab = "")
graphics::box(col = "grey")
for (w in 1:length(p)) {
invisible(lapply(ell.data[[w]][[ell.plot.count]][[2]],
function(x) graphics::points(x, col = colEll[w],
type = "l", lwd = ell.wd)))
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
invisible(graphics::points(ell.point[[w]][[ell.plot.count]],
col = point.color[w], type = "l", lwd = point.wd))
}
}
ell.plot.count <- ell.plot.count + 1
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
}
}
}
graphics::par(old.par)
}
else {
LL <- lapply(p, function(x) lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[x]],
function(x) x[y, ])))))
ell.data <- list()
for (w in 1:length(p)) {
ell.data[[w]] <- list()
ell.data.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.data[[w]][[ell.data.count]] <- getEllipseMatrix(mat = chain$matrix[[p[w]]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.data.count <- ell.data.count + 1
}
}
}
if (!is.null(point.matrix)) {
if (!class(point.matrix) == "list")
stop(" point.matrix need to be a list of matrices.")
if (!length(point.matrix) == length(p))
stop("Lenght of point.matrix need to be equal to the number of regimes fitted to the tree.")
if (!class(point.matrix[[1]]) == "matrix")
stop(" point.matrix need to be a list of matrices.")
ell.point <- list()
for (w in 1:length(p)) {
ell.point[[w]] <- list()
ell.point.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.point[[w]][[ell.point.count]] <- getEllipseMatrix(mat = point.matrix[[w]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.point.count <- ell.point.count + 1
}
}
}
}
y.hist <- vector()
x.hist <- vector()
for (w in 1:length(p)) {
for (i in 1:dd) {
for (j in i:dd) {
x.hist <- c(min(x.hist[1], LL[[w]][[i]][, j],
na.rm = TRUE), max(x.hist[2], LL[[w]][[i]][,
j], na.rm = TRUE))
}
}
}
if (is.null(set.xlim)) {
wd <- (x.hist[2] - mean(x.hist))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- x.hist
}
else {
wd <- (set.xlim[2] - mean(set.xlim))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- set.xlim
}
hists <- list()
for (w in 1:length(p)) {
hists[[w]] <- list()
hist.count <- 1
for (i in 1:dd) {
for (j in i:dd) {
if (i == j) {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk.var)
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
else {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk)
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
}
}
}
ylim.hist <- c(0, y.hist)
ell.lim <- lapply(do.call(c, ell.data), function(x) x[[1]])
ell.lim <- do.call(rbind, ell.lim)
ell.lim <- apply(ell.lim, 2, range)
ell.lim.iso <- c(min(ell.lim[1, ]), max(ell.lim[2, ]))
old.par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(dd[1], dd[1]))
graphics::par(cex = 0.6)
graphics::par(mar = c(0, 0, 0, 0), oma = c(2, 2, 2, 2))
graphics::par(tcl = -0.25)
graphics::par(mgp = c(2, 0.6, 0))
colOff <- grDevices::adjustcolor(col = colors, alpha.f = alphaOff)
colDiag <- grDevices::adjustcolor(col = colors, alpha.f = alphaDiag)
colEll <- grDevices::adjustcolor(col = colors, alpha.f = alphaEll)
if (is.null(point.color)) {
point.color <- colors
}
ell.plot.count <- 1
hist.plot.count <- 1
for (i in 1:dd) {
for (j in 1:dd) {
if (j >= i) {
graphics::plot(1, xlim = xlim.hist, ylim = ylim.hist,
axes = FALSE, type = "n", xlab = "", ylab = "")
mid <- mean(xlim.hist)
first.quart <- xlim.hist[1] + (mid - xlim.hist[1])/2
second.quart <- mid + (xlim.hist[2] - mid)/2
graphics::lines(x = c(mid, mid), y = ylim.hist,
type = "l", lty = 3, col = "grey")
graphics::lines(x = c(first.quart, first.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
graphics::lines(x = c(second.quart, second.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
if (show.zero == TRUE) {
graphics::lines(x = c(0, 0), y = ylim.hist,
type = "l", lty = 3, col = "blue")
}
graphics::box(col = "grey")
if (j != i) {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, col = colOff[w],
border = "gray")
}
}
else {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, col = colDiag[w],
border = "black")
}
if (i == dd) {
graphics::axis(1, at = round(c(xlim.hist[1],
mean(xlim.hist), xlim.hist[2]), digits = 2))
}
}
if (i == 1) {
graphics::mtext(text = set.leg[j], side = 3,
cex = l.cex)
}
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
graphics::lines(x = c(point.matrix[[w]][i,
j], point.matrix[[w]][i, j]), y = ylim.hist,
type = "l", col = point.color[w], lwd = point.wd)
}
}
hist.plot.count <- hist.plot.count + 1
}
else {
graphics::plot(1, xlim = ell.lim.iso, ylim = ell.lim.iso,
axes = FALSE, type = "n", xlab = "", ylab = "")
graphics::box(col = "grey")
for (w in 1:length(p)) {
invisible(lapply(ell.data[[w]][[ell.plot.count]][[2]],
function(x) graphics::points(x, col = colEll[w],
type = "l", lwd = ell.wd)))
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
invisible(graphics::points(ell.point[[w]][[ell.plot.count]],
col = point.color[w], type = "l", lwd = point.wd))
}
}
ell.plot.count <- ell.plot.count + 1
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
}
}
}
graphics::par(old.par)
}
}
<bytecode: 0x558926646980>
<environment: namespace:ratematrix>
--- function search by body ---
Function plotRatematrix in namespace ratematrix has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 186-188 (Making_prior_on_ratematrix.Rmd)
Error: processing vignette 'Making_prior_on_ratematrix.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building ‘Making_prior_on_ratematrix.Rmd’
--- re-building ‘Set_custom_starting_point.Rmd’ using knitr
--- finished re-building ‘Set_custom_starting_point.Rmd’
SUMMARY: processing the following file failed:
‘Making_prior_on_ratematrix.Rmd’
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 1.2.1
Check: installed package size
Result: NOTE
installed size is 6.0Mb
sub-directories of 1Mb or more:
libs 4.3Mb
Flavors: r-devel-linux-x86_64-fedora-clang, r-release-osx-x86_64, r-oldrel-osx-x86_64
Version: 1.2.1
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
--- re-building ‘Intro_on_the_package.Rmd’ using knitr
--- finished re-building ‘Intro_on_the_package.Rmd’
--- re-building ‘Making_prior_on_ratematrix.Rmd’ using knitr
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
ratematrix
--- call from context ---
plotRatematrix(chain = post.unif.root, set.leg = c("trait_1",
"trait_2"), point.matrix = list(R), point.color = "red",
point.wd = 1.5)
--- call from argument ---
if (!class(point.matrix[[1]]) == "matrix") stop(" point.matrix need to be a list of matrices.")
--- R stacktrace ---
where 1: plotRatematrix(chain = post.unif.root, set.leg = c("trait_1",
"trait_2"), point.matrix = list(R), point.color = "red",
point.wd = 1.5)
where 2: eval(expr, envir, enclos)
where 3: eval(expr, envir, enclos)
where 4: withVisible(eval(expr, envir, enclos))
where 5: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 6: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 7: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 8: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 9: evaluate::evaluate(...)
where 10: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 11: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 12: block_exec(params)
where 13: call_block(x)
where 14: process_group.block(group)
where 15: process_group(group)
where 16: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 17: process_file(text, output)
where 18: knit(input, text = text, envir = envir, quiet = quiet)
where 19: knit2html(..., force_v1 = TRUE)
where 20: (if (grepl("\\.[Rr]md$", file)) knit2html_v1 else if (grepl("\\.[Rr]rst$",
file)) knit2pandoc else knit)(file, encoding = encoding,
quiet = quiet, envir = globalenv(), ...)
where 21: engine$weave(file, quiet = quiet, encoding = enc)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, classes, parentenv, handlers)
where 25: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
}, error = function(e) {
OK <<- FALSE
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 26: tools:::.buildOneVignette("Making_prior_on_ratematrix.Rmd", "/data/gannet/ripley/R/packages/tests-clang/ratematrix.Rcheck/vign_test/ratematrix",
TRUE, FALSE, "Making_prior_on_ratematrix", "UTF-8", "/tmp/RtmpfjbL84/working_dir/RtmpBRxxLI/file2fe75ca68d35.rds")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (chain, p = NULL, colors = NULL, set.xlim = NULL, set.leg = NULL,
l.cex = 0.7, ell.wd = 0.5, alphaOff = 1, alphaDiag = 1, alphaEll = 1,
hpd = 100, show.zero = FALSE, n.lines = 50, n.points = 200,
point.matrix = NULL, point.color = NULL, point.wd = 0.5)
{
ll_class <- length(class(chain))
if (ll_class == 1) {
correct_class <- grepl(pattern = "ratematrix", x = class(chain))
}
else {
correct_class <- any(sapply(class(chain), function(x) grepl(pattern = "ratematrix",
x = x)))
}
if (!correct_class)
stop("chain argument need to be a single MCMC chain. See 'mergePosterior' function to merge multiple MCMC chains together.")
if (is.null(chain$n_post_samples)) {
if (n.lines > nrow(chain[[1]])) {
n.lines <- nrow(chain[[1]])
}
}
else {
if (n.lines > chain$n_post_samples) {
n.lines <- chain$n_post_samples
}
}
if (is.null(p)) {
if (is.list(chain$matrix) & is.matrix(chain$matrix[[1]][[1]])) {
np <- length(chain$matrix)
p <- 1:np
}
else {
p <- 1
}
}
if (is.null(colors)) {
np <- length(p)
if (np > 9)
stop("Unable to generate colors for more than 9 regimes. Please define color vector using 'colors' argument.")
if (np == 1) {
colors <- "black"
}
else {
check <- c(np < 4, 3 < np && np < 6, np > 5)
cols <- list(c("#002244", "#69BE28", "#A5ACAF"),
c("#7fc97f", "#beaed4", "#fdc086", "#386cb0",
"#ffff99"), c("#bc80bd", "#d9d9d9", "#fccde5",
"#b3de69", "#fdb462", "#b3de69", "#fccde5",
"#d9d9d9", "#bc80bd"))
colors <- unlist(cols[check])[1:np]
}
}
if (is.null(set.leg)) {
if (is.null(chain$trait_names)) {
set.leg <- colnames(chain$root)
}
else {
set.leg <- chain$trait_names
}
}
if (length(p) == 1) {
if (is.list(chain$matrix) & is.matrix(chain$matrix[[p]][[1]])) {
cat("Plotting a single regime.", "\n")
dd <- ncol(chain$matrix[[p]][[1]])
ll <- length(chain$matrix[[p]])
if (class(chain) == "ratematrix_prior_sample") {
corr <- lapply(chain$matrix[[p]], decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[[p]][x, ]^2))
chain$matrix[[p]] <- rb.matrix
}
}
if (is.list(chain$matrix) & is.matrix(chain$matrix[[1]])) {
if (!p == 1)
stop("There is only one regime in the chain, then p need to be equal to 1.")
cat("Plotting a single regime.", "\n")
dd <- ncol(chain$matrix[[1]])
ll <- length(chain$matrix)
if (class(chain) == "ratematrix_prior_sample") {
corr <- lapply(chain$matrix, decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[x, ]^2))
chain$matrix <- rb.matrix
}
temp <- chain$matrix
rm(chain)
chain <- list()
chain$matrix <- list()
chain$matrix[[1]] <- temp
}
}
if (length(p) > 1) {
cat("Plotting multiple regimes.", "\n")
name.table <- rbind(names(chain$matrix)[p], colors)
cat("Table with regimes and colors (names or HEX):\n")
utils::write.table(format(name.table, justify = "right"),
row.names = F, col.names = F, quote = F)
check.mat <- vector()
check.length <- vector()
for (i in 1:length(p)) {
check.mat[i] <- ncol(chain$matrix[[p[i]]][[1]])
check.length[i] <- length(chain$matrix[[p[i]]])
}
equal.size <- sapply(2:length(p), function(x) check.mat[1] ==
check.mat[x])
equal.length <- sapply(2:length(p), function(x) check.length[1] ==
check.length[x])
if (!sum(equal.size) == (length(p) - 1))
stop("Matrix regimes do not have the same number of traits.")
if (!sum(equal.length) == (length(p) - 1))
stop("Chain for regimes do not have the same length.")
ll <- check.length[1]
dd <- check.mat[1]
if (class(chain) == "ratematrix_prior_sample") {
for (i in p) {
corr <- lapply(chain$matrix[[i]], decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[[i]][x, ]^2))
chain$matrix[[i]] <- rb.matrix
}
}
}
if (hpd < 100) {
frac <- (1 - (hpd/100))/2
prob <- c(frac, 1 - frac)
LL <- lapply(p, function(x) lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[x]],
function(x) x[y, ])))))
qq.list <- list()
for (w in 1:length(LL)) {
qq.list[[w]] <- list()
qq.count <- 1
for (i in 1:dd) {
for (j in i:dd) {
qq.list[[w]][[qq.count]] <- stats::quantile(x = LL[[w]][[i]][,
j], probs = prob)
qq.count <- qq.count + 1
}
}
}
if (ll < n.lines)
stop(" n.lines is larger than number of matrices in the chain.")
if (n.lines < 1)
stop(" n.lines need to be > 1.")
ss.list <- list()
sampled.LL <- list()
for (i in 1:length(p)) {
count <- 1
ss.list[[i]] <- vector()
while (count < n.lines) {
ss <- sample(1:ll, size = 1)
if (ss %in% ss.list[[i]])
next
if (checkHPD(chain$matrix[[p[i]]][[ss]], qq.list[[i]],
dd))
next
ss.list[[i]][count] <- ss
count <- count + 1
}
sampled.LL[[i]] <- lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[p[i]]][ss.list[[i]]],
function(x) x[y, ]))))
}
ell.data <- list()
for (w in 1:length(p)) {
ell.data.count <- 1
ell.data[[w]] <- list()
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.data[[w]][[ell.data.count]] <- getEllipseMatrix(mat = chain$matrix[[p[w]]][ss.list[[w]]],
traits = c(i, j), n.points = n.points)
ell.data.count <- ell.data.count + 1
}
}
}
if (!is.null(point.matrix)) {
if (!class(point.matrix) == "list")
stop(" point.matrix need to be a list of matrices.")
if (!length(point.matrix) == length(p))
stop("Lenght of point.matrix need to be equal to the number of regimes fitted to the tree.")
if (!class(point.matrix[[1]]) == "matrix")
stop(" point.matrix need to be a list of matrices.")
ell.point <- list()
for (w in 1:length(p)) {
ell.point[[w]] <- list()
ell.point.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.point[[w]][[ell.point.count]] <- getEllipseMatrix(mat = point.matrix[[w]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.point.count <- ell.point.count + 1
}
}
}
}
y.hist <- vector()
x.hist <- vector()
for (w in 1:length(p)) {
for (i in 1:dd) {
for (j in i:dd) {
x.hist <- c(min(x.hist[1], LL[[w]][[i]][, j],
na.rm = TRUE), max(x.hist[2], LL[[w]][[i]][,
j], na.rm = TRUE))
}
}
}
if (is.null(set.xlim)) {
wd <- (x.hist[2] - mean(x.hist))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(0, to = x.hist[2] + wd, by = wd)
xlim.hist <- x.hist
}
else {
wd <- (set.xlim[2] - mean(set.xlim))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- set.xlim
}
hists <- list()
ccat <- list()
for (w in 1:length(p)) {
hists[[w]] <- list()
ccat[[w]] <- list()
hist.count <- 1
for (i in 1:dd[1]) {
for (j in i:dd[1]) {
if (i == j) {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk.var)
ccat[[w]][[hist.count]] <- cut(hists[[w]][[hist.count]]$breaks,
c(-Inf, qq.list[[w]][[hist.count]][1],
qq.list[[w]][[hist.count]][2], Inf))
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
else {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk)
ccat[[w]][[hist.count]] <- cut(hists[[w]][[hist.count]]$breaks,
c(-Inf, qq.list[[w]][[hist.count]][1],
qq.list[[w]][[hist.count]][2], Inf))
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
}
}
}
ylim.hist <- c(0, y.hist)
ell.lim <- lapply(do.call(c, ell.data), function(x) x[[1]])
ell.lim <- do.call(rbind, ell.lim)
ell.lim <- apply(ell.lim, 2, range)
ell.lim.iso <- c(min(ell.lim[1, ]), max(ell.lim[2, ]))
old.par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(dd, dd))
graphics::par(cex = 0.6)
graphics::par(mar = c(0, 0, 0, 0), oma = c(2, 2, 2, 2))
graphics::par(tcl = -0.25)
graphics::par(mgp = c(2, 0.6, 0))
colOff <- grDevices::adjustcolor(col = colors, alpha.f = alphaOff)
colDiag <- grDevices::adjustcolor(col = colors, alpha.f = alphaDiag)
colEll <- grDevices::adjustcolor(col = colors, alpha.f = alphaEll)
if (is.null(point.color)) {
point.color <- colors
}
ell.plot.count <- 1
hist.plot.count <- 1
for (i in 1:dd) {
for (j in 1:dd) {
if (j >= i) {
graphics::plot(1, xlim = xlim.hist, ylim = ylim.hist,
axes = FALSE, type = "n", xlab = "", ylab = "")
mid <- mean(xlim.hist)
first.quart <- xlim.hist[1] + (mid - xlim.hist[1])/2
second.quart <- mid + (xlim.hist[2] - mid)/2
graphics::lines(x = c(mid, mid), y = ylim.hist,
type = "l", lty = 3, col = "grey")
graphics::lines(x = c(first.quart, first.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
graphics::lines(x = c(second.quart, second.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
if (show.zero == TRUE) {
graphics::lines(x = c(0, 0), y = ylim.hist,
type = "l", lty = 3, col = "blue")
}
graphics::box(col = "grey")
if (j != i) {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, border = "gray",
col = c("white", colOff[w], "white")[ccat[[w]][[hist.plot.count]]])
}
}
else {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, border = "black",
col = c("white", colDiag[w], "white")[ccat[[w]][[hist.plot.count]]])
}
if (i == dd[1]) {
graphics::axis(1, at = round(c(xlim.hist[1],
mean(xlim.hist), xlim.hist[2]), digits = 2))
}
}
if (i == 1) {
graphics::mtext(text = set.leg[j], side = 3,
cex = l.cex)
}
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
graphics::lines(x = c(point.matrix[[w]][i,
j], point.matrix[[w]][i, j]), y = ylim.hist,
type = "l", col = point.color[w], lwd = point.wd)
}
}
hist.plot.count <- hist.plot.count + 1
}
else {
graphics::plot(1, xlim = ell.lim.iso, ylim = ell.lim.iso,
axes = FALSE, type = "n", xlab = "", ylab = "")
graphics::box(col = "grey")
for (w in 1:length(p)) {
invisible(lapply(ell.data[[w]][[ell.plot.count]][[2]],
function(x) graphics::points(x, col = colEll[w],
type = "l", lwd = ell.wd)))
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
invisible(graphics::points(ell.point[[w]][[ell.plot.count]],
col = point.color[w], type = "l", lwd = point.wd))
}
}
ell.plot.count <- ell.plot.count + 1
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
}
}
}
graphics::par(old.par)
}
else {
LL <- lapply(p, function(x) lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[x]],
function(x) x[y, ])))))
ell.data <- list()
for (w in 1:length(p)) {
ell.data[[w]] <- list()
ell.data.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.data[[w]][[ell.data.count]] <- getEllipseMatrix(mat = chain$matrix[[p[w]]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.data.count <- ell.data.count + 1
}
}
}
if (!is.null(point.matrix)) {
if (!class(point.matrix) == "list")
stop(" point.matrix need to be a list of matrices.")
if (!length(point.matrix) == length(p))
stop("Lenght of point.matrix need to be equal to the number of regimes fitted to the tree.")
if (!class(point.matrix[[1]]) == "matrix")
stop(" point.matrix need to be a list of matrices.")
ell.point <- list()
for (w in 1:length(p)) {
ell.point[[w]] <- list()
ell.point.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.point[[w]][[ell.point.count]] <- getEllipseMatrix(mat = point.matrix[[w]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.point.count <- ell.point.count + 1
}
}
}
}
y.hist <- vector()
x.hist <- vector()
for (w in 1:length(p)) {
for (i in 1:dd) {
for (j in i:dd) {
x.hist <- c(min(x.hist[1], LL[[w]][[i]][, j],
na.rm = TRUE), max(x.hist[2], LL[[w]][[i]][,
j], na.rm = TRUE))
}
}
}
if (is.null(set.xlim)) {
wd <- (x.hist[2] - mean(x.hist))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- x.hist
}
else {
wd <- (set.xlim[2] - mean(set.xlim))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- set.xlim
}
hists <- list()
for (w in 1:length(p)) {
hists[[w]] <- list()
hist.count <- 1
for (i in 1:dd) {
for (j in i:dd) {
if (i == j) {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk.var)
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
else {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk)
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
}
}
}
ylim.hist <- c(0, y.hist)
ell.lim <- lapply(do.call(c, ell.data), function(x) x[[1]])
ell.lim <- do.call(rbind, ell.lim)
ell.lim <- apply(ell.lim, 2, range)
ell.lim.iso <- c(min(ell.lim[1, ]), max(ell.lim[2, ]))
old.par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(dd[1], dd[1]))
graphics::par(cex = 0.6)
graphics::par(mar = c(0, 0, 0, 0), oma = c(2, 2, 2, 2))
graphics::par(tcl = -0.25)
graphics::par(mgp = c(2, 0.6, 0))
colOff <- grDevices::adjustcolor(col = colors, alpha.f = alphaOff)
colDiag <- grDevices::adjustcolor(col = colors, alpha.f = alphaDiag)
colEll <- grDevices::adjustcolor(col = colors, alpha.f = alphaEll)
if (is.null(point.color)) {
point.color <- colors
}
ell.plot.count <- 1
hist.plot.count <- 1
for (i in 1:dd) {
for (j in 1:dd) {
if (j >= i) {
graphics::plot(1, xlim = xlim.hist, ylim = ylim.hist,
axes = FALSE, type = "n", xlab = "", ylab = "")
mid <- mean(xlim.hist)
first.quart <- xlim.hist[1] + (mid - xlim.hist[1])/2
second.quart <- mid + (xlim.hist[2] - mid)/2
graphics::lines(x = c(mid, mid), y = ylim.hist,
type = "l", lty = 3, col = "grey")
graphics::lines(x = c(first.quart, first.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
graphics::lines(x = c(second.quart, second.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
if (show.zero == TRUE) {
graphics::lines(x = c(0, 0), y = ylim.hist,
type = "l", lty = 3, col = "blue")
}
graphics::box(col = "grey")
if (j != i) {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, col = colOff[w],
border = "gray")
}
}
else {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, col = colDiag[w],
border = "black")
}
if (i == dd) {
graphics::axis(1, at = round(c(xlim.hist[1],
mean(xlim.hist), xlim.hist[2]), digits = 2))
}
}
if (i == 1) {
graphics::mtext(text = set.leg[j], side = 3,
cex = l.cex)
}
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
graphics::lines(x = c(point.matrix[[w]][i,
j], point.matrix[[w]][i, j]), y = ylim.hist,
type = "l", col = point.color[w], lwd = point.wd)
}
}
hist.plot.count <- hist.plot.count + 1
}
else {
graphics::plot(1, xlim = ell.lim.iso, ylim = ell.lim.iso,
axes = FALSE, type = "n", xlab = "", ylab = "")
graphics::box(col = "grey")
for (w in 1:length(p)) {
invisible(lapply(ell.data[[w]][[ell.plot.count]][[2]],
function(x) graphics::points(x, col = colEll[w],
type = "l", lwd = ell.wd)))
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
invisible(graphics::points(ell.point[[w]][[ell.plot.count]],
col = point.color[w], type = "l", lwd = point.wd))
}
}
ell.plot.count <- ell.plot.count + 1
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
}
}
}
graphics::par(old.par)
}
}
<bytecode: 0xfa14700>
<environment: namespace:ratematrix>
--- function search by body ---
Function plotRatematrix in namespace ratematrix has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 186-188 (Making_prior_on_ratematrix.Rmd)
Error: processing vignette 'Making_prior_on_ratematrix.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building ‘Making_prior_on_ratematrix.Rmd’
--- re-building ‘Set_custom_starting_point.Rmd’ using knitr
--- finished re-building ‘Set_custom_starting_point.Rmd’
SUMMARY: processing the following file failed:
‘Making_prior_on_ratematrix.Rmd’
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 1.2.1
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
--- re-building ‘Intro_on_the_package.Rmd’ using knitr
--- finished re-building ‘Intro_on_the_package.Rmd’
--- re-building ‘Making_prior_on_ratematrix.Rmd’ using knitr
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
ratematrix
--- call from context ---
plotRatematrix(chain = post.unif.root, set.leg = c("trait_1",
"trait_2"), point.matrix = list(R), point.color = "red",
point.wd = 1.5)
--- call from argument ---
if (!class(point.matrix[[1]]) == "matrix") stop(" point.matrix need to be a list of matrices.")
--- R stacktrace ---
where 1: plotRatematrix(chain = post.unif.root, set.leg = c("trait_1",
"trait_2"), point.matrix = list(R), point.color = "red",
point.wd = 1.5)
where 2: eval(expr, envir, enclos)
where 3: eval(expr, envir, enclos)
where 4: withVisible(eval(expr, envir, enclos))
where 5: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 6: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 7: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 8: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
debug = debug, last = i == length(out), use_try = stop_on_error !=
2L, keep_warning = keep_warning, keep_message = keep_message,
output_handler = output_handler, include_timing = include_timing)
where 9: evaluate::evaluate(...)
where 10: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
options$include) 0L else 2L, output_handler = knit_handlers(options$render,
options))
where 11: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
stop_on_error = if (options$error && options$include) 0L else 2L,
output_handler = knit_handlers(options$render, options)))
where 12: block_exec(params)
where 13: call_block(x)
where 14: process_group.block(group)
where 15: process_group(group)
where 16: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
error = function(e) {
setwd(wd)
cat(res, sep = "\n", file = output %n% "")
message("Quitting from lines ", paste(current_lines(i),
collapse = "-"), " (", knit_concord$get("infile"),
") ")
})
where 17: process_file(text, output)
where 18: knit(input, text = text, envir = envir, quiet = quiet)
where 19: knit2html(..., force_v1 = TRUE)
where 20: (if (grepl("\\.[Rr]md$", file)) knit2html_v1 else if (grepl("\\.[Rr]rst$",
file)) knit2pandoc else knit)(file, encoding = encoding,
quiet = quiet, envir = globalenv(), ...)
where 21: engine$weave(file, quiet = quiet, encoding = enc)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, classes, parentenv, handlers)
where 25: tryCatch({
engine$weave(file, quiet = quiet, encoding = enc)
setwd(startdir)
output <- find_vignette_product(name, by = "weave", engine = engine)
if (!have.makefile && vignette_is_tex(output)) {
texi2pdf(file = output, clean = FALSE, quiet = quiet)
output <- find_vignette_product(name, by = "texi2pdf",
engine = engine)
}
}, error = function(e) {
OK <<- FALSE
message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
file, conditionMessage(e)))
})
where 26: tools:::.buildOneVignette("Making_prior_on_ratematrix.Rmd", "/data/gannet/ripley/R/packages/tests-devel/ratematrix.Rcheck/vign_test/ratematrix",
TRUE, FALSE, "Making_prior_on_ratematrix", "UTF-8", "/tmp/RtmpyooDNg/working_dir/Rtmp8n9Edj/file23e6b226802.rds")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (chain, p = NULL, colors = NULL, set.xlim = NULL, set.leg = NULL,
l.cex = 0.7, ell.wd = 0.5, alphaOff = 1, alphaDiag = 1, alphaEll = 1,
hpd = 100, show.zero = FALSE, n.lines = 50, n.points = 200,
point.matrix = NULL, point.color = NULL, point.wd = 0.5)
{
ll_class <- length(class(chain))
if (ll_class == 1) {
correct_class <- grepl(pattern = "ratematrix", x = class(chain))
}
else {
correct_class <- any(sapply(class(chain), function(x) grepl(pattern = "ratematrix",
x = x)))
}
if (!correct_class)
stop("chain argument need to be a single MCMC chain. See 'mergePosterior' function to merge multiple MCMC chains together.")
if (is.null(chain$n_post_samples)) {
if (n.lines > nrow(chain[[1]])) {
n.lines <- nrow(chain[[1]])
}
}
else {
if (n.lines > chain$n_post_samples) {
n.lines <- chain$n_post_samples
}
}
if (is.null(p)) {
if (is.list(chain$matrix) & is.matrix(chain$matrix[[1]][[1]])) {
np <- length(chain$matrix)
p <- 1:np
}
else {
p <- 1
}
}
if (is.null(colors)) {
np <- length(p)
if (np > 9)
stop("Unable to generate colors for more than 9 regimes. Please define color vector using 'colors' argument.")
if (np == 1) {
colors <- "black"
}
else {
check <- c(np < 4, 3 < np && np < 6, np > 5)
cols <- list(c("#002244", "#69BE28", "#A5ACAF"),
c("#7fc97f", "#beaed4", "#fdc086", "#386cb0",
"#ffff99"), c("#bc80bd", "#d9d9d9", "#fccde5",
"#b3de69", "#fdb462", "#b3de69", "#fccde5",
"#d9d9d9", "#bc80bd"))
colors <- unlist(cols[check])[1:np]
}
}
if (is.null(set.leg)) {
if (is.null(chain$trait_names)) {
set.leg <- colnames(chain$root)
}
else {
set.leg <- chain$trait_names
}
}
if (length(p) == 1) {
if (is.list(chain$matrix) & is.matrix(chain$matrix[[p]][[1]])) {
cat("Plotting a single regime.", "\n")
dd <- ncol(chain$matrix[[p]][[1]])
ll <- length(chain$matrix[[p]])
if (class(chain) == "ratematrix_prior_sample") {
corr <- lapply(chain$matrix[[p]], decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[[p]][x, ]^2))
chain$matrix[[p]] <- rb.matrix
}
}
if (is.list(chain$matrix) & is.matrix(chain$matrix[[1]])) {
if (!p == 1)
stop("There is only one regime in the chain, then p need to be equal to 1.")
cat("Plotting a single regime.", "\n")
dd <- ncol(chain$matrix[[1]])
ll <- length(chain$matrix)
if (class(chain) == "ratematrix_prior_sample") {
corr <- lapply(chain$matrix, decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[x, ]^2))
chain$matrix <- rb.matrix
}
temp <- chain$matrix
rm(chain)
chain <- list()
chain$matrix <- list()
chain$matrix[[1]] <- temp
}
}
if (length(p) > 1) {
cat("Plotting multiple regimes.", "\n")
name.table <- rbind(names(chain$matrix)[p], colors)
cat("Table with regimes and colors (names or HEX):\n")
utils::write.table(format(name.table, justify = "right"),
row.names = F, col.names = F, quote = F)
check.mat <- vector()
check.length <- vector()
for (i in 1:length(p)) {
check.mat[i] <- ncol(chain$matrix[[p[i]]][[1]])
check.length[i] <- length(chain$matrix[[p[i]]])
}
equal.size <- sapply(2:length(p), function(x) check.mat[1] ==
check.mat[x])
equal.length <- sapply(2:length(p), function(x) check.length[1] ==
check.length[x])
if (!sum(equal.size) == (length(p) - 1))
stop("Matrix regimes do not have the same number of traits.")
if (!sum(equal.length) == (length(p) - 1))
stop("Chain for regimes do not have the same length.")
ll <- check.length[1]
dd <- check.mat[1]
if (class(chain) == "ratematrix_prior_sample") {
for (i in p) {
corr <- lapply(chain$matrix[[i]], decompose.cov)
rb.matrix <- lapply(1:ll, function(x) rebuild.cov(r = corr[[x]]$r,
v = chain$sd[[i]][x, ]^2))
chain$matrix[[i]] <- rb.matrix
}
}
}
if (hpd < 100) {
frac <- (1 - (hpd/100))/2
prob <- c(frac, 1 - frac)
LL <- lapply(p, function(x) lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[x]],
function(x) x[y, ])))))
qq.list <- list()
for (w in 1:length(LL)) {
qq.list[[w]] <- list()
qq.count <- 1
for (i in 1:dd) {
for (j in i:dd) {
qq.list[[w]][[qq.count]] <- stats::quantile(x = LL[[w]][[i]][,
j], probs = prob)
qq.count <- qq.count + 1
}
}
}
if (ll < n.lines)
stop(" n.lines is larger than number of matrices in the chain.")
if (n.lines < 1)
stop(" n.lines need to be > 1.")
ss.list <- list()
sampled.LL <- list()
for (i in 1:length(p)) {
count <- 1
ss.list[[i]] <- vector()
while (count < n.lines) {
ss <- sample(1:ll, size = 1)
if (ss %in% ss.list[[i]])
next
if (checkHPD(chain$matrix[[p[i]]][[ss]], qq.list[[i]],
dd))
next
ss.list[[i]][count] <- ss
count <- count + 1
}
sampled.LL[[i]] <- lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[p[i]]][ss.list[[i]]],
function(x) x[y, ]))))
}
ell.data <- list()
for (w in 1:length(p)) {
ell.data.count <- 1
ell.data[[w]] <- list()
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.data[[w]][[ell.data.count]] <- getEllipseMatrix(mat = chain$matrix[[p[w]]][ss.list[[w]]],
traits = c(i, j), n.points = n.points)
ell.data.count <- ell.data.count + 1
}
}
}
if (!is.null(point.matrix)) {
if (!class(point.matrix) == "list")
stop(" point.matrix need to be a list of matrices.")
if (!length(point.matrix) == length(p))
stop("Lenght of point.matrix need to be equal to the number of regimes fitted to the tree.")
if (!class(point.matrix[[1]]) == "matrix")
stop(" point.matrix need to be a list of matrices.")
ell.point <- list()
for (w in 1:length(p)) {
ell.point[[w]] <- list()
ell.point.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.point[[w]][[ell.point.count]] <- getEllipseMatrix(mat = point.matrix[[w]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.point.count <- ell.point.count + 1
}
}
}
}
y.hist <- vector()
x.hist <- vector()
for (w in 1:length(p)) {
for (i in 1:dd) {
for (j in i:dd) {
x.hist <- c(min(x.hist[1], LL[[w]][[i]][, j],
na.rm = TRUE), max(x.hist[2], LL[[w]][[i]][,
j], na.rm = TRUE))
}
}
}
if (is.null(set.xlim)) {
wd <- (x.hist[2] - mean(x.hist))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(0, to = x.hist[2] + wd, by = wd)
xlim.hist <- x.hist
}
else {
wd <- (set.xlim[2] - mean(set.xlim))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- set.xlim
}
hists <- list()
ccat <- list()
for (w in 1:length(p)) {
hists[[w]] <- list()
ccat[[w]] <- list()
hist.count <- 1
for (i in 1:dd[1]) {
for (j in i:dd[1]) {
if (i == j) {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk.var)
ccat[[w]][[hist.count]] <- cut(hists[[w]][[hist.count]]$breaks,
c(-Inf, qq.list[[w]][[hist.count]][1],
qq.list[[w]][[hist.count]][2], Inf))
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
else {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk)
ccat[[w]][[hist.count]] <- cut(hists[[w]][[hist.count]]$breaks,
c(-Inf, qq.list[[w]][[hist.count]][1],
qq.list[[w]][[hist.count]][2], Inf))
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
}
}
}
ylim.hist <- c(0, y.hist)
ell.lim <- lapply(do.call(c, ell.data), function(x) x[[1]])
ell.lim <- do.call(rbind, ell.lim)
ell.lim <- apply(ell.lim, 2, range)
ell.lim.iso <- c(min(ell.lim[1, ]), max(ell.lim[2, ]))
old.par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(dd, dd))
graphics::par(cex = 0.6)
graphics::par(mar = c(0, 0, 0, 0), oma = c(2, 2, 2, 2))
graphics::par(tcl = -0.25)
graphics::par(mgp = c(2, 0.6, 0))
colOff <- grDevices::adjustcolor(col = colors, alpha.f = alphaOff)
colDiag <- grDevices::adjustcolor(col = colors, alpha.f = alphaDiag)
colEll <- grDevices::adjustcolor(col = colors, alpha.f = alphaEll)
if (is.null(point.color)) {
point.color <- colors
}
ell.plot.count <- 1
hist.plot.count <- 1
for (i in 1:dd) {
for (j in 1:dd) {
if (j >= i) {
graphics::plot(1, xlim = xlim.hist, ylim = ylim.hist,
axes = FALSE, type = "n", xlab = "", ylab = "")
mid <- mean(xlim.hist)
first.quart <- xlim.hist[1] + (mid - xlim.hist[1])/2
second.quart <- mid + (xlim.hist[2] - mid)/2
graphics::lines(x = c(mid, mid), y = ylim.hist,
type = "l", lty = 3, col = "grey")
graphics::lines(x = c(first.quart, first.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
graphics::lines(x = c(second.quart, second.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
if (show.zero == TRUE) {
graphics::lines(x = c(0, 0), y = ylim.hist,
type = "l", lty = 3, col = "blue")
}
graphics::box(col = "grey")
if (j != i) {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, border = "gray",
col = c("white", colOff[w], "white")[ccat[[w]][[hist.plot.count]]])
}
}
else {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, border = "black",
col = c("white", colDiag[w], "white")[ccat[[w]][[hist.plot.count]]])
}
if (i == dd[1]) {
graphics::axis(1, at = round(c(xlim.hist[1],
mean(xlim.hist), xlim.hist[2]), digits = 2))
}
}
if (i == 1) {
graphics::mtext(text = set.leg[j], side = 3,
cex = l.cex)
}
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
graphics::lines(x = c(point.matrix[[w]][i,
j], point.matrix[[w]][i, j]), y = ylim.hist,
type = "l", col = point.color[w], lwd = point.wd)
}
}
hist.plot.count <- hist.plot.count + 1
}
else {
graphics::plot(1, xlim = ell.lim.iso, ylim = ell.lim.iso,
axes = FALSE, type = "n", xlab = "", ylab = "")
graphics::box(col = "grey")
for (w in 1:length(p)) {
invisible(lapply(ell.data[[w]][[ell.plot.count]][[2]],
function(x) graphics::points(x, col = colEll[w],
type = "l", lwd = ell.wd)))
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
invisible(graphics::points(ell.point[[w]][[ell.plot.count]],
col = point.color[w], type = "l", lwd = point.wd))
}
}
ell.plot.count <- ell.plot.count + 1
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
}
}
}
graphics::par(old.par)
}
else {
LL <- lapply(p, function(x) lapply(1:dd, function(y) data.frame(t(sapply(chain$matrix[[x]],
function(x) x[y, ])))))
ell.data <- list()
for (w in 1:length(p)) {
ell.data[[w]] <- list()
ell.data.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.data[[w]][[ell.data.count]] <- getEllipseMatrix(mat = chain$matrix[[p[w]]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.data.count <- ell.data.count + 1
}
}
}
if (!is.null(point.matrix)) {
if (!class(point.matrix) == "list")
stop(" point.matrix need to be a list of matrices.")
if (!length(point.matrix) == length(p))
stop("Lenght of point.matrix need to be equal to the number of regimes fitted to the tree.")
if (!class(point.matrix[[1]]) == "matrix")
stop(" point.matrix need to be a list of matrices.")
ell.point <- list()
for (w in 1:length(p)) {
ell.point[[w]] <- list()
ell.point.count <- 1
for (j in 2:dd) {
for (i in 1:(j - 1)) {
ell.point[[w]][[ell.point.count]] <- getEllipseMatrix(mat = point.matrix[[w]],
traits = c(i, j), sample.line = n.lines,
n.points = n.points)
ell.point.count <- ell.point.count + 1
}
}
}
}
y.hist <- vector()
x.hist <- vector()
for (w in 1:length(p)) {
for (i in 1:dd) {
for (j in i:dd) {
x.hist <- c(min(x.hist[1], LL[[w]][[i]][, j],
na.rm = TRUE), max(x.hist[2], LL[[w]][[i]][,
j], na.rm = TRUE))
}
}
}
if (is.null(set.xlim)) {
wd <- (x.hist[2] - mean(x.hist))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- x.hist
}
else {
wd <- (set.xlim[2] - mean(set.xlim))/20
brk <- seq(from = x.hist[1] - wd, to = x.hist[2] +
wd, by = wd)
brk.var <- seq(from = 0, to = x.hist[2] + wd, by = wd)
xlim.hist <- set.xlim
}
hists <- list()
for (w in 1:length(p)) {
hists[[w]] <- list()
hist.count <- 1
for (i in 1:dd) {
for (j in i:dd) {
if (i == j) {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk.var)
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
else {
hists[[w]][[hist.count]] <- graphics::hist(LL[[w]][[i]][,
j], plot = FALSE, breaks = brk)
y.hist <- max(y.hist, hists[[w]][[hist.count]]$density)
hist.count <- hist.count + 1
}
}
}
}
ylim.hist <- c(0, y.hist)
ell.lim <- lapply(do.call(c, ell.data), function(x) x[[1]])
ell.lim <- do.call(rbind, ell.lim)
ell.lim <- apply(ell.lim, 2, range)
ell.lim.iso <- c(min(ell.lim[1, ]), max(ell.lim[2, ]))
old.par <- graphics::par(no.readonly = TRUE)
graphics::par(mfrow = c(dd[1], dd[1]))
graphics::par(cex = 0.6)
graphics::par(mar = c(0, 0, 0, 0), oma = c(2, 2, 2, 2))
graphics::par(tcl = -0.25)
graphics::par(mgp = c(2, 0.6, 0))
colOff <- grDevices::adjustcolor(col = colors, alpha.f = alphaOff)
colDiag <- grDevices::adjustcolor(col = colors, alpha.f = alphaDiag)
colEll <- grDevices::adjustcolor(col = colors, alpha.f = alphaEll)
if (is.null(point.color)) {
point.color <- colors
}
ell.plot.count <- 1
hist.plot.count <- 1
for (i in 1:dd) {
for (j in 1:dd) {
if (j >= i) {
graphics::plot(1, xlim = xlim.hist, ylim = ylim.hist,
axes = FALSE, type = "n", xlab = "", ylab = "")
mid <- mean(xlim.hist)
first.quart <- xlim.hist[1] + (mid - xlim.hist[1])/2
second.quart <- mid + (xlim.hist[2] - mid)/2
graphics::lines(x = c(mid, mid), y = ylim.hist,
type = "l", lty = 3, col = "grey")
graphics::lines(x = c(first.quart, first.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
graphics::lines(x = c(second.quart, second.quart),
y = ylim.hist, type = "l", lty = 3, col = "grey")
if (show.zero == TRUE) {
graphics::lines(x = c(0, 0), y = ylim.hist,
type = "l", lty = 3, col = "blue")
}
graphics::box(col = "grey")
if (j != i) {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, col = colOff[w],
border = "gray")
}
}
else {
for (w in 1:length(p)) {
graphics::plot(hists[[w]][[hist.plot.count]],
add = TRUE, freq = FALSE, col = colDiag[w],
border = "black")
}
if (i == dd) {
graphics::axis(1, at = round(c(xlim.hist[1],
mean(xlim.hist), xlim.hist[2]), digits = 2))
}
}
if (i == 1) {
graphics::mtext(text = set.leg[j], side = 3,
cex = l.cex)
}
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
graphics::lines(x = c(point.matrix[[w]][i,
j], point.matrix[[w]][i, j]), y = ylim.hist,
type = "l", col = point.color[w], lwd = point.wd)
}
}
hist.plot.count <- hist.plot.count + 1
}
else {
graphics::plot(1, xlim = ell.lim.iso, ylim = ell.lim.iso,
axes = FALSE, type = "n", xlab = "", ylab = "")
graphics::box(col = "grey")
for (w in 1:length(p)) {
invisible(lapply(ell.data[[w]][[ell.plot.count]][[2]],
function(x) graphics::points(x, col = colEll[w],
type = "l", lwd = ell.wd)))
}
if (!is.null(point.matrix)) {
for (w in 1:length(p)) {
invisible(graphics::points(ell.point[[w]][[ell.plot.count]],
col = point.color[w], type = "l", lwd = point.wd))
}
}
ell.plot.count <- ell.plot.count + 1
if (j == 1) {
graphics::mtext(text = set.leg[i], side = 2,
cex = l.cex)
}
}
}
}
graphics::par(old.par)
}
}
<bytecode: 0xdcd43b0>
<environment: namespace:ratematrix>
--- function search by body ---
Function plotRatematrix in namespace ratematrix has this body.
----------- END OF FAILURE REPORT --------------
Quitting from lines 186-188 (Making_prior_on_ratematrix.Rmd)
Error: processing vignette 'Making_prior_on_ratematrix.Rmd' failed with diagnostics:
the condition has length > 1
--- failed re-building ‘Making_prior_on_ratematrix.Rmd’
--- re-building ‘Set_custom_starting_point.Rmd’ using knitr
--- finished re-building ‘Set_custom_starting_point.Rmd’
SUMMARY: processing the following file failed:
‘Making_prior_on_ratematrix.Rmd’
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc