Hi All,
I have been able to modify the x-axis to start at zero by adding xlow
and xhigh parameters; that was pretty simple. I have been unable to
find the location of the code that would turn off the information
weighting of the box size (I have smaller randomized trials getting
less weight than a much larger non-randomized trial). The function
is forestplot() from rmeta.
Thanks for any help.
Gerard
Slightly modified working function with data and a call follows:
fplot=function (labeltext, mean, lower, upper, align = NULL,
is.summary = FALSE,
clip = c(-Inf, Inf), xlab = "", zero = 1, graphwidth =
unit(3,"inches"),
col = meta.colors(), xlog = FALSE, xticks = NULL,
xlow=0, xhigh, digitsize,
...)
{
require("grid") || stop("`grid' package not
found")
require("rmeta") || stop("`rmeta' package not
found")
drawNormalCI <- function(LL, OR, UL, size)
{
size = 0.75 * size
clipupper <- convertX(unit(UL, "native"), "npc",
valueOnly = TRUE) > 1
cliplower <- convertX(unit(LL, "native"), "npc",
valueOnly = TRUE) < 0
box <- convertX(unit(OR, "native"), "npc",
valueOnly = TRUE)
clipbox <- box < 0 || box > 1
if (clipupper || cliplower)
{
ends <- "both"
lims <- unit(c(0, 1), c("npc", "npc"))
if (!clipupper) {
ends <- "first"
lims <- unit(c(0, UL), c("npc",
"native"))
}
if (!cliplower) {
ends <- "last"
lims <- unit(c(LL, 1), c("native",
"npc"))
}
grid.lines(x = lims, y = 0.5, arrow = arrow(ends = ends,
length = unit(0.05, "inches")), gp = gpar(col =
col$lines))
if (!clipbox)
grid.rect(x = unit(OR, "native"), width = unit(size,
"snpc"), height = unit(size, "snpc"), gp
=
gpar(fill = col$box,
col = col$box))
}
else {
grid.lines(x = unit(c(LL, UL), "native"), y = 0.5,
gp = gpar(col = col$lines))
grid.rect(x = unit(OR, "native"), width = unit(size,
"snpc"), height = unit(size, "snpc"), gp =
gpar(fill
= col$box,
col = col$box))
if ((convertX(unit(OR, "native") + unit(0.5 * size,
"lines"), "native", valueOnly = TRUE) >
UL) &&
(convertX(unit(OR, "native") - unit(0.5 * size,
"lines"), "native", valueOnly = TRUE)
< LL))
grid.lines(x = unit(c(LL, UL), "native"), y = 0.5,
gp = gpar(col = col$lines))
}
}
drawSummaryCI <- function(LL, OR, UL, size) {
grid.polygon(x = unit(c(LL, OR, UL, OR), "native"), y =
unit(0.5 +
c(0, 0.5 * size, 0, -0.5 * size), "npc"), gp = gpar(fill
= col$summary,
col = col$summary))
}
plot.new()
widthcolumn <- !apply(is.na(labeltext), 1, any)
nc <- NCOL(labeltext)
labels <- vector("list", nc)
if (is.null(align))
align <- c("l", rep("r", nc - 1))
else align <- rep(align, length = nc)
nr <- NROW(labeltext)
is.summary <- rep(is.summary, length = nr)
for (j in 1:nc) {
labels[[j]] <- vector("list", nr)
for (i in 1:nr) {
if (is.na(labeltext[i, j]))
next
x <- switch(align[j], l = 0, r = 1, c = 0.5)
just <- switch(align[j], l = "left", r =
"right", c = "center")
labels[[j]][[i]] <- textGrob(labeltext[i, j], x = x,
just = just, gp = gpar(fontface = if (is.summary[i])
"bold"
else "plain", col = rep(col$text, length = nr)[i]))
}
}
colgap <- unit(3, "mm")
colwidths <- unit.c(max(unit(rep(1, sum(widthcolumn)),
"grobwidth",
labels[[1]][widthcolumn])), colgap)
if (nc > 1) {
for (i in 2:nc) colwidths <- unit.c(colwidths, max(unit(rep(1,
sum(widthcolumn)), "grobwidth",
labels[[i]][widthcolumn])),
colgap)
}
colwidths <- unit.c(colwidths, graphwidth)
pushViewport(viewport(layout = grid.layout(nr + 1, nc * 2 +
1, widths = colwidths, heights = unit(c(rep(1, nr), 0.5),
"lines"))))
cwidth <- (upper - lower)
#xrange <- c(max(min(lower, na.rm = TRUE), clip[1]),
min(max(upper, na.rm = TRUE), clip[2]))
xrange <- c(xlow,xhigh)
info <- 1/cwidth
info <- info/max(info[!is.summary], na.rm = TRUE)
info[is.summary] <- 1
for (j in 1:nc) {
for (i in 1:nr) {
if (!is.null(labels[[j]][[i]])) {
pushViewport(viewport(layout.pos.row = i,
layout.pos.col = 2 *
j - 1))
grid.draw(labels[[j]][[i]])
popViewport()
}
}
}
pushViewport(viewport(layout.pos.col = 2 * nc + 1, xscale = xrange))
grid.lines(x = unit(zero, "native"), y = 0:1, gp = gpar(col =
col$zero))
if (xlog) {
if (is.null(xticks)) {
ticks <- pretty(exp(xrange))
ticks <- ticks[ticks > 0]
}
else {
ticks <- xticks
}
if (length(ticks)) {
if (min(lower, na.rm = TRUE) < clip[1])
ticks <- c(exp(clip[1]), ticks)
if (max(upper, na.rm = TRUE) > clip[2])
ticks <- c(ticks, exp(clip[2]))
xax <- xaxisGrob(gp = gpar(cex = digitsize, col = col$axes),
at = log(ticks), name = "xax")
xax1 <- editGrob(xax, gPath("labels"), label =
format(ticks, digits = 2))
grid.draw(xax1)
}
}
else {
if (is.null(xticks)) {
grid.xaxis(gp = gpar(cex = digitsize, col = col$axes))
}
else if (length(xticks)) {
grid.xaxis(at = xticks, gp = gpar(cex = 0.6, col = col$axes))
}
}
grid.text(xlab, y = unit(-2, "lines"), gp = gpar(col = col$axes))
popViewport()
for (i in 1:nr) {
if (is.na(mean[i]))
next
pushViewport(viewport(layout.pos.row = i, layout.pos.col = 2 *
nc + 1, xscale = xrange))
if (is.summary[i])
drawSummaryCI(lower[i], mean[i], upper[i], info[i])
else drawNormalCI(lower[i], mean[i], upper[i], info[i])
popViewport()
}
popViewport()
}
tabletext<-cbind(c("","Randomized Trials"," Study
1", " Study 2",
" Combined", "", "Study 3 ", "
Comorbid"," Non-Comorbid",""),
c("","","","","","","","","",""))
m <- c(NA, NA, 2.32 , 2.55 , 2.41 , NA, NA, 2.04 , 1.62 , NA)
l <- c(NA, NA, 1.1746, 1.1495, 1.4377, NA, NA, 1.609, 1.339, NA)
u <- c(NA, NA, 4.5919, 5.6364, 4.0490, NA, NA, 2.592, 1.952, NA)
fplot(tabletext, m, l ,u, zero=1, is.summary=c(rep(FALSE,3)),
clip=c(0,8), xlog=FALSE,
xlow=0, xhigh=6, xlab="Odds Ratio",digitsize=0.9,graphwidth =
unit(4,"inches"),
col=meta.colors(box="black",line="black",
summary="black"))
[[alternative HTML version deleted]]
If you look at the original code (or at the help page), you should see
a boxsize parameter. If you set that to 1 in the call you get boxes
all the same size. Presumably that could be modified to suit your
needs.
You seem to have removed that section of the code. The two lines with
that parameter are:
if (!is.null(boxsize))
info <- rep(boxsize, length = length(info))
--
David Winsemius, MD
Heritage Laboratories
West Hartford, CT
On Mar 21, 2009, at 1:03 PM, Gerard Smits wrote:
> Hi All,
>
> I have been able to modify the x-axis to start at zero by adding xlow
> and xhigh parameters; that was pretty simple. I have been unable to
> find the location of the code that would turn off the information
> weighting of the box size (I have smaller randomized trials getting
> less weight than a much larger non-randomized trial). The function
> is forestplot() from rmeta.
>
> Thanks for any help.
>
> Gerard
>
> Slightly modified working function with data and a call follows:
>
>
> fplot=function (labeltext, mean, lower, upper, align = NULL,
> is.summary = FALSE,
> clip = c(-Inf, Inf), xlab = "", zero = 1, graphwidth =
> unit(3,"inches"),
> col = meta.colors(), xlog = FALSE, xticks = NULL,
> xlow=0, xhigh, digitsize,
> ...)
> {
> require("grid") || stop("`grid' package not
found")
> require("rmeta") || stop("`rmeta' package not
found")
>
> drawNormalCI <- function(LL, OR, UL, size)
> {
>
> size = 0.75 * size
> clipupper <- convertX(unit(UL, "native"),
"npc", valueOnly =
> TRUE) > 1
> cliplower <- convertX(unit(LL, "native"),
"npc", valueOnly =
> TRUE) < 0
> box <- convertX(unit(OR, "native"), "npc",
valueOnly = TRUE)
> clipbox <- box < 0 || box > 1
>
> if (clipupper || cliplower)
> {
> ends <- "both"
> lims <- unit(c(0, 1), c("npc", "npc"))
> if (!clipupper) {
> ends <- "first"
> lims <- unit(c(0, UL), c("npc",
"native"))
> }
> if (!cliplower) {
> ends <- "last"
> lims <- unit(c(LL, 1), c("native",
"npc"))
> }
> grid.lines(x = lims, y = 0.5, arrow = arrow(ends = ends,
> length = unit(0.05, "inches")), gp = gpar(col =
col
> $lines))
>
> if (!clipbox)
> grid.rect(x = unit(OR, "native"), width =
unit(size,
> "snpc"), height = unit(size, "snpc"),
gp > gpar(fill = col$box,
> col = col$box))
> }
> else {
> grid.lines(x = unit(c(LL, UL), "native"), y = 0.5,
> gp = gpar(col = col$lines))
> grid.rect(x = unit(OR, "native"), width = unit(size,
> "snpc"), height = unit(size, "snpc"),
gp = gpar(fill
> = col$box,
> col = col$box))
> if ((convertX(unit(OR, "native") + unit(0.5 * size,
> "lines"), "native", valueOnly = TRUE)
> UL) &&
> (convertX(unit(OR, "native") - unit(0.5 * size,
> "lines"), "native", valueOnly = TRUE)
< LL))
> grid.lines(x = unit(c(LL, UL), "native"), y =
0.5,
> gp = gpar(col = col$lines))
> }
>
> }
>
> drawSummaryCI <- function(LL, OR, UL, size) {
> grid.polygon(x = unit(c(LL, OR, UL, OR), "native"), y =
> unit(0.5 +
> c(0, 0.5 * size, 0, -0.5 * size), "npc"), gp =
gpar(fill
> = col$summary,
> col = col$summary))
> }
>
> plot.new()
> widthcolumn <- !apply(is.na(labeltext), 1, any)
> nc <- NCOL(labeltext)
> labels <- vector("list", nc)
> if (is.null(align))
> align <- c("l", rep("r", nc - 1))
> else align <- rep(align, length = nc)
> nr <- NROW(labeltext)
> is.summary <- rep(is.summary, length = nr)
> for (j in 1:nc) {
> labels[[j]] <- vector("list", nr)
> for (i in 1:nr) {
> if (is.na(labeltext[i, j]))
> next
> x <- switch(align[j], l = 0, r = 1, c = 0.5)
> just <- switch(align[j], l = "left", r =
"right", c =
> "center")
> labels[[j]][[i]] <- textGrob(labeltext[i, j], x = x,
> just = just, gp = gpar(fontface = if (is.summary[i])
> "bold"
> else "plain", col = rep(col$text, length =
nr)[i]))
> }
> }
> colgap <- unit(3, "mm")
> colwidths <- unit.c(max(unit(rep(1, sum(widthcolumn)),
> "grobwidth",
> labels[[1]][widthcolumn])), colgap)
> if (nc > 1) {
> for (i in 2:nc) colwidths <- unit.c(colwidths, max(unit(rep(1,
> sum(widthcolumn)), "grobwidth", labels[[i]]
> [widthcolumn])),
> colgap)
> }
> colwidths <- unit.c(colwidths, graphwidth)
> pushViewport(viewport(layout = grid.layout(nr + 1, nc * 2 +
> 1, widths = colwidths, heights = unit(c(rep(1, nr), 0.5),
> "lines"))))
> cwidth <- (upper - lower)
>
> #xrange <- c(max(min(lower, na.rm = TRUE), clip[1]),
> min(max(upper, na.rm = TRUE), clip[2]))
> xrange <- c(xlow,xhigh)
>
> info <- 1/cwidth
> info <- info/max(info[!is.summary], na.rm = TRUE)
> info[is.summary] <- 1
>
> for (j in 1:nc) {
> for (i in 1:nr) {
> if (!is.null(labels[[j]][[i]])) {
> pushViewport(viewport(layout.pos.row = i,
> layout.pos.col = 2 *
> j - 1))
> grid.draw(labels[[j]][[i]])
> popViewport()
> }
> }
> }
>
> pushViewport(viewport(layout.pos.col = 2 * nc + 1, xscale =
> xrange))
> grid.lines(x = unit(zero, "native"), y = 0:1, gp = gpar(col =
col
> $zero))
> if (xlog) {
> if (is.null(xticks)) {
> ticks <- pretty(exp(xrange))
> ticks <- ticks[ticks > 0]
> }
> else {
> ticks <- xticks
> }
> if (length(ticks)) {
> if (min(lower, na.rm = TRUE) < clip[1])
> ticks <- c(exp(clip[1]), ticks)
> if (max(upper, na.rm = TRUE) > clip[2])
> ticks <- c(ticks, exp(clip[2]))
> xax <- xaxisGrob(gp = gpar(cex = digitsize, col = col
> $axes),
> at = log(ticks), name = "xax")
> xax1 <- editGrob(xax, gPath("labels"), label >
format(ticks, digits = 2))
> grid.draw(xax1)
> }
> }
> else {
> if (is.null(xticks)) {
> grid.xaxis(gp = gpar(cex = digitsize, col = col$axes))
> }
> else if (length(xticks)) {
> grid.xaxis(at = xticks, gp = gpar(cex = 0.6, col = col
> $axes))
> }
> }
>
> grid.text(xlab, y = unit(-2, "lines"), gp = gpar(col =
col$axes))
> popViewport()
> for (i in 1:nr) {
> if (is.na(mean[i]))
> next
> pushViewport(viewport(layout.pos.row = i, layout.pos.col = 2 *
> nc + 1, xscale = xrange))
> if (is.summary[i])
> drawSummaryCI(lower[i], mean[i], upper[i], info[i])
> else drawNormalCI(lower[i], mean[i], upper[i], info[i])
> popViewport()
> }
> popViewport()
> }
>
>
> tabletext<-cbind(c("","Randomized Trials","
Study 1", " Study 2",
> " Combined", "", "Study 3 ", "
Comorbid"," Non-Comorbid",""),
>
c("","","","","","","","","",""))
>
> m <- c(NA, NA, 2.32 , 2.55 , 2.41 , NA, NA, 2.04 , 1.62 , NA)
> l <- c(NA, NA, 1.1746, 1.1495, 1.4377, NA, NA, 1.609, 1.339, NA)
> u <- c(NA, NA, 4.5919, 5.6364, 4.0490, NA, NA, 2.592, 1.952, NA)
>
>
> fplot(tabletext, m, l ,u, zero=1, is.summary=c(rep(FALSE,3)),
> clip=c(0,8), xlog=FALSE,
> xlow=0, xhigh=6, xlab="Odds Ratio",digitsize=0.9,graphwidth
> unit(4,"inches"),
> col=meta.colors(box="black",line="black",
summary="black"))
>
>
> [[alternative HTML version deleted]]
>
> ______________________________________________
> R-help at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-help
> PLEASE do read the posting guide
http://www.R-project.org/posting-guide.html
> and provide commented, minimal, self-contained, reproducible code.