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.
