[R] Forestplot () box size question
David Winsemius
dwinsemius at comcast.net
Sat Mar 21 18:32:04 CET 2009
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.
More information about the R-help
mailing list