changing font size in Forest plot code.

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.

On Jan 19, 2014, at 1:13 PM, Gerard Smits wrote:

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.

Wouldn't it just be needed to specify grid parameters (as exemplified several other places in that code)  in the code where 'labels' are created?

...
labels[[j]][[i]] <- textGrob(labeltext[i, j], x = x, 
               just = just, gp = gpar(fontsize=8, fontface = if (is.summary[i]) "bold"
               else "plain", col = rep(col$text, length = nr)[i]))
...

Seems to succeed (once the errant and quite strange double comma character '?' is removed and replaced with a proper double quote.) If you are doing this on a word processor, then you should convert to a programming text editor.

-- 
David.

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]]

David Winsemius
Alameda, CA, USA

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]]