The R Project SVN R

library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

################################################################################
## Gradients

## Simple linear gradient on grob
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
HersheyLabel("default linear gradient
black bottom-left to white top-right")

## Test linearGradient() arguments
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient(c("red", "yellow", "red"),
                                      c(0, .5, 1),
                                      x1=.5, y1=unit(1, "in"), 
                                      x2=.5, y2=1,
                                      extend="none")))
HersheyLabel("vertical linear gradient
1 inch from bottom
red-yellow-red")

## Gradient relative to grob
grid.newpage()
grid.rect(width=.5, height=.5,
          gp=gpar(fill=linearGradient()))
HersheyLabel("gradient on rect
black bottom-left to white top-right OF RECT")

## Gradient on viewport
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("default linear gradient on viewport
black bottom-left to white top-right")

## Gradient relative to viewport
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect(width=.5, height=.5)
HersheyLabel("linear gradient on viewport
viewport whole page
rect half height/width
darker grey (not black) bottom-left OF RECT
lighter grey (not white) top-right OF RECT")

grid.newpage()
pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("linear gradient on viewport
viewport half height/width
rect whole viewport
black bottom-left to white top-right OF RECT")

## Inherited gradient on viewport
## (should be relative to first, larger viewport)
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
pushViewport(viewport(width=.5, height=.5))
grid.rect()
HersheyLabel("gradient on viewport
viewport whole page
nested viewport half height/width
rect whole viewport
darker grey (not black) bottom-left OF RECT
lighter grey (not white) top-right OF RECT")

## Restore of gradient (just like any other gpar)
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect(x=.2, width=.2, height=.5)
pushViewport(viewport(gp=gpar(fill="green")))
grid.rect(x=.5, width=.2, height=.5)
popViewport()
grid.rect(x=.8, width=.2, height=.5)
HersheyLabel("gradient on viewport
viewport whole page
rect left third (gradient from whole page)
nested viewport whole page
nested viewport green fill
rect centre (green)
pop to first viewport
rect right third (gradient from whole page)")

## Translucent gradient
grid.newpage()
grid.text("Reveal", gp=gpar(fontfamily="HersheySans",
                            fontface="bold", cex=3))
grid.rect(gp=gpar(fill=linearGradient(c("white", "transparent"),
                                      x1=.4, x2=.6, y1=.5, y2=.5)))
HersheyLabel("gradient from white to transparent
over text", y=.1)

## Radial gradient
grid.newpage()
grid.rect(gp=gpar(fill=radialGradient()))
HersheyLabel("default radial gradient
black centre to white radius", y=.1)

## Test radialGradient() arguments
grid.newpage()
grid.rect(gp=gpar(fill=radialGradient(c("white", "black"),
                                      cx1=.8, cy1=.8)))    
HersheyLabel("radial gradient
white to black
start centre top-right")

## Gradient on a gTree
grid.newpage()
grid.draw(gTree(children=gList(rectGrob(gp=gpar(fill=linearGradient())))))
HersheyLabel("gTree with rect child
gradient on rect
black bottom-left to white top-right")

grid.newpage()
grid.draw(gTree(children=gList(rectGrob()), gp=gpar(fill=linearGradient())))
HersheyLabel("gTree with rect child
gradient on gTree
black bottom-left to white top-right")

## Rotated gradient
grid.newpage()
pushViewport(viewport(width=.5, height=.5, angle=45,
                      gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("rotated gradient
black bottom-left to white top-right OF RECT")

######################################
## Tests of replaying graphics engine display list

## Resize graphics device
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
HersheyLabel("default gradient
(for resizing)
black bottom-left to white top-right")

grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("gradient on viewport
(for resizing)
black bottom-left to white top-right")

## Copy to new graphics device
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
x <- recordPlot()
HersheyLabel("default gradient
for recordPlot()
black bottom-left to white top-right")
replayPlot(x)
HersheyLabel("default gradient
from replayPlot()
black bottom-left to white top-right")
## (Resize that as well if you like)

grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect()
x <- recordPlot()
HersheyLabel("gradient on viewport
for recordPlot()
black bottom-left to white top-right")
replayPlot(x)
HersheyLabel("gradient on viewport
from replayPlot()
black bottom-left to white top-right")

## Replay on new device with gradient already defined
## (watch out for recorded grob using existing gradient)
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
x <- recordPlot()
HersheyLabel("default gradient
for recordPlot()
black bottom-left to white top-right")
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient(c("white", "red"))))
HersheyLabel("new rect with new gradient")
replayPlot(x)
HersheyLabel("default gradient
from replayPlot()
AFTER white-red gradient
(should be default gradient)")

## Similar to previous, except involving viewports
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect()
x <- recordPlot()
HersheyLabel("gradient on viewport
for recordPlot()")
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient(c("white", "red")))))
grid.rect()
HersheyLabel("new viewport with new gradient")
replayPlot(x)
HersheyLabel("gradient on viewport
from replayPlot()
AFTER white-red gradient
(should be default gradient)")

######################################
## Test of 'grid' display list

grid.newpage()
grid.rect(name="r")
HersheyLabel("empty rect")
grid.edit("r", gp=gpar(fill=linearGradient()))
HersheyLabel("edited rect
to add gradient", y=.1)

grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
HersheyLabel("rect with gradient
(for grab)")
x <- grid.grab()
grid.newpage()
grid.draw(x)
HersheyLabel("default gradient
from grid.grab()")

grid.newpage()
pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("gradient on viewport
viewport half height/width
for grid.grab")
x <- grid.grab()
grid.newpage()
grid.draw(x)
HersheyLabel("gradient on viewport
viewport half height/width
from grid.grab")

######################################
## Tests of "efficiency"
## (are patterns being resolved only as necessary)

## 
trace(grid:::resolveFill.GridPattern, print=FALSE,
      function(...) cat("*** RESOLVE:  Viewport pattern resolved\n"))
trace(grid:::resolveFill.GridGrobPattern, print=FALSE,
      function(...) cat("*** RESOLVE:  Grob pattern resolved\n"))

## ONCE for rect grob
traceHead <- "ONE resolve for rect grob with gradient"
grid.newpage()
traceOutput <- capture.output(grid.rect(gp=gpar(fill=linearGradient())))
HersheyLabel("default gradient
for tracing", y=.9)
HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))


## ONCE for multiple rects from single grob
traceHead <- "ONE resolve for multiple rects from rect grob with gradient"
grid.newpage()
traceOutput <- capture.output(grid.rect(x=1:5/6, y=1:5/6, width=1/8, height=1/8,
                                        gp=gpar(fill=linearGradient())))
HersheyLabel("gradient on five rects
for tracing", y=.9)
HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))

## ONCE for viewport with rect
traceHead <- "ONE resolve for rect grob in viewport with gradient"
grid.newpage()
traceOutput <- capture.output({
    pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
    grid.rect()
})
HersheyLabel("gradient on viewport
viewport half height/width
for tracing", y=.8)
HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))

## ONCE for viewport with rect, revisiting multiple times
traceHead <- "ONE resolve for rect grob in viewport with gradient\nplus nested viewport\nplus viewport revisited"
grid.newpage()
traceOutput <- capture.output({
    pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient()),
                          name="vp"))
    grid.rect(gp=gpar(lwd=8))
    pushViewport(viewport(width=.5, height=.5))
    grid.rect()
    upViewport()
    grid.rect(gp=gpar(col="red", lwd=4))
    upViewport()
    downViewport("vp")
    grid.rect(gp=gpar(col="blue", lwd=2))
})
HersheyLabel("gradient on viewport
viewport half width/height
rect (thick black border)
nested viewport (inherits gradient)
rect (medium red border)
navigate to original viewport
rect (thin blue border)", y=.9)
HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))

untrace(grid:::resolveFill.GridPattern)
untrace(grid:::resolveFill.GridGrobPattern)

################################################################################
## Grob-based patterns

## Simple circle grob as pattern in rect
grid.newpage()
grid.rect(gp=gpar(fill=pattern(circleGrob(gp=gpar(fill="grey")))))
HersheyLabel("single grey filled circle pattern")

## Multiple circles as pattern in rect
grid.newpage()
pat <- circleGrob(1:3/4, r=unit(1, "cm"))
grid.rect(gp=gpar(fill=pattern(pat)))
HersheyLabel("three unfilled circles pattern")

## Pattern on rect scales with rect
grid.newpage()
grid.rect(width=.5, height=.8, gp=gpar(fill=pattern(pat)))
HersheyLabel("pattern on rect scales with rect")

## Pattern on viewport
grid.newpage()
pushViewport(viewport(gp=gpar(fill=pattern(pat))))
grid.rect()
HersheyLabel("pattern on viewport
applied to rect")

## Pattern on viewport stays fixed for rect
grid.newpage()
pushViewport(viewport(gp=gpar(fill=pattern(pat))))
grid.rect(width=.5, height=.8)
HersheyLabel("pattern on viewport
applied to rect
pattern does not scale with rect")

## Patterns have colour
grid.newpage()
pat <- circleGrob(1:3/4, r=unit(1, "cm"),
                  gp=gpar(fill=c("red", "green", "blue")))
grid.rect(gp=gpar(fill=pattern(pat)))
HersheyLabel("pattern with colour")

## Pattern with gradient
grid.newpage()
pat <- circleGrob(1:3/4, r=unit(1, "cm"),
                  gp=gpar(fill=linearGradient()))
grid.rect(gp=gpar(fill=pattern(pat)))
HersheyLabel("pattern with gradient")

## Pattern with a clipping path
grid.newpage()
pat <- circleGrob(1:3/4, r=unit(1, "cm"),
                  vp=viewport(clip=rectGrob(height=unit(1, "cm"))),
                  gp=gpar(fill=linearGradient()))
grid.rect(gp=gpar(fill=pattern(pat)))
HersheyLabel("pattern with clipping path
and gradient")

## Tiling patterns
grid.newpage()
grob <- circleGrob(r=unit(2, "mm"),
                   gp=gpar(col=NA, fill="grey"))
pat <- pattern(grob,
               width=unit(5, "mm"),
               height=unit(5, "mm"),
               extend="repeat")
grid.rect(gp=gpar(fill=pat))
HersheyLabel("pattern that tiles page")

grid.newpage()
pushViewport(viewport(gp=gpar(fill=pat)))
grid.rect(width=.5)
HersheyLabel("pattern that fills viewport
but only drawn within rectangle
pattern relative to viewport")

grid.newpage()
grob <- circleGrob(x=0, y=0, r=unit(2, "mm"),
                   gp=gpar(col=NA, fill="grey"))
pat <- pattern(grob,
               x=0, y=0, 
               width=unit(5, "mm"),
               height=unit(5, "mm"),
               extend="repeat")
grid.rect(width=.5, gp=gpar(fill=pat))
HersheyLabel("pattern as big as the viewport
but only drawn within rectangle
pattern relative to rectangle
(starts at bottom left of rectangle)")

## More tests
grid.newpage()
grid.circle(gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
HersheyLabel("circle with horizontal gradient
black left to white right")

grid.newpage()
grid.polygon(c(.2, .8, .7, .5, .3),
             c(.8, .8, .2, .4, .2),
             gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
HersheyLabel("polygon with horizontal gradient
black left to white right")

grid.newpage()
grid.path(c(.2, .8, .3, .5, .7),
          c(.8, .8, .2, .4, .2),
          gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
HersheyLabel("path with horizontal gradient
black left to white right")

grid.newpage()
grid.text("Reveal", gp=gpar(fontfamily="HersheySans",
                            fontface="bold", cex=3))
grid.rect(gp=gpar(col=NA,
                  fill=radialGradient(c("white", "transparent"),
                                      r2=.3)))
HersheyLabel("text with semitransparent radial gradient
centre of text should be dissolved", y=.2)

grid.newpage()
pat <-
    pattern(circleGrob(gp=gpar(col=NA, fill="grey"),
                       vp=viewport(width=.2, height=.2,
                                   mask=rectGrob(x=c(1, 3)/4,
                                                 width=.3,
                                                 gp=gpar(fill="black")))),
            width=1/4, height=1/4,
            extend="repeat")
grid.rect(width=.5, height=.5, gp=gpar(fill=pat))
HersheyLabel("rect in centre with pattern fill
pattern is circle drawn in smaller viewport
pattern is masked by two tall thin rects
pattern repeats", y=.15)

grid.newpage()
pat1 <-
    pattern(circleGrob(r=.1, gp=gpar(col="black", fill="grey")),
            width=.2, height=.2,
            extend="repeat")
pat2 <-
    pattern(circleGrob(r=1/4, gp=gpar(col="black", fill=pat1)),
            width=1/2, height=1/2,
            extend="repeat")
grid.rect(width=.5, height=.5, gp=gpar(fill=pat2))
HersheyLabel("rect in centre with pattern fill
pattern is small circle with pattern fill
nested pattern is smaller circle (grey)
both patterns repeat", y=.15)

######################################
## Test for expanding pattern resources
grid.newpage()
for (i in 1:21) {
    grid.rect(gp=gpar(fill=linearGradient()))
    HersheyLabel(paste0("rect ", i, " with gradient
pattern released every time"))
}

grid.newpage()
for (i in 1:65) {
    pushViewport(viewport(gp=gpar(fill=linearGradient())))
    grid.rect()
    HersheyLabel(paste0("viewport ", i, " with gradient
new pattern every time"))
}

grid.newpage()
for (i in 1:21) {
    grid.rect(gp=gpar(fill=linearGradient()))
    HersheyLabel(paste0("rect ", i, " with gradient
AFTER grid.newpage()
pattern released every time"))
}

####################################
## Additional tests

## gTree with gradient fill
grid.newpage()
gt <- gTree(children=gList(circleGrob(1:2/3, r=.1)),
            gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
grid.draw(gt)
HersheyLabel("gTree with circles as children
gTree has gradient fill
gradient relative to circle bounds
(black at left to white at right)", y=.8)

## gTree with gradient fill with gTree 
grid.newpage()
gt <- gTree(children=gList(gTree(children=gList(circleGrob(1:2/3, r=.1)))),
            gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
grid.draw(gt)
HersheyLabel("gTree with gTree as child
inner gTree has circles as children
outer gTree has gradient fill
gradient relative to circle bounds
(black at left to white at right)", y=.8)

## Pattern including text
grid.newpage()
pat <- pattern(textGrob("test"),
               width=1.2*stringWidth("test"),
               height=unit(1, "lines"),
               extend="repeat")
grid.circle(r=.3, gp=gpar(fill=pat))
HersheyLabel("circle filled with pattern
pattern based on (repeating) text", y=.9)

## Text (path) filled with pattern
grid.newpage()
rects <- gTree(children=gList(rectGrob(width=unit(2, "mm"),
                                       height=unit(2, "mm"),
                                       just=c("left", "bottom"),
                                       gp=gpar(fill="black")),
                              rectGrob(width=unit(2, "mm"),
                                       height=unit(2, "mm"),
                                       just=c("right", "top"),
                                       gp=gpar(fill="black"))))
checkerBoard <- pattern(rects,
                        width=unit(4, "mm"), height=unit(4, "mm"),
                        extend="repeat")
grid.fill(textGrob("test", gp=gpar(cex=10)),
          gp=gpar(fontface="bold", fill=checkerBoard))
HersheyLabel("stroked path based on text
filled with checkerboard pattern", y=.8)
    
## Pattern including raster
grid.newpage()
rg <- rasterGrob(matrix(c(0:1, 1:0), nrow=2),
                 width=unit(1, "cm"), height=unit(1, "cm"),
                 interpolate=FALSE)
pat <- pattern(rg, 
               width=unit(1, "cm"), height=unit(1, "cm"),
               extend="repeat")
grid.circle(r=.2, gp=gpar(fill=pat))
HersheyLabel("circle filled with pattern
pattern is based on raster (checkerboard)", y=.8)

## Radial gradient where start circle and final circle overlap
grid.newpage()
x1 <- .7
y1 <- .7
r1 <- .2
x2 <- .4
y2 <- .4
r2 <- .4
grid.circle(x1, y1, r=r1, gp=gpar(col="green", fill=NA, lwd=2))
grid.circle(x2, y2, r=r2, gp=gpar(col="red", fill=NA, lwd=2))
grid.rect(gp=gpar(fill=radialGradient(rgb(0:1, 1:0, 0, .5),
                                      cx1=x1, cy1=y1, r1=r1,
                                      cx2=x2, cy2=y2, r2=r2)))
HersheyLabel("radial gradient with overlapping start and final circles
gradient is from semitransparent green
to semitransparent red
start circle is green
final circle is red")

## Text (path) filled with pattern
grid.newpage()
grid.fill(textGrob("test", gp=gpar(cex=10)),
          gp=gpar(fontface="bold", fill=linearGradient(2:3)))
HersheyLabel("stroked path based on text
filled with linear gradient", y=.8)