Hi All,

I have pulled the following function (fplot) from the internet, and unfortunately I do not see an author to whom I can give credit.  It used grid graphics and relies mostly on package rmeta by Thomas Lumley.  I am trying to make the font smaller in my labeltext, but don’t see any references to font size in the code.  Digitize changes the number size on the x-axis, but don’t see a corresponding way of making the labeling size smaller.

Using R 3.0.2

Any suggestions appreciated.

Gerard Smits

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, boxsize, 
    ...) 

{
    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

    if (!is.null(boxsize))
         info <- rep(boxsize, length = length(info))

    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()
}
 


# my code starts here:


labletext<-cbind(c("",
                   "All Available Eyes (n=194)",
                   "", 
                   "Month 12 Visit Timing          (p=0.8312*)",
                   "   Before Window (n=12)",
                   "   In Window (n=146)", 
                   "   After Window (n=36)", 
                   "", 
                   "Major Protocol Deviation     (p=0.5189*)", 
                   "   None (n=149)",
                   "   Present (n=45)",
                   "",
                   "Protocol Approved Device    (p=0.5131*)", 
                   "   Yes (n=62)",
                   "   No (n=132)",
                   "",
                   "ITT Imputations", 
                   "   Multiple Imputation (n=210)",
                   "   LOCF (n=210)",
                   "   Worst Case (n=210)"
                   ),

                 c("",
                   " 0.0309 [-0.0488  0.1106]",
                   "","",
                   "","","","","",
                   "","","","","",
                   "","","","","",
                   "",""))


m <- c(NA,  0.0309, NA, NA,  0.1591,  0.0286,  0.0153, NA, NA,  0.0529, -0.0441, NA, NA,  0.0364,  0.0455,  NA, NA,  0.0123,  -0.0667, -0.1429)
l <- c(NA, -0.0488, NA, NA, -0.0524, -0.0548, -0.1372, NA, NA, -0.0251, -0.2106, NA, NA, -0.0529, -0.0605,  NA, NA, -0.0670,  -0.2333, -0.2576)
u <- c(NA,  0.1106, NA, NA,  0.3706,  0.1120,  0.1678, NA, NA,  0.1309,  0.1224, NA, NA,  0.1257,  0.1515,  NA, NA,  0.0916,   0.1000, -0.0282)


fplot(labletext, m, l ,u, zero=0, is.summary=c(rep(FALSE,3)), clip=c(0,8), xlog=FALSE,
      xlow=-0.5, xhigh=+0.5, xlab=“\nVariable Tested", digitsize=0.9, graphwidth = unit(3,"inches"), 
      boxsize=.6,
      col=meta.colors(box="blue",line="blue", summary="red"))

grid.text("Forest Plot of xxx\nwith Point Estimate and 95% CI", x = .5, y = .9, gp=gpar(fontsize=15))
grid.text("* Test of heterogeneity of subgroups using General Estimating Equation model.", x = .38, y = .07, gp=gpar(fontsize=10))


	[[alternative HTML version deleted]]

