R/forest-internal.R
In guido-s/meta: General Package for Meta-Analysis
Defines functions
show_subgroup_results
gh
repl
notallNA
selmat
ordermat
collapsemat
wcalc
twolines
tgl
tg
removeNULL
formatcol
draw.lines
draw.forest
draw.ci
draw.ci.predict
draw.ci.diamond
draw.axis
add.rob
add.xlab
add.text
add.label
##
##
## Definition of auxiliary functions for forest plots
##
##
add.label <- function(x, column,
xpos, ypos, just, fs.lr, ff.lr, col,
fontfamily,
...) {
##
pushViewport(viewport(layout.pos.col = column, ...))
##
grid.text(x, x = xpos, y = ypos, just = just,
gp = gpar(fontsize = fs.lr, fontface = ff.lr, col = col,
fontfamily = fontfamily))
##
popViewport()
##
invisible(NULL)
}
add.text <- function(x, column, ...) {
##
for (i in seq_len(length(x$rows))) {
if (!is.na(x$rows[i])) {
pushViewport(
viewport(
layout.pos.row = x$rows[i],
layout.pos.col = column, ...))
#
grid.draw(x$labels[[i]])
#
popViewport()
}
}
##
invisible(NULL)
}
add.xlab <- function(x, column, xlab, xlab.add, newline.xlab,
xpos, ypos, fs.xlab, ff.xlab,
fontfamily) {
##
pushViewport(viewport(layout.pos.col = column, xscale = x$range))
##
## Label on x-axis:
##
grid.text(xlab,
x = unit(xpos, "native"),
y = unit(ypos, "lines"),
just = "center",
gp = gpar(fontsize = fs.xlab, fontface = ff.xlab,
fontfamily = fontfamily))
##
if (newline.xlab)
grid.text(xlab.add,
x = unit(xpos, "native"),
y = unit(ypos - 1, "lines"),
just = "center",
gp = gpar(fontsize = fs.xlab, fontface = ff.xlab,
fontfamily = fontfamily))
##
popViewport()
##
invisible(NULL)
}
add.rob <- function(x, column, size, fs, ff, fontfamily,
rob, rob.levels, rob.symbols, rob.colour, ...) {
##
if (is.null(rob.levels)) {
if (is.factor(rob))
rob.levels <- levels(rob)
else
rob.levels <- unique(rob)
}
##
n.levs <- length(rob.levels)
##
if (is.null(rob.symbols)) {
if (n.levs == 3)
rob.symbols <- c("-", "?", "+")
else
rob.symbols <- rev(seq_len(n.levs))
}
else if (length(rob.symbols) == 1 && is.logical(rob.symbols)) {
if (rob.symbols) {
if (n.levs == 3)
rob.symbols <- c("-", "?", "+")
else
rob.symbols <- rev(seq_len(n.levs))
}
}
else if (length(rob.symbols) != n.levs)
stop("Wrong number of RoB symbols (argument 'rob.symbols').",
call. = FALSE)
##
if (is.null(rob.colour)) {
if (n.levs == 3)
rob.colour <- c("red", "yellow", "green")
else
rob.colour <- rev(seq_len(n.levs))
}
##
if (!(length(rob.symbols) == 1 && is.logical(rob.symbols) && !rob.symbols))
txt.rob <-
as.character(
factor(rob, levels = rob.levels, labels = rob.symbols))
else
txt.rob <- NULL
##
col.rob <-
as.character(
factor(rob, levels = rob.levels,
labels = rob.colour))
##
j <- 0
##
for (i in seq_len(length(x$rows))) {
if (!is.na(x$rows[i])) {
pushViewport(
viewport(
layout.pos.row = x$rows[i],
layout.pos.col = column, ...))
##
if (i == 1)
grid.draw(x$labels[[1]])
else {
j <- j + 1
##
grid.circle(x = unit(0.5, "npc"), y = unit(0.5, "npc"),
r = unit(size / 2, "snpc"),
gp = gpar(fill = col.rob[j], col = col.rob[j]))
##
if (!is.null(txt.rob) && !is.na(txt.rob[j]))
grid.text(txt.rob[j],
x = unit(0.5, "npc"),
y = unit(if (txt.rob[j] %in% c("-", "+")) 0.58 else 0.5,
"npc"),
gp = gpar(fontsize = fs, fontface = ff,
fontfamily = fontfamily),
just = c("center", "center"))
}
##
popViewport()
}
}
##
invisible(NULL)
}
draw.axis <- function(x, column, yS, log.xaxis, at, label,
fs.axis, ff.axis, fontfamily, lwd,
xlim, notmiss.xlim,
col.line, col.label) {
##
## Function to draw x-axis
##
pushViewport(
viewport(
layout.pos.row = max(yS, na.rm = TRUE),
layout.pos.col = column,
xscale = x$range))
##
## x-axis:
##
if (log.xaxis) {
if (is.null(at)) {
x1000 <- c(0.001, 0.1, 1, 10, 1000)
x100 <- c(0.01 , 0.1, 1, 10, 100)
x10 <- c(0.1 , 0.5, 1, 2, 10)
x5 <- c(0.2 , 0.5, 1, 2, 5)
x2 <- c(0.5 , 1, 2)
x1.5 <- c(0.75 , 1, 1.5)
x1.25 <- c(0.8 , 1, 1.25)
x1 <- c(0.9 , 1, 1.1)
##
min.x <- min(exp(x$range[1]), 1)
max.x <- max(exp(x$range[2]), 1)
##
if (all(x1000 >= min.x) &
all(x1000 <= max.x))
label <- x1000
else if (all(x100 >= min.x) &
all(x100 <= max.x))
label <- x100
else if (all(x10 >= min.x) &
all(x10 <= max.x))
label <- x10
else if (all(x5 >= min.x) &
all(x5 <= max.x))
label <- x5
else if (all(x2 >= min.x) &
all(x2 <= max.x))
label <- x2
else if (all(x1.5 >= min.x) &
all(x1.5 <= max.x))
label <- x1.5
else if (all(x1.25 >= min.x) &
all(x1.25 <= max.x))
label <- x1.25
else if (all(x1 >= min.x) &
all(x1 <= max.x))
label <- x1
else
label <- 1
##
if (notmiss.xlim && is.numeric(xlim[1])) {
if (exp(min(xlim)) < min(label))
label <- c(exp(min(xlim)), label)
if (exp(max(xlim)) > max(label))
label <- c(label, exp(max(xlim)))
}
at <- log(label)
}
else {
if (length(label) == 1 && is.logical(label) && label)
label <- at
at <- log(at)
}
## Print x-axis labels
grid.xaxis(name = "xaxis1",
at = at, label = label,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.label, tcl = -0.1))
## Print xaxis and tick marks (in different colour)
grid.xaxis(name = "xaxis2",
at = at, label = FALSE,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.line, tcl = -0.1))
}
else {
if (is.null(at)) {
## Print x-axis labels
grid.xaxis(name = "xaxis1",
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.label, tcl = -0.1))
## Print xaxis and tick marks (in different colour)
grid.xaxis(name = "xaxis2",
label = FALSE,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.line, tcl = -0.1))
}
else if ((length(label) == 1 && is.logical(label) && label) |
(length(label) >= 1 & !is.logical(label))) {
## Print x-axis labels
grid.xaxis(name = "xaxis1",
at = at, label = label,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.label, tcl = -0.1))
## Print xaxis and tick marks (in different colour)
grid.xaxis(name = "xaxis2",
at = at, label = FALSE,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.line, tcl = -0.1))
}
else {
## Print x-axis labels
grid.xaxis(name = "xaxis1",
at = at,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.label, tcl = -0.1))
## Print xaxis and tick marks (in different colour)
grid.xaxis(name = "xaxis2",
at = at, label = FALSE,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.line, tcl = -0.1))
}
}
##
popViewport()
##
invisible(NULL)
}
draw.ci.diamond <- function(TE, lower, upper,
size, min, max,
col.diamond, col.diamond.lines,
lwd) {
##
if (min > max) {
tmp <- min
min <- max
max <- tmp
}
##
if (!is.na(TE) &&
((min <= TE & TE <= max) |
(min <= lower & lower <= max) |
(min <= upper & upper <= max))
) {
if (min <= lower & max >= upper) {
grid.polygon(x = unit(c(lower, TE, upper, TE), "native"),
y = unit(0.5 + c(0, 0.4 * size, 0, -0.4 * size), "npc"),
gp = gpar(fill = col.diamond, col = col.diamond.lines,
lwd = lwd))
}
##
else {
if (min > lower) {
x.min <- min
y.min1 <- 0.5 + -0.4 * size * (lower - min) / (lower - TE)
y.min2 <- 0.5 + 0.4 * size * (lower - min) / (lower - TE)
}
else {
x.min <- lower
y.min1 <- y.min2 <- 0.5
}
##
if (max < upper) {
x.max <- max
y.max1 <- 0.5 + 0.4 * size * (upper - max) / (upper - TE)
y.max2 <- 0.5 + -0.4 * size * (upper - max) / (upper - TE)
}
else {
x.max <- upper
y.max1 <- y.max2 <- 0.5
}
##
grid.polygon(x = unit(c(x.min, x.min, TE, x.max, x.max, TE, x.min),
"native"),
y = unit(c(y.min1, y.min2, 0.5 + 0.4 * size,
y.max1, y.max2, 0.5 - 0.4 * size,
y.min1), "npc"),
gp = gpar(fill = col.diamond, col = col.diamond.lines,
lwd = lwd))
}
}
##
invisible(NULL)
}
draw.ci.predict <- function(lower.predict, upper.predict,
size, min, max,
col.predict, col.predict.lines) {
##
if (min > max) {
tmp <- min
min <- max
max <- tmp
}
##
if (!(is.na(lower.predict) | is.na(upper.predict))) {
range <- max - min
## Plot prediction interval only within plotting range
if (min > lower.predict)
x.min <- min + range / 40
else
x.min <- lower.predict
##
if (max < upper.predict)
x.max <- max - range / 40
else
x.max <- upper.predict
##
grid.polygon(x = unit(c(x.min, x.min, x.max, x.max), "native"),
y = unit(0.5 + size * c(-1, 1, 1, -1) / 10, "npc"),
gp = gpar(fill = col.predict, col = col.predict.lines))
##
if (min > lower.predict)
grid.lines(x = unit(c(min, min + 0.00001), "native"),
y = 0.5,
gp = gpar(col = col.predict.lines,
fill = col.predict),
arrow = arrow(ends = "first",
length = unit(0.5, "npc"),
type = "closed"))
##
if (max < upper.predict)
grid.lines(x = unit(c(max - 0.00001, max), "native"),
y = 0.5,
gp = gpar(col = col.predict.lines,
fill = col.predict),
arrow = arrow(ends = "last",
length = unit(0.5, "npc"),
type = "closed"))
}
##
invisible(NULL)
}
draw.ci <- function(TE, lower, upper,
size, min, max,
lwd,
col,
col.square, col.square.lines,
col.circle, col.circle.lines,
col.inside,
type,
lwd.square,
arrow.type, arrow.length) {
##
if (min > max) {
tmp <- min
min <- max
max <- tmp
}
##
if (!is.na(TE)) {
##
## Draw lines in colour "col.inside" if totally inside rect
##
TElineCol <- col
##
if ((!is.na(size) & !is.na(lower) & !is.na(upper)))
if (size > 0 &&
(convertX(unit(TE, "native") + unit(0.5 * size, "lines"),
"native", valueOnly = TRUE) > upper) &&
(convertX(unit(TE, "native") - unit(0.5 * size, "lines"),
"native", valueOnly = TRUE) < lower))
TElineCol <- col.inside
}
##
if (!is.na(TE) && (TE >= min & TE <= max)) {
if (!is.na(size) && size > 0 && !is.na(lower) && !is.na(upper)) {
if (type == "square") {
grid.rect(x = unit(TE, "native"),
width = unit(size, "snpc"),
height = unit(size, "snpc"),
gp = gpar(fill = col.square, col = col.square.lines,
lwd = lwd.square))
##
grid.lines(x = unit(c(TE, TE), "native"),
y = unit(c(0.4, 0.6), "npc"),
gp = gpar(col = TElineCol, lwd = lwd))
}
}
else
grid.lines(x = unit(c(TE, TE), "native"),
y = unit(c(0.4, 0.6), "npc"),
gp = gpar(col = TElineCol, lwd = lwd))
}
##
if (!is.na(TE)) {
##
## Draw lines in colour "col.inside" if totally inside rect
##
if (!is.na(size)) {
lineCol <- col
##
if (!is.na(lower) & !is.na(upper))
if (size > 0 &&
(convertX(unit(TE, "native") + unit(0.5 * size, "lines"),
"native", valueOnly = TRUE) > upper) &&
(convertX(unit(TE, "native") - unit(0.5 * size, "lines"),
"native", valueOnly = TRUE) < lower))
lineCol <- col.inside
##
## Draw arrow if exceed col range
## convertX() used to convert between coordinate systems
##
if (!is.na(lower) && !is.na(upper) &&
(lower >= min & upper <= max))
grid.lines(x = unit(c(lower, upper), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd))
##
if (!is.na(lower) && !is.na(upper) &&
(lower < min & upper > max))
grid.lines(x = unit(c(min, max), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd))
##
if (!is.na(lower) && !is.na(upper) &&
(lower < min & (upper <= max & upper > min)))
grid.lines(x = unit(c(min, upper), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd))
##
if (!is.na(lower) && !is.na(upper) &&
((lower >= min & lower < max) & upper > max))
grid.lines(x = unit(c(lower, max), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd))
##
if (!is.na(lower) && lower < min)
grid.lines(x = unit(c(min - 0.00001, min), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd, fill = lineCol),
arrow = arrow(ends = "first",
length = unit(arrow.length, "inches"),
type = arrow.type))
if (!is.na(upper) && upper > max)
grid.lines(x = unit(c(max, max + 0.00001), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd, fill = lineCol),
arrow = arrow(ends = "last",
length = unit(arrow.length, "inches"),
type = arrow.type))
}
}
##
if (!is.na(TE) && (TE >= min & TE <= max)) {
if (!is.na(size) && size > 0 && !is.na(lower) && !is.na(upper)) {
if (type == "circle")
grid.circle(x = unit(TE, "native"), y = unit(0.5, "npc"),
r = unit(size / 2, "snpc"),
gp = gpar(fill = col.circle, col = col.circle.lines))
##
else if (type == "squarediamond") {
xmin <- convertX(unit(TE, "native") - unit(0.5 * size, "lines"),
"native", valueOnly = TRUE)
xmax <- convertX(unit(TE, "native") + unit(0.5 * size, "lines"),
"native", valueOnly = TRUE)
##
grid.polygon(x = unit(c(xmin, TE, xmax, TE), "native"),
y = unit(0.5 + c(0, 0.5 * size, 0, -0.5 * size), "npc"),
gp = gpar(col = col.square.lines, fill = col.square,
lwd = lwd.square))
}
}
else
grid.lines(x = unit(c(TE, TE), "native"),
y = unit(c(0.4, 0.6), "npc"),
gp = gpar(col = TElineCol, lwd = lwd))
}
##
invisible(NULL)
}
draw.forest <- function(x, column) {
##
## Function to plot results for individual studies and summaries
##
for (i in seq_len(length(x$rows))) {
if (!is.na(x$rows[i])) {
pushViewport(
viewport(
layout.pos.row = x$rows[i],
layout.pos.col = column,
xscale = x$range))
##
if (x$type[i] %in% c("square", "circle", "squarediamond"))
draw.ci(x$eff[i], x$low[i], x$upp[i],
x$sizes[i], x$range[1], x$range[2],
x$lwd,
x$col[i],
x$col.square[i], x$col.square.lines[i],
x$col.circle[i], x$col.circle.lines[i],
x$col.inside[i],
type = x$type[i],
x$lwd.square,
x$arrow.type, x$arrow.length)
##
else if (x$type[i] == "diamond")
draw.ci.diamond(x$eff[i], x$low[i], x$upp[i],
x$sizes[i], x$range[1], x$range[2],
x$col.diamond[i], x$col.diamond.lines[i],
x$lwd.diamond)
##
else if (x$type[i] == "predict")
draw.ci.predict(x$low[i], x$upp[i],
x$sizes[i], x$range[1], x$range[2],
x$col.diamond[i], x$col.diamond.lines[i])
##
popViewport()
}
}
##
invisible(NULL)
}
draw.lines <- function(x, column,
ref, TE.common, TE.random,
overall, common, random, prediction,
ymin.common, ymin.random, ymin.ref, ymax,
lwd, lty.common, lty.random, col.common, col.random,
xmin, xmax,
lower.equi, upper.equi,
lty.equi, col.equi,
fill.lower.equi, fill.upper.equi,
fill,
col.line) {
##
if (xmin > xmax) {
xmin <- x$range[2]
xmax <- x$range[1]
}
else {
xmin <- x$range[1]
xmax <- x$range[2]
}
##
pushViewport(viewport(layout.pos.col = column, xscale = x$range))
##
## Add background colour for confidence interval plot
##
if (!is.null(fill))
grid.polygon(x = unit(c(xmin, xmax, xmax, xmin), "native"),
y = unit(c(ymin.ref, ymin.ref, ymax, ymax),
"lines"),
gp = gpar(col = fill, fill = fill))
##
## Add equivalence region(s)
##
if (is.na(ref) & any(!is.na(lower.equi)) & any(!is.na(upper.equi)))
ref.equi <- min(lower.equi, na.rm = TRUE) +
0.5 * (max(upper.equi, na.rm = TRUE) - min(lower.equi, na.rm = TRUE))
else
ref.equi <- ref
##
if (!is.na(ref.equi) && (xmin <= ref.equi & ref.equi <= xmax) &&
any(!is.na(lower.equi))) {
##
n.lower.equi <- sum(!is.na(lower.equi))
n.fill.lower.equi <- length(fill.lower.equi)
##
if (n.lower.equi < n.fill.lower.equi) {
firstline <- FALSE
lower.equi <- c(xmin, lower.equi, ref.equi)
}
else {
firstline <- TRUE
lower.equi <- c(lower.equi, ref.equi)
}
##
n.lo <- length(lower.equi[-1])
##
for (i in seq_len(n.lo)) {
if (!is.na(lower.equi[i]) && !is.na(lower.equi[i + 1]) &&
((xmin <= lower.equi[i] & lower.equi[i] <= lower.equi[i + 1]) &
(lower.equi[i + 1] <= xmax))) {
##
grid.polygon(x = unit(c(lower.equi[i], lower.equi[i + 1],
lower.equi[i + 1], lower.equi[i]), "native"),
y = unit(c(ymin.ref, ymin.ref, ymax, ymax),
"lines"),
gp = gpar(lwd = lwd, col = "transparent",
fill = fill.lower.equi[i]))
}
}
##
for (i in seq_len(n.lo)) {
if (!(i == 1 & !firstline) &
!is.na(lower.equi[i]) && !is.na(lower.equi[i + 1]) &&
((xmin <= lower.equi[i] & lower.equi[i] <= lower.equi[i + 1]) &
(lower.equi[i + 1] <= xmax)))
grid.lines(x = unit(lower.equi[i], "native"),
y = unit(c(ymin.ref, ymax), "lines"),
gp = gpar(lwd = lwd, col = col.equi, lty = lty.equi))
}
}
##
if (!is.na(ref.equi) && (xmin <= ref.equi & ref.equi <= xmax) &&
any(!is.na(upper.equi))) {
##
n.upper.equi <- sum(!is.na(upper.equi))
n.fill.upper.equi <- length(fill.upper.equi)
##
if (n.upper.equi < n.fill.upper.equi) {
lastline <- FALSE
upper.equi <- c(ref.equi, upper.equi, xmax)
}
else {
lastline <- TRUE
upper.equi <- c(ref.equi, upper.equi)
}
##
n.up <- length(upper.equi[-1])
##
for (i in seq_len(n.up)) {
if (!is.na(upper.equi[i]) && !is.na(upper.equi[i + 1]) &&
((xmin <= upper.equi[i] & upper.equi[i] <= upper.equi[i + 1]) &
(upper.equi[i + 1] <= xmax))) {
##
grid.polygon(x = unit(c(upper.equi[i], upper.equi[i + 1],
upper.equi[i + 1], upper.equi[i]), "native"),
y = unit(c(ymin.ref, ymin.ref, ymax, ymax),
"lines"),
gp = gpar(lwd = lwd, col = "transparent",
fill = fill.upper.equi[i]))
}
}
##
for (i in seq_len(n.up)) {
if ((i != n.up | (i == n.up & lastline)) &
!is.na(upper.equi[i + 1]) &&
(xmin <= upper.equi[i + 1] & upper.equi[i + 1] <= xmax))
grid.lines(x = unit(upper.equi[i + 1], "native"),
y = unit(c(ymin.ref, ymax), "lines"),
gp = gpar(lwd = lwd, col = col.equi, lty = lty.equi))
}
}
##
## Reference line:
##
if (!is.na(ref) && (xmin <= ref & ref <= xmax))
grid.lines(x = unit(ref, "native"),
y = unit(c(ymin.ref, ymax), "lines"),
gp = gpar(lwd = lwd, col = col.line))
##
## Line for common effect estimate(s):
##
if (common & overall)
for (i in seq_along(TE.common))
if (!is.na(TE.common[i]))
if (xmin <= TE.common[i] & TE.common[i] <= xmax)
if (!is.null(lty.common))
grid.lines(x = unit(TE.common[i], "native"),
y = unit(c(ymin.common + length(TE.common) - i, ymax),
"lines"),
gp = gpar(lty = lty.common, lwd = lwd, col = col.common))
##
## Line for random effects estimate(s):
##
if (random & overall)
for (i in seq_along(TE.random))
if (!is.na(TE.random[i]))
if (xmin <= TE.random[i] & TE.random[i] <= xmax)
if (!is.null(lty.random) & !is.na(TE.random[i]))
grid.lines(x = unit(TE.random[i], "native"),
y = unit(c(ymin.random + length(TE.random) - i, ymax),
"lines"),
gp = gpar(lty = lty.random,
lwd = lwd, col = col.random))
##
popViewport()
##
invisible(NULL)
}
formatcol <- function(x, y, rows, just = "right", settings,
fontfamily,
n.com, n.ran, n.prd,
rob = FALSE) {
##
if (just == "left")
xpos <- 0
if (just == "center")
xpos <- 0.5
if (just == "right")
xpos <- 1
##
res <- list(labels =
lapply(c(x, as.list(y)),
textGrob, x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.study,
fontface = settings$ff.study,
fontfamily = fontfamily)
),
rows = rows,
rob = rob)
##
## Study label:
##
res$labels[[1]] <- textGrob(x,
x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.heading,
fontface = settings$ff.heading,
fontfamily = fontfamily)
)
##
## Common effect estimate:
##
strt <- j <- 1
for (i in seq_len(n.com)) {
res$labels[[strt + i]] <- textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.common,
fontface = settings$ff.common,
fontfamily = fontfamily)
)
j <- j + 1
}
##
## Random effects estimate:
##
strt <- j
for (i in seq_len(n.ran)) {
res$labels[[strt + i]] <- textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.random,
fontface = settings$ff.random,
fontfamily = fontfamily)
)
j <- j + 1
}
##
## Prediction interval:
##
strt <- j
for (i in seq_len(n.prd)) {
res$labels[[strt + i]] <- textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.predict,
fontface = settings$ff.predict,
fontfamily = fontfamily)
)
j <- j + 1
}
##
if (settings$by) {
n.by <- settings$n.by
strt <- j
##
## Common effect estimates:
##
for (i in seq_len(n.by * n.com)) {
res$labels[[strt + i]] <-
textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp =
gpar(
fontsize = settings$fs.common,
fontface = settings$ff.common,
fontfamily = fontfamily,
col = settings$col.subgroup)
)
j <- j + 1
}
##
## Random effects estimates:
##
strt <- j
for (i in seq_len(n.by * n.ran)) {
res$labels[[strt + i]] <-
textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp =
gpar(
fontsize = settings$fs.random,
fontface = settings$ff.random,
fontfamily = fontfamily,
col = settings$col.subgroup)
)
j <- j + 1
}
##
## Prediction interval:
##
strt <- j
for (i in seq_len(n.by * n.prd)) {
res$labels[[strt + i]] <-
textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp =
gpar(
fontsize = settings$fs.predict,
fontface = settings$ff.predict,
fontfamily = fontfamily,
col = settings$col.subgroup)
)
j <- j + 1
}
}
##
res
}
removeNULL <- function(x, names, varname) {
if (is.null(x[[varname]]))
res <- names[names != varname]
else
res <- names
##
res
}
tg <- function(x, xpos, just, fs, ff, fontfamily, col) {
if (missing(col))
res <- textGrob(x,
x = xpos, just = just,
gp = gpar(fontsize = fs, fontface = ff,
fontfamily = fontfamily))
else
res <- textGrob(x,
x = xpos, just = just,
gp = gpar(fontsize = fs, fontface = ff,
fontfamily = fontfamily,
col = col))
##
res
}
tgl <- function(x, xpos, just, fs, ff, fontfamily, rows = 1, col) {
##
if (missing(col))
res <- list(labels = list(tg(x, xpos, just, fs, ff, fontfamily)),
rows = rows)
else
res <- list(labels = list(tg(x, xpos, just, fs, ff, fontfamily, col)),
rows = rows)
##
res
}
twolines <- function(x, xname = deparse(substitute(x)), arg = FALSE) {
newline <- FALSE
bottom <- longer <- x
top <- NULL
##
if (!is.null(bottom)) {
if (grepl("\n", bottom)) {
wsplit <- unlist(strsplit(bottom, "\n"))
if (length(wsplit) == 1) {
if (substring(bottom, 1, 1) == "\n") {
top <- ""
bottom <- wsplit[1]
longer <- bottom
newline <- TRUE
}
else if (substring(bottom, nchar(bottom), nchar(bottom)) == "\n") {
top <- wsplit[1]
bottom <- ""
longer <- top
newline <- TRUE
}
}
else if (length(wsplit) != 2) {
if (arg)
stop("Maximum of two lines for argument '", xname, "'.",
call. = FALSE)
else
stop("Maximum of two lines for label of column '", xname, "'.",
call. = FALSE)
}
else {
top <- wsplit[1]
bottom <- wsplit[2]
longer <- ifelse(nchar(top) > nchar(bottom), top, bottom)
newline <- TRUE
}
}
}
##
list(newline = newline, bottom = bottom, top = top, longer = longer)
}
wcalc <- function(x)
max(unit(rep(1, length(x)), "grobwidth", x))
collapsemat <- function(x) {
if (is.list(x)) {
for (i in rev(seq_len(length(x)))) {
if (is.null(x[[i]]))
x[[i]] <- NULL
}
}
##
if (is.list(x) & length(x) == 1)
x <- x[[1]]
##
if (is.matrix(x)) {
res <- as.vector(t(x))
names(res) <- rep(rownames(x), rep(ncol(x), nrow(x)))
}
else
res <- x
##
res
}
ordermat <- function(x, levs) {
o <- order(factor(names(x), levels = levs))
x[o]
}
selmat <- function(x, levs) {
o <- order(factor(names(x), levels = levs))
x[o]
}
notallNA <- function(x)
any(!is.na(x))
repl <- function(x, n1, n2)
rep(x, rep(n1, n2))
gh <- function(type.gr, rows.gr,
##
n.stud,
lower.common, lower.random, lower.predict,
subgroup, subgroup.levels,
lower.common.w, lower.random.w, lower.predict.w,
##
common, random, overall,
prediction, overall.hetstat,
study.results,
##
spacing,
##
xlab, xlab.add, label.right, label.left, bottom.lr,
##
prediction.subgroup, subgroup.hetstat,
test.overall.common, test.overall.random,
test.subgroup.common, test.subgroup.random,
##
text.addline1, text.addline2,
text.details, text.rob,
##
addrow, addrow.overall,
addrow.subgroups, addrows.below.overall,
##
cols, labs,
text.w.common, text.w.random) {
##
## (1) Determine height per row
##
if (grepl("bmp$", tolower(type.gr)) ||
grepl("jpg$", tolower(type.gr)) ||
grepl("jpeg$", tolower(type.gr)) ||
grepl("png$", tolower(type.gr)) ||
grepl("tif$", tolower(type.gr)) ||
grepl("tiff$", tolower(type.gr)))
height_per_row <- 480 / 33
else
height_per_row <- 7 / 35
##
## (2) Column labels
##
labs <- unlist(labs)
if (any(grepl("col.w.common", cols)))
labs <- c(labs, text.w.common)
if (any(grepl("col.w.random", cols)))
labs <- c(labs, text.w.random)
##
rows_column_labels <- 1 + 1L * any(grepl("\n", unlist(labs))) + 1L * addrow
##
## (2) Study results
##
rows_studies <-
if (!study.results)
0
else
n.stud
##
## (3) Meta-analysis results
##
if (overall)
rows_overall <-
1L * addrow.overall +
1L * common * length(lower.common) +
1L * random * length(lower.random) +
1L * prediction * length(lower.predict)
else
rows_overall <- 1L * addrow.overall
##
## (4) Text below meta-analysis results
##
n.details <- sum(text.details != "")
n.rob <- sum(text.rob != "")
rows_below_overall_labels <- addrows.below.overall + overall.hetstat +
test.overall.common + test.overall.random +
test.subgroup.common + test.subgroup.random +
1L * (text.addline1 != "") +
1L * (text.addline2 != "") +
n.details + 1L * (n.details > 0) +
n.rob + 1L * (n.rob > 0) +
1L * (n.details > 0 | n.rob > 0) +
2L * (n.details == 0 & n.rob == 0)
## + 0.25
##
## (5) Information below confidence interval plot
##
rows_xlab <-
if (xlab == "")
0
else
2
##
rows_xlab.add <-
if (xlab.add == "")
0
else
2
##
rows_xlab <- rows_xlab + rows_xlab.add
##
if (!bottom.lr) {
rows_label.left <- 0
rows_label.right <- 0
}
else {
rows_label.left <-
if (is.null(label.left) || label.left == "")
0
else if (!grepl("\n", label.left))
2
else
4
##
rows_label.right <-
if (is.null(label.right) || label.right == "")
0
else if (!grepl("\n", label.right))
2
else
4
}
##
rows_label <- max(c(rows_label.left, rows_label.right))
##
rows_below_forest <- 2 + rows_xlab + rows_label
##
## (6) Subgroup results
##
if (is.null(subgroup))
rows_subgroups <- 0
else {
n.subgr <- length(subgroup.levels)
##
rows_subgroups_common <- common * n.subgr
rows_subgroups_random <- random * n.subgr
##
rows_subgroups_predict <-
if (is.vector(prediction.subgroup))
sum(prediction.subgroup)
else
prediction.subgroup * n.subgr
##
rows_subgroups_hetstat <-
if (length(subgroup.hetstat) > 1)
sum(subgroup.hetstat)
else
subgroup.hetstat * n.subgr
##
if (is.matrix(lower.common.w))
rows_subgroups_common <- rows_subgroups_common * nrow(lower.common.w)
##
if (is.matrix(lower.random.w))
rows_subgroups_random <- rows_subgroups_random * nrow(lower.random.w)
##
if (is.matrix(lower.predict.w))
rows_subgroups_predict <- rows_subgroups_predict * nrow(lower.predict.w)
##
rows_subgroups <-
n.subgr + # Labels
addrow.subgroups * (n.subgr - 1) +
rows_subgroups_common + rows_subgroups_random +
rows_subgroups_predict + rows_subgroups_hetstat
}
##
## (7) Determine total height of graphics device
##
total_rows <-
rows_column_labels +
rows_studies +
rows_overall +
max(rows_below_overall_labels, rows_below_forest) +
rows_subgroups +
rows.gr +
1
##
total_height <- height_per_row * spacing * total_rows
res <- data.frame(total_height, total_rows, height_per_row, spacing)
##
res
}
show_subgroup_results <- function(x, n, lower, upper) {
if (length(x) == 1) {
if (is.matrix(lower))
return(x &
apply(lower, 1, notallNA) &
apply(upper, 1, notallNA))
else
return(rep(x & notallNA(lower) & notallNA(upper), n))
}
else {
chklength(x, n,
text = paste0("Length of argument '",
deparse(substitute(x)),
"' must be equal to 1 or number of subgroups."))
return(x)
}
}
guido-s/meta documentation built on April 18, 2024, 7:11 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions show_subgroup_results gh repl notallNA selmat ordermat collapsemat wcalc twolines tgl tg removeNULL formatcol draw.lines draw.forest draw.ci draw.ci.predict draw.ci.diamond draw.axis add.rob add.xlab add.text add.label
##
##
## Definition of auxiliary functions for forest plots
##
##
add.label <- function(x, column,
xpos, ypos, just, fs.lr, ff.lr, col,
fontfamily,
...) {
##
pushViewport(viewport(layout.pos.col = column, ...))
##
grid.text(x, x = xpos, y = ypos, just = just,
gp = gpar(fontsize = fs.lr, fontface = ff.lr, col = col,
fontfamily = fontfamily))
##
popViewport()
##
invisible(NULL)
}
add.text <- function(x, column, ...) {
##
for (i in seq_len(length(x$rows))) {
if (!is.na(x$rows[i])) {
pushViewport(
viewport(
layout.pos.row = x$rows[i],
layout.pos.col = column, ...))
#
grid.draw(x$labels[[i]])
#
popViewport()
}
}
##
invisible(NULL)
}
add.xlab <- function(x, column, xlab, xlab.add, newline.xlab,
xpos, ypos, fs.xlab, ff.xlab,
fontfamily) {
##
pushViewport(viewport(layout.pos.col = column, xscale = x$range))
##
## Label on x-axis:
##
grid.text(xlab,
x = unit(xpos, "native"),
y = unit(ypos, "lines"),
just = "center",
gp = gpar(fontsize = fs.xlab, fontface = ff.xlab,
fontfamily = fontfamily))
##
if (newline.xlab)
grid.text(xlab.add,
x = unit(xpos, "native"),
y = unit(ypos - 1, "lines"),
just = "center",
gp = gpar(fontsize = fs.xlab, fontface = ff.xlab,
fontfamily = fontfamily))
##
popViewport()
##
invisible(NULL)
}
add.rob <- function(x, column, size, fs, ff, fontfamily,
rob, rob.levels, rob.symbols, rob.colour, ...) {
##
if (is.null(rob.levels)) {
if (is.factor(rob))
rob.levels <- levels(rob)
else
rob.levels <- unique(rob)
}
##
n.levs <- length(rob.levels)
##
if (is.null(rob.symbols)) {
if (n.levs == 3)
rob.symbols <- c("-", "?", "+")
else
rob.symbols <- rev(seq_len(n.levs))
}
else if (length(rob.symbols) == 1 && is.logical(rob.symbols)) {
if (rob.symbols) {
if (n.levs == 3)
rob.symbols <- c("-", "?", "+")
else
rob.symbols <- rev(seq_len(n.levs))
}
}
else if (length(rob.symbols) != n.levs)
stop("Wrong number of RoB symbols (argument 'rob.symbols').",
call. = FALSE)
##
if (is.null(rob.colour)) {
if (n.levs == 3)
rob.colour <- c("red", "yellow", "green")
else
rob.colour <- rev(seq_len(n.levs))
}
##
if (!(length(rob.symbols) == 1 && is.logical(rob.symbols) && !rob.symbols))
txt.rob <-
as.character(
factor(rob, levels = rob.levels, labels = rob.symbols))
else
txt.rob <- NULL
##
col.rob <-
as.character(
factor(rob, levels = rob.levels,
labels = rob.colour))
##
j <- 0
##
for (i in seq_len(length(x$rows))) {
if (!is.na(x$rows[i])) {
pushViewport(
viewport(
layout.pos.row = x$rows[i],
layout.pos.col = column, ...))
##
if (i == 1)
grid.draw(x$labels[[1]])
else {
j <- j + 1
##
grid.circle(x = unit(0.5, "npc"), y = unit(0.5, "npc"),
r = unit(size / 2, "snpc"),
gp = gpar(fill = col.rob[j], col = col.rob[j]))
##
if (!is.null(txt.rob) && !is.na(txt.rob[j]))
grid.text(txt.rob[j],
x = unit(0.5, "npc"),
y = unit(if (txt.rob[j] %in% c("-", "+")) 0.58 else 0.5,
"npc"),
gp = gpar(fontsize = fs, fontface = ff,
fontfamily = fontfamily),
just = c("center", "center"))
}
##
popViewport()
}
}
##
invisible(NULL)
}
draw.axis <- function(x, column, yS, log.xaxis, at, label,
fs.axis, ff.axis, fontfamily, lwd,
xlim, notmiss.xlim,
col.line, col.label) {
##
## Function to draw x-axis
##
pushViewport(
viewport(
layout.pos.row = max(yS, na.rm = TRUE),
layout.pos.col = column,
xscale = x$range))
##
## x-axis:
##
if (log.xaxis) {
if (is.null(at)) {
x1000 <- c(0.001, 0.1, 1, 10, 1000)
x100 <- c(0.01 , 0.1, 1, 10, 100)
x10 <- c(0.1 , 0.5, 1, 2, 10)
x5 <- c(0.2 , 0.5, 1, 2, 5)
x2 <- c(0.5 , 1, 2)
x1.5 <- c(0.75 , 1, 1.5)
x1.25 <- c(0.8 , 1, 1.25)
x1 <- c(0.9 , 1, 1.1)
##
min.x <- min(exp(x$range[1]), 1)
max.x <- max(exp(x$range[2]), 1)
##
if (all(x1000 >= min.x) &
all(x1000 <= max.x))
label <- x1000
else if (all(x100 >= min.x) &
all(x100 <= max.x))
label <- x100
else if (all(x10 >= min.x) &
all(x10 <= max.x))
label <- x10
else if (all(x5 >= min.x) &
all(x5 <= max.x))
label <- x5
else if (all(x2 >= min.x) &
all(x2 <= max.x))
label <- x2
else if (all(x1.5 >= min.x) &
all(x1.5 <= max.x))
label <- x1.5
else if (all(x1.25 >= min.x) &
all(x1.25 <= max.x))
label <- x1.25
else if (all(x1 >= min.x) &
all(x1 <= max.x))
label <- x1
else
label <- 1
##
if (notmiss.xlim && is.numeric(xlim[1])) {
if (exp(min(xlim)) < min(label))
label <- c(exp(min(xlim)), label)
if (exp(max(xlim)) > max(label))
label <- c(label, exp(max(xlim)))
}
at <- log(label)
}
else {
if (length(label) == 1 && is.logical(label) && label)
label <- at
at <- log(at)
}
## Print x-axis labels
grid.xaxis(name = "xaxis1",
at = at, label = label,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.label, tcl = -0.1))
## Print xaxis and tick marks (in different colour)
grid.xaxis(name = "xaxis2",
at = at, label = FALSE,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.line, tcl = -0.1))
}
else {
if (is.null(at)) {
## Print x-axis labels
grid.xaxis(name = "xaxis1",
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.label, tcl = -0.1))
## Print xaxis and tick marks (in different colour)
grid.xaxis(name = "xaxis2",
label = FALSE,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.line, tcl = -0.1))
}
else if ((length(label) == 1 && is.logical(label) && label) |
(length(label) >= 1 & !is.logical(label))) {
## Print x-axis labels
grid.xaxis(name = "xaxis1",
at = at, label = label,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.label, tcl = -0.1))
## Print xaxis and tick marks (in different colour)
grid.xaxis(name = "xaxis2",
at = at, label = FALSE,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.line, tcl = -0.1))
}
else {
## Print x-axis labels
grid.xaxis(name = "xaxis1",
at = at,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.label, tcl = -0.1))
## Print xaxis and tick marks (in different colour)
grid.xaxis(name = "xaxis2",
at = at, label = FALSE,
gp = gpar(fontsize = fs.axis, fontface = ff.axis,
fontfamily = fontfamily, lwd = lwd,
col = col.line, tcl = -0.1))
}
}
##
popViewport()
##
invisible(NULL)
}
draw.ci.diamond <- function(TE, lower, upper,
size, min, max,
col.diamond, col.diamond.lines,
lwd) {
##
if (min > max) {
tmp <- min
min <- max
max <- tmp
}
##
if (!is.na(TE) &&
((min <= TE & TE <= max) |
(min <= lower & lower <= max) |
(min <= upper & upper <= max))
) {
if (min <= lower & max >= upper) {
grid.polygon(x = unit(c(lower, TE, upper, TE), "native"),
y = unit(0.5 + c(0, 0.4 * size, 0, -0.4 * size), "npc"),
gp = gpar(fill = col.diamond, col = col.diamond.lines,
lwd = lwd))
}
##
else {
if (min > lower) {
x.min <- min
y.min1 <- 0.5 + -0.4 * size * (lower - min) / (lower - TE)
y.min2 <- 0.5 + 0.4 * size * (lower - min) / (lower - TE)
}
else {
x.min <- lower
y.min1 <- y.min2 <- 0.5
}
##
if (max < upper) {
x.max <- max
y.max1 <- 0.5 + 0.4 * size * (upper - max) / (upper - TE)
y.max2 <- 0.5 + -0.4 * size * (upper - max) / (upper - TE)
}
else {
x.max <- upper
y.max1 <- y.max2 <- 0.5
}
##
grid.polygon(x = unit(c(x.min, x.min, TE, x.max, x.max, TE, x.min),
"native"),
y = unit(c(y.min1, y.min2, 0.5 + 0.4 * size,
y.max1, y.max2, 0.5 - 0.4 * size,
y.min1), "npc"),
gp = gpar(fill = col.diamond, col = col.diamond.lines,
lwd = lwd))
}
}
##
invisible(NULL)
}
draw.ci.predict <- function(lower.predict, upper.predict,
size, min, max,
col.predict, col.predict.lines) {
##
if (min > max) {
tmp <- min
min <- max
max <- tmp
}
##
if (!(is.na(lower.predict) | is.na(upper.predict))) {
range <- max - min
## Plot prediction interval only within plotting range
if (min > lower.predict)
x.min <- min + range / 40
else
x.min <- lower.predict
##
if (max < upper.predict)
x.max <- max - range / 40
else
x.max <- upper.predict
##
grid.polygon(x = unit(c(x.min, x.min, x.max, x.max), "native"),
y = unit(0.5 + size * c(-1, 1, 1, -1) / 10, "npc"),
gp = gpar(fill = col.predict, col = col.predict.lines))
##
if (min > lower.predict)
grid.lines(x = unit(c(min, min + 0.00001), "native"),
y = 0.5,
gp = gpar(col = col.predict.lines,
fill = col.predict),
arrow = arrow(ends = "first",
length = unit(0.5, "npc"),
type = "closed"))
##
if (max < upper.predict)
grid.lines(x = unit(c(max - 0.00001, max), "native"),
y = 0.5,
gp = gpar(col = col.predict.lines,
fill = col.predict),
arrow = arrow(ends = "last",
length = unit(0.5, "npc"),
type = "closed"))
}
##
invisible(NULL)
}
draw.ci <- function(TE, lower, upper,
size, min, max,
lwd,
col,
col.square, col.square.lines,
col.circle, col.circle.lines,
col.inside,
type,
lwd.square,
arrow.type, arrow.length) {
##
if (min > max) {
tmp <- min
min <- max
max <- tmp
}
##
if (!is.na(TE)) {
##
## Draw lines in colour "col.inside" if totally inside rect
##
TElineCol <- col
##
if ((!is.na(size) & !is.na(lower) & !is.na(upper)))
if (size > 0 &&
(convertX(unit(TE, "native") + unit(0.5 * size, "lines"),
"native", valueOnly = TRUE) > upper) &&
(convertX(unit(TE, "native") - unit(0.5 * size, "lines"),
"native", valueOnly = TRUE) < lower))
TElineCol <- col.inside
}
##
if (!is.na(TE) && (TE >= min & TE <= max)) {
if (!is.na(size) && size > 0 && !is.na(lower) && !is.na(upper)) {
if (type == "square") {
grid.rect(x = unit(TE, "native"),
width = unit(size, "snpc"),
height = unit(size, "snpc"),
gp = gpar(fill = col.square, col = col.square.lines,
lwd = lwd.square))
##
grid.lines(x = unit(c(TE, TE), "native"),
y = unit(c(0.4, 0.6), "npc"),
gp = gpar(col = TElineCol, lwd = lwd))
}
}
else
grid.lines(x = unit(c(TE, TE), "native"),
y = unit(c(0.4, 0.6), "npc"),
gp = gpar(col = TElineCol, lwd = lwd))
}
##
if (!is.na(TE)) {
##
## Draw lines in colour "col.inside" if totally inside rect
##
if (!is.na(size)) {
lineCol <- col
##
if (!is.na(lower) & !is.na(upper))
if (size > 0 &&
(convertX(unit(TE, "native") + unit(0.5 * size, "lines"),
"native", valueOnly = TRUE) > upper) &&
(convertX(unit(TE, "native") - unit(0.5 * size, "lines"),
"native", valueOnly = TRUE) < lower))
lineCol <- col.inside
##
## Draw arrow if exceed col range
## convertX() used to convert between coordinate systems
##
if (!is.na(lower) && !is.na(upper) &&
(lower >= min & upper <= max))
grid.lines(x = unit(c(lower, upper), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd))
##
if (!is.na(lower) && !is.na(upper) &&
(lower < min & upper > max))
grid.lines(x = unit(c(min, max), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd))
##
if (!is.na(lower) && !is.na(upper) &&
(lower < min & (upper <= max & upper > min)))
grid.lines(x = unit(c(min, upper), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd))
##
if (!is.na(lower) && !is.na(upper) &&
((lower >= min & lower < max) & upper > max))
grid.lines(x = unit(c(lower, max), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd))
##
if (!is.na(lower) && lower < min)
grid.lines(x = unit(c(min - 0.00001, min), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd, fill = lineCol),
arrow = arrow(ends = "first",
length = unit(arrow.length, "inches"),
type = arrow.type))
if (!is.na(upper) && upper > max)
grid.lines(x = unit(c(max, max + 0.00001), "native"), y = 0.5,
gp = gpar(col = lineCol, lwd = lwd, fill = lineCol),
arrow = arrow(ends = "last",
length = unit(arrow.length, "inches"),
type = arrow.type))
}
}
##
if (!is.na(TE) && (TE >= min & TE <= max)) {
if (!is.na(size) && size > 0 && !is.na(lower) && !is.na(upper)) {
if (type == "circle")
grid.circle(x = unit(TE, "native"), y = unit(0.5, "npc"),
r = unit(size / 2, "snpc"),
gp = gpar(fill = col.circle, col = col.circle.lines))
##
else if (type == "squarediamond") {
xmin <- convertX(unit(TE, "native") - unit(0.5 * size, "lines"),
"native", valueOnly = TRUE)
xmax <- convertX(unit(TE, "native") + unit(0.5 * size, "lines"),
"native", valueOnly = TRUE)
##
grid.polygon(x = unit(c(xmin, TE, xmax, TE), "native"),
y = unit(0.5 + c(0, 0.5 * size, 0, -0.5 * size), "npc"),
gp = gpar(col = col.square.lines, fill = col.square,
lwd = lwd.square))
}
}
else
grid.lines(x = unit(c(TE, TE), "native"),
y = unit(c(0.4, 0.6), "npc"),
gp = gpar(col = TElineCol, lwd = lwd))
}
##
invisible(NULL)
}
draw.forest <- function(x, column) {
##
## Function to plot results for individual studies and summaries
##
for (i in seq_len(length(x$rows))) {
if (!is.na(x$rows[i])) {
pushViewport(
viewport(
layout.pos.row = x$rows[i],
layout.pos.col = column,
xscale = x$range))
##
if (x$type[i] %in% c("square", "circle", "squarediamond"))
draw.ci(x$eff[i], x$low[i], x$upp[i],
x$sizes[i], x$range[1], x$range[2],
x$lwd,
x$col[i],
x$col.square[i], x$col.square.lines[i],
x$col.circle[i], x$col.circle.lines[i],
x$col.inside[i],
type = x$type[i],
x$lwd.square,
x$arrow.type, x$arrow.length)
##
else if (x$type[i] == "diamond")
draw.ci.diamond(x$eff[i], x$low[i], x$upp[i],
x$sizes[i], x$range[1], x$range[2],
x$col.diamond[i], x$col.diamond.lines[i],
x$lwd.diamond)
##
else if (x$type[i] == "predict")
draw.ci.predict(x$low[i], x$upp[i],
x$sizes[i], x$range[1], x$range[2],
x$col.diamond[i], x$col.diamond.lines[i])
##
popViewport()
}
}
##
invisible(NULL)
}
draw.lines <- function(x, column,
ref, TE.common, TE.random,
overall, common, random, prediction,
ymin.common, ymin.random, ymin.ref, ymax,
lwd, lty.common, lty.random, col.common, col.random,
xmin, xmax,
lower.equi, upper.equi,
lty.equi, col.equi,
fill.lower.equi, fill.upper.equi,
fill,
col.line) {
##
if (xmin > xmax) {
xmin <- x$range[2]
xmax <- x$range[1]
}
else {
xmin <- x$range[1]
xmax <- x$range[2]
}
##
pushViewport(viewport(layout.pos.col = column, xscale = x$range))
##
## Add background colour for confidence interval plot
##
if (!is.null(fill))
grid.polygon(x = unit(c(xmin, xmax, xmax, xmin), "native"),
y = unit(c(ymin.ref, ymin.ref, ymax, ymax),
"lines"),
gp = gpar(col = fill, fill = fill))
##
## Add equivalence region(s)
##
if (is.na(ref) & any(!is.na(lower.equi)) & any(!is.na(upper.equi)))
ref.equi <- min(lower.equi, na.rm = TRUE) +
0.5 * (max(upper.equi, na.rm = TRUE) - min(lower.equi, na.rm = TRUE))
else
ref.equi <- ref
##
if (!is.na(ref.equi) && (xmin <= ref.equi & ref.equi <= xmax) &&
any(!is.na(lower.equi))) {
##
n.lower.equi <- sum(!is.na(lower.equi))
n.fill.lower.equi <- length(fill.lower.equi)
##
if (n.lower.equi < n.fill.lower.equi) {
firstline <- FALSE
lower.equi <- c(xmin, lower.equi, ref.equi)
}
else {
firstline <- TRUE
lower.equi <- c(lower.equi, ref.equi)
}
##
n.lo <- length(lower.equi[-1])
##
for (i in seq_len(n.lo)) {
if (!is.na(lower.equi[i]) && !is.na(lower.equi[i + 1]) &&
((xmin <= lower.equi[i] & lower.equi[i] <= lower.equi[i + 1]) &
(lower.equi[i + 1] <= xmax))) {
##
grid.polygon(x = unit(c(lower.equi[i], lower.equi[i + 1],
lower.equi[i + 1], lower.equi[i]), "native"),
y = unit(c(ymin.ref, ymin.ref, ymax, ymax),
"lines"),
gp = gpar(lwd = lwd, col = "transparent",
fill = fill.lower.equi[i]))
}
}
##
for (i in seq_len(n.lo)) {
if (!(i == 1 & !firstline) &
!is.na(lower.equi[i]) && !is.na(lower.equi[i + 1]) &&
((xmin <= lower.equi[i] & lower.equi[i] <= lower.equi[i + 1]) &
(lower.equi[i + 1] <= xmax)))
grid.lines(x = unit(lower.equi[i], "native"),
y = unit(c(ymin.ref, ymax), "lines"),
gp = gpar(lwd = lwd, col = col.equi, lty = lty.equi))
}
}
##
if (!is.na(ref.equi) && (xmin <= ref.equi & ref.equi <= xmax) &&
any(!is.na(upper.equi))) {
##
n.upper.equi <- sum(!is.na(upper.equi))
n.fill.upper.equi <- length(fill.upper.equi)
##
if (n.upper.equi < n.fill.upper.equi) {
lastline <- FALSE
upper.equi <- c(ref.equi, upper.equi, xmax)
}
else {
lastline <- TRUE
upper.equi <- c(ref.equi, upper.equi)
}
##
n.up <- length(upper.equi[-1])
##
for (i in seq_len(n.up)) {
if (!is.na(upper.equi[i]) && !is.na(upper.equi[i + 1]) &&
((xmin <= upper.equi[i] & upper.equi[i] <= upper.equi[i + 1]) &
(upper.equi[i + 1] <= xmax))) {
##
grid.polygon(x = unit(c(upper.equi[i], upper.equi[i + 1],
upper.equi[i + 1], upper.equi[i]), "native"),
y = unit(c(ymin.ref, ymin.ref, ymax, ymax),
"lines"),
gp = gpar(lwd = lwd, col = "transparent",
fill = fill.upper.equi[i]))
}
}
##
for (i in seq_len(n.up)) {
if ((i != n.up | (i == n.up & lastline)) &
!is.na(upper.equi[i + 1]) &&
(xmin <= upper.equi[i + 1] & upper.equi[i + 1] <= xmax))
grid.lines(x = unit(upper.equi[i + 1], "native"),
y = unit(c(ymin.ref, ymax), "lines"),
gp = gpar(lwd = lwd, col = col.equi, lty = lty.equi))
}
}
##
## Reference line:
##
if (!is.na(ref) && (xmin <= ref & ref <= xmax))
grid.lines(x = unit(ref, "native"),
y = unit(c(ymin.ref, ymax), "lines"),
gp = gpar(lwd = lwd, col = col.line))
##
## Line for common effect estimate(s):
##
if (common & overall)
for (i in seq_along(TE.common))
if (!is.na(TE.common[i]))
if (xmin <= TE.common[i] & TE.common[i] <= xmax)
if (!is.null(lty.common))
grid.lines(x = unit(TE.common[i], "native"),
y = unit(c(ymin.common + length(TE.common) - i, ymax),
"lines"),
gp = gpar(lty = lty.common, lwd = lwd, col = col.common))
##
## Line for random effects estimate(s):
##
if (random & overall)
for (i in seq_along(TE.random))
if (!is.na(TE.random[i]))
if (xmin <= TE.random[i] & TE.random[i] <= xmax)
if (!is.null(lty.random) & !is.na(TE.random[i]))
grid.lines(x = unit(TE.random[i], "native"),
y = unit(c(ymin.random + length(TE.random) - i, ymax),
"lines"),
gp = gpar(lty = lty.random,
lwd = lwd, col = col.random))
##
popViewport()
##
invisible(NULL)
}
formatcol <- function(x, y, rows, just = "right", settings,
fontfamily,
n.com, n.ran, n.prd,
rob = FALSE) {
##
if (just == "left")
xpos <- 0
if (just == "center")
xpos <- 0.5
if (just == "right")
xpos <- 1
##
res <- list(labels =
lapply(c(x, as.list(y)),
textGrob, x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.study,
fontface = settings$ff.study,
fontfamily = fontfamily)
),
rows = rows,
rob = rob)
##
## Study label:
##
res$labels[[1]] <- textGrob(x,
x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.heading,
fontface = settings$ff.heading,
fontfamily = fontfamily)
)
##
## Common effect estimate:
##
strt <- j <- 1
for (i in seq_len(n.com)) {
res$labels[[strt + i]] <- textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.common,
fontface = settings$ff.common,
fontfamily = fontfamily)
)
j <- j + 1
}
##
## Random effects estimate:
##
strt <- j
for (i in seq_len(n.ran)) {
res$labels[[strt + i]] <- textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.random,
fontface = settings$ff.random,
fontfamily = fontfamily)
)
j <- j + 1
}
##
## Prediction interval:
##
strt <- j
for (i in seq_len(n.prd)) {
res$labels[[strt + i]] <- textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp = gpar(
fontsize = settings$fs.predict,
fontface = settings$ff.predict,
fontfamily = fontfamily)
)
j <- j + 1
}
##
if (settings$by) {
n.by <- settings$n.by
strt <- j
##
## Common effect estimates:
##
for (i in seq_len(n.by * n.com)) {
res$labels[[strt + i]] <-
textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp =
gpar(
fontsize = settings$fs.common,
fontface = settings$ff.common,
fontfamily = fontfamily,
col = settings$col.subgroup)
)
j <- j + 1
}
##
## Random effects estimates:
##
strt <- j
for (i in seq_len(n.by * n.ran)) {
res$labels[[strt + i]] <-
textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp =
gpar(
fontsize = settings$fs.random,
fontface = settings$ff.random,
fontfamily = fontfamily,
col = settings$col.subgroup)
)
j <- j + 1
}
##
## Prediction interval:
##
strt <- j
for (i in seq_len(n.by * n.prd)) {
res$labels[[strt + i]] <-
textGrob(y[strt - 1 + i],
x = xpos, just = just,
gp =
gpar(
fontsize = settings$fs.predict,
fontface = settings$ff.predict,
fontfamily = fontfamily,
col = settings$col.subgroup)
)
j <- j + 1
}
}
##
res
}
removeNULL <- function(x, names, varname) {
if (is.null(x[[varname]]))
res <- names[names != varname]
else
res <- names
##
res
}
tg <- function(x, xpos, just, fs, ff, fontfamily, col) {
if (missing(col))
res <- textGrob(x,
x = xpos, just = just,
gp = gpar(fontsize = fs, fontface = ff,
fontfamily = fontfamily))
else
res <- textGrob(x,
x = xpos, just = just,
gp = gpar(fontsize = fs, fontface = ff,
fontfamily = fontfamily,
col = col))
##
res
}
tgl <- function(x, xpos, just, fs, ff, fontfamily, rows = 1, col) {
##
if (missing(col))
res <- list(labels = list(tg(x, xpos, just, fs, ff, fontfamily)),
rows = rows)
else
res <- list(labels = list(tg(x, xpos, just, fs, ff, fontfamily, col)),
rows = rows)
##
res
}
twolines <- function(x, xname = deparse(substitute(x)), arg = FALSE) {
newline <- FALSE
bottom <- longer <- x
top <- NULL
##
if (!is.null(bottom)) {
if (grepl("\n", bottom)) {
wsplit <- unlist(strsplit(bottom, "\n"))
if (length(wsplit) == 1) {
if (substring(bottom, 1, 1) == "\n") {
top <- ""
bottom <- wsplit[1]
longer <- bottom
newline <- TRUE
}
else if (substring(bottom, nchar(bottom), nchar(bottom)) == "\n") {
top <- wsplit[1]
bottom <- ""
longer <- top
newline <- TRUE
}
}
else if (length(wsplit) != 2) {
if (arg)
stop("Maximum of two lines for argument '", xname, "'.",
call. = FALSE)
else
stop("Maximum of two lines for label of column '", xname, "'.",
call. = FALSE)
}
else {
top <- wsplit[1]
bottom <- wsplit[2]
longer <- ifelse(nchar(top) > nchar(bottom), top, bottom)
newline <- TRUE
}
}
}
##
list(newline = newline, bottom = bottom, top = top, longer = longer)
}
wcalc <- function(x)
max(unit(rep(1, length(x)), "grobwidth", x))
collapsemat <- function(x) {
if (is.list(x)) {
for (i in rev(seq_len(length(x)))) {
if (is.null(x[[i]]))
x[[i]] <- NULL
}
}
##
if (is.list(x) & length(x) == 1)
x <- x[[1]]
##
if (is.matrix(x)) {
res <- as.vector(t(x))
names(res) <- rep(rownames(x), rep(ncol(x), nrow(x)))
}
else
res <- x
##
res
}
ordermat <- function(x, levs) {
o <- order(factor(names(x), levels = levs))
x[o]
}
selmat <- function(x, levs) {
o <- order(factor(names(x), levels = levs))
x[o]
}
notallNA <- function(x)
any(!is.na(x))
repl <- function(x, n1, n2)
rep(x, rep(n1, n2))
gh <- function(type.gr, rows.gr,
##
n.stud,
lower.common, lower.random, lower.predict,
subgroup, subgroup.levels,
lower.common.w, lower.random.w, lower.predict.w,
##
common, random, overall,
prediction, overall.hetstat,
study.results,
##
spacing,
##
xlab, xlab.add, label.right, label.left, bottom.lr,
##
prediction.subgroup, subgroup.hetstat,
test.overall.common, test.overall.random,
test.subgroup.common, test.subgroup.random,
##
text.addline1, text.addline2,
text.details, text.rob,
##
addrow, addrow.overall,
addrow.subgroups, addrows.below.overall,
##
cols, labs,
text.w.common, text.w.random) {
##
## (1) Determine height per row
##
if (grepl("bmp$", tolower(type.gr)) ||
grepl("jpg$", tolower(type.gr)) ||
grepl("jpeg$", tolower(type.gr)) ||
grepl("png$", tolower(type.gr)) ||
grepl("tif$", tolower(type.gr)) ||
grepl("tiff$", tolower(type.gr)))
height_per_row <- 480 / 33
else
height_per_row <- 7 / 35
##
## (2) Column labels
##
labs <- unlist(labs)
if (any(grepl("col.w.common", cols)))
labs <- c(labs, text.w.common)
if (any(grepl("col.w.random", cols)))
labs <- c(labs, text.w.random)
##
rows_column_labels <- 1 + 1L * any(grepl("\n", unlist(labs))) + 1L * addrow
##
## (2) Study results
##
rows_studies <-
if (!study.results)
0
else
n.stud
##
## (3) Meta-analysis results
##
if (overall)
rows_overall <-
1L * addrow.overall +
1L * common * length(lower.common) +
1L * random * length(lower.random) +
1L * prediction * length(lower.predict)
else
rows_overall <- 1L * addrow.overall
##
## (4) Text below meta-analysis results
##
n.details <- sum(text.details != "")
n.rob <- sum(text.rob != "")
rows_below_overall_labels <- addrows.below.overall + overall.hetstat +
test.overall.common + test.overall.random +
test.subgroup.common + test.subgroup.random +
1L * (text.addline1 != "") +
1L * (text.addline2 != "") +
n.details + 1L * (n.details > 0) +
n.rob + 1L * (n.rob > 0) +
1L * (n.details > 0 | n.rob > 0) +
2L * (n.details == 0 & n.rob == 0)
## + 0.25
##
## (5) Information below confidence interval plot
##
rows_xlab <-
if (xlab == "")
0
else
2
##
rows_xlab.add <-
if (xlab.add == "")
0
else
2
##
rows_xlab <- rows_xlab + rows_xlab.add
##
if (!bottom.lr) {
rows_label.left <- 0
rows_label.right <- 0
}
else {
rows_label.left <-
if (is.null(label.left) || label.left == "")
0
else if (!grepl("\n", label.left))
2
else
4
##
rows_label.right <-
if (is.null(label.right) || label.right == "")
0
else if (!grepl("\n", label.right))
2
else
4
}
##
rows_label <- max(c(rows_label.left, rows_label.right))
##
rows_below_forest <- 2 + rows_xlab + rows_label
##
## (6) Subgroup results
##
if (is.null(subgroup))
rows_subgroups <- 0
else {
n.subgr <- length(subgroup.levels)
##
rows_subgroups_common <- common * n.subgr
rows_subgroups_random <- random * n.subgr
##
rows_subgroups_predict <-
if (is.vector(prediction.subgroup))
sum(prediction.subgroup)
else
prediction.subgroup * n.subgr
##
rows_subgroups_hetstat <-
if (length(subgroup.hetstat) > 1)
sum(subgroup.hetstat)
else
subgroup.hetstat * n.subgr
##
if (is.matrix(lower.common.w))
rows_subgroups_common <- rows_subgroups_common * nrow(lower.common.w)
##
if (is.matrix(lower.random.w))
rows_subgroups_random <- rows_subgroups_random * nrow(lower.random.w)
##
if (is.matrix(lower.predict.w))
rows_subgroups_predict <- rows_subgroups_predict * nrow(lower.predict.w)
##
rows_subgroups <-
n.subgr + # Labels
addrow.subgroups * (n.subgr - 1) +
rows_subgroups_common + rows_subgroups_random +
rows_subgroups_predict + rows_subgroups_hetstat
}
##
## (7) Determine total height of graphics device
##
total_rows <-
rows_column_labels +
rows_studies +
rows_overall +
max(rows_below_overall_labels, rows_below_forest) +
rows_subgroups +
rows.gr +
1
##
total_height <- height_per_row * spacing * total_rows
res <- data.frame(total_height, total_rows, height_per_row, spacing)
##
res
}
show_subgroup_results <- function(x, n, lower, upper) {
if (length(x) == 1) {
if (is.matrix(lower))
return(x &
apply(lower, 1, notallNA) &
apply(upper, 1, notallNA))
else
return(rep(x & notallNA(lower) & notallNA(upper), n))
}
else {
chklength(x, n,
text = paste0("Length of argument '",
deparse(substitute(x)),
"' must be equal to 1 or number of subgroups."))
return(x)
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.