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@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.

Reply via email to