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