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.