[R] changing font size in Forest plot code.
Michael Dewey
info at aghmed.fsnet.co.uk
Mon Jan 20 13:04:40 CET 2014
At 21:13 19/01/2014, 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.
Dear Gerard
Unless you are particularly wedded to using rmeta and/or grid
graphics you could always try one of the other packages from CRAN
which provide customisable forest plots like metafor or meta.
Incidentally I am not sure whether the upper case F in your subject
line is deliberate but the story that the plots are named after an
Oxford cancer researcher named Forest is believed to be apocryphal
and it is their supposed resemblance to a collection of trees which
is the source. And, no, they do not remind me of trees either ...
> 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]]
Michael Dewey
info at aghmed.fsnet.co.uk
http://www.aghmed.fsnet.co.uk/home.html
More information about the R-help
mailing list