[R] changing font size in Forest plot code.

Gerard Smits g_smits at verizon.net
Mon Jan 20 01:12:23 CET 2014


Hi David,

That worked perfectly.  I had tried something like that, but obviously messed up the change.

Thanks for your help. Much appreciated.

Gerard


On Jan 19, 2014, at 2:16 PM, David Winsemius <dwinsemius at comcast.net> wrote:

> 
> 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]]
>> 
>> ______________________________________________
>> 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.
> 
> David Winsemius
> Alameda, CA, USA
> 




More information about the R-help mailing list