1
2library(grid)
3
4HersheyLabel <- function(x, y=unit(.5, "npc")) {
5    lines <- strsplit(x, "\n")[[1]]
6    if (!is.unit(y))
7        y <- unit(y, "npc")
8    n <- length(lines)
9    if (n > 1) {
10        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
11    }
12    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
13}
14
15################################################################################
16## Gradients
17
18## Simple linear gradient on grob
19grid.newpage()
20grid.rect(gp=gpar(fill=linearGradient()))
21HersheyLabel("default linear gradient
22black bottom-left to white top-right")
23
24## Test linearGradient() arguments
25grid.newpage()
26grid.rect(gp=gpar(fill=linearGradient(c("red", "yellow", "red"),
27                                      c(0, .5, 1),
28                                      x1=.5, y1=unit(1, "in"),
29                                      x2=.5, y2=1,
30                                      extend="none")))
31HersheyLabel("vertical linear gradient
321 inch from bottom
33red-yellow-red")
34
35## Gradient relative to grob
36grid.newpage()
37grid.rect(width=.5, height=.5,
38          gp=gpar(fill=linearGradient()))
39HersheyLabel("gradient on rect
40black bottom-left to white top-right OF RECT")
41
42## Gradient on viewport
43grid.newpage()
44pushViewport(viewport(gp=gpar(fill=linearGradient())))
45grid.rect()
46HersheyLabel("default linear gradient on viewport
47black bottom-left to white top-right")
48
49## Gradient relative to viewport
50grid.newpage()
51pushViewport(viewport(gp=gpar(fill=linearGradient())))
52grid.rect(width=.5, height=.5)
53HersheyLabel("linear gradient on viewport
54viewport whole page
55rect half height/width
56darker grey (not black) bottom-left OF RECT
57lighter grey (not white) top-right OF RECT")
58
59grid.newpage()
60pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
61grid.rect()
62HersheyLabel("linear gradient on viewport
63viewport half height/width
64rect whole viewport
65black bottom-left to white top-right OF RECT")
66
67## Inherited gradient on viewport
68## (should be relative to first, larger viewport)
69grid.newpage()
70pushViewport(viewport(gp=gpar(fill=linearGradient())))
71pushViewport(viewport(width=.5, height=.5))
72grid.rect()
73HersheyLabel("gradient on viewport
74viewport whole page
75nested viewport half height/width
76rect whole viewport
77darker grey (not black) bottom-left OF RECT
78lighter grey (not white) top-right OF RECT")
79
80## Restore of gradient (just like any other gpar)
81grid.newpage()
82pushViewport(viewport(gp=gpar(fill=linearGradient())))
83grid.rect(x=.2, width=.2, height=.5)
84pushViewport(viewport(gp=gpar(fill="green")))
85grid.rect(x=.5, width=.2, height=.5)
86popViewport()
87grid.rect(x=.8, width=.2, height=.5)
88HersheyLabel("gradient on viewport
89viewport whole page
90rect left third (gradient from whole page)
91nested viewport whole page
92nested viewport green fill
93rect centre (green)
94pop to first viewport
95rect right third (gradient from whole page)")
96
97## Translucent gradient
98grid.newpage()
99grid.text("Reveal", gp=gpar(fontfamily="HersheySans",
100                            fontface="bold", cex=3))
101grid.rect(gp=gpar(fill=linearGradient(c("white", "transparent"),
102                                      x1=.4, x2=.6, y1=.5, y2=.5)))
103HersheyLabel("gradient from white to transparent
104over text", y=.1)
105
106## Radial gradient
107grid.newpage()
108grid.rect(gp=gpar(fill=radialGradient()))
109HersheyLabel("default radial gradient
110black centre to white radius", y=.1)
111
112## Test radialGradient() arguments
113grid.newpage()
114grid.rect(gp=gpar(fill=radialGradient(c("white", "black"),
115                                      cx1=.8, cy1=.8)))
116HersheyLabel("radial gradient
117white to black
118start centre top-right")
119
120## Gradient on a gTree
121grid.newpage()
122grid.draw(gTree(children=gList(rectGrob(gp=gpar(fill=linearGradient())))))
123HersheyLabel("gTree with rect child
124gradient on rect
125black bottom-left to white top-right")
126
127grid.newpage()
128grid.draw(gTree(children=gList(rectGrob()), gp=gpar(fill=linearGradient())))
129HersheyLabel("gTree with rect child
130gradient on gTree
131black bottom-left to white top-right")
132
133## Rotated gradient
134grid.newpage()
135pushViewport(viewport(width=.5, height=.5, angle=45,
136                      gp=gpar(fill=linearGradient())))
137grid.rect()
138HersheyLabel("rotated gradient
139black bottom-left to white top-right OF RECT")
140
141######################################
142## Tests of replaying graphics engine display list
143
144## Resize graphics device
145grid.newpage()
146grid.rect(gp=gpar(fill=linearGradient()))
147HersheyLabel("default gradient
148(for resizing)
149black bottom-left to white top-right")
150
151grid.newpage()
152pushViewport(viewport(gp=gpar(fill=linearGradient())))
153grid.rect()
154HersheyLabel("gradient on viewport
155(for resizing)
156black bottom-left to white top-right")
157
158## Copy to new graphics device
159grid.newpage()
160grid.rect(gp=gpar(fill=linearGradient()))
161x <- recordPlot()
162HersheyLabel("default gradient
163for recordPlot()
164black bottom-left to white top-right")
165replayPlot(x)
166HersheyLabel("default gradient
167from replayPlot()
168black bottom-left to white top-right")
169## (Resize that as well if you like)
170
171grid.newpage()
172pushViewport(viewport(gp=gpar(fill=linearGradient())))
173grid.rect()
174x <- recordPlot()
175HersheyLabel("gradient on viewport
176for recordPlot()
177black bottom-left to white top-right")
178replayPlot(x)
179HersheyLabel("gradient on viewport
180from replayPlot()
181black bottom-left to white top-right")
182
183## Replay on new device with gradient already defined
184## (watch out for recorded grob using existing gradient)
185grid.newpage()
186grid.rect(gp=gpar(fill=linearGradient()))
187x <- recordPlot()
188HersheyLabel("default gradient
189for recordPlot()
190black bottom-left to white top-right")
191grid.newpage()
192grid.rect(gp=gpar(fill=linearGradient(c("white", "red"))))
193HersheyLabel("new rect with new gradient")
194replayPlot(x)
195HersheyLabel("default gradient
196from replayPlot()
197AFTER white-red gradient
198(should be default gradient)")
199
200## Similar to previous, except involving viewports
201grid.newpage()
202pushViewport(viewport(gp=gpar(fill=linearGradient())))
203grid.rect()
204x <- recordPlot()
205HersheyLabel("gradient on viewport
206for recordPlot()")
207grid.newpage()
208pushViewport(viewport(gp=gpar(fill=linearGradient(c("white", "red")))))
209grid.rect()
210HersheyLabel("new viewport with new gradient")
211replayPlot(x)
212HersheyLabel("gradient on viewport
213from replayPlot()
214AFTER white-red gradient
215(should be default gradient)")
216
217######################################
218## Test of 'grid' display list
219
220grid.newpage()
221grid.rect(name="r")
222HersheyLabel("empty rect")
223grid.edit("r", gp=gpar(fill=linearGradient()))
224HersheyLabel("edited rect
225to add gradient", y=.1)
226
227grid.newpage()
228grid.rect(gp=gpar(fill=linearGradient()))
229HersheyLabel("rect with gradient
230(for grab)")
231x <- grid.grab()
232grid.newpage()
233grid.draw(x)
234HersheyLabel("default gradient
235from grid.grab()")
236
237grid.newpage()
238pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
239grid.rect()
240HersheyLabel("gradient on viewport
241viewport half height/width
242for grid.grab")
243x <- grid.grab()
244grid.newpage()
245grid.draw(x)
246HersheyLabel("gradient on viewport
247viewport half height/width
248from grid.grab")
249
250######################################
251## Tests of "efficiency"
252## (are patterns being resolved only as necessary)
253
254##
255trace(grid:::resolveFill.GridPattern, print=FALSE,
256      function(...) cat("*** RESOLVE:  Viewport pattern resolved\n"))
257trace(grid:::resolveFill.GridGrobPattern, print=FALSE,
258      function(...) cat("*** RESOLVE:  Grob pattern resolved\n"))
259
260## ONCE for rect grob
261traceHead <- "ONE resolve for rect grob with gradient"
262grid.newpage()
263traceOutput <- capture.output(grid.rect(gp=gpar(fill=linearGradient())))
264HersheyLabel("default gradient
265for tracing", y=.9)
266HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))
267
268
269## ONCE for multiple rects from single grob
270traceHead <- "ONE resolve for multiple rects from rect grob with gradient"
271grid.newpage()
272traceOutput <- capture.output(grid.rect(x=1:5/6, y=1:5/6, width=1/8, height=1/8,
273                                        gp=gpar(fill=linearGradient())))
274HersheyLabel("gradient on five rects
275for tracing", y=.9)
276HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))
277
278## ONCE for viewport with rect
279traceHead <- "ONE resolve for rect grob in viewport with gradient"
280grid.newpage()
281traceOutput <- capture.output({
282    pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
283    grid.rect()
284})
285HersheyLabel("gradient on viewport
286viewport half height/width
287for tracing", y=.8)
288HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))
289
290## ONCE for viewport with rect, revisiting multiple times
291traceHead <- "ONE resolve for rect grob in viewport with gradient\nplus nested viewport\nplus viewport revisited"
292grid.newpage()
293traceOutput <- capture.output({
294    pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient()),
295                          name="vp"))
296    grid.rect(gp=gpar(lwd=8))
297    pushViewport(viewport(width=.5, height=.5))
298    grid.rect()
299    upViewport()
300    grid.rect(gp=gpar(col="red", lwd=4))
301    upViewport()
302    downViewport("vp")
303    grid.rect(gp=gpar(col="blue", lwd=2))
304})
305HersheyLabel("gradient on viewport
306viewport half width/height
307rect (thick black border)
308nested viewport (inherits gradient)
309rect (medium red border)
310navigate to original viewport
311rect (thin blue border)", y=.9)
312HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))
313
314untrace(grid:::resolveFill.GridPattern)
315untrace(grid:::resolveFill.GridGrobPattern)
316
317######################################
318## Test for running out of patterns
319
320## Should NOT run out of patterns
321grid.newpage()
322for (i in 1:21) {
323    grid.rect(gp=gpar(fill=linearGradient()))
324    HersheyLabel(paste0("rect ", i, " with gradient
325new pattern every time"))
326}
327
328## Should run out of patterns
329grid.newpage()
330for (i in 1:21) {
331    pushViewport(viewport(gp=gpar(fill=linearGradient())))
332    grid.rect()
333    HersheyLabel(paste0("viewport ", i, " with gradient
334runs out after 20"))
335}
336
337## grid.newpage() should fix it
338grid.newpage()
339for (i in 1:21) {
340    grid.rect(gp=gpar(fill=linearGradient()))
341    HersheyLabel(paste0("rect ", i, " with gradient
342AFTER grid.newpage()
343new pattern every time"))
344}
345
346################################################################################
347## Grob-based patterns
348
349## Simple circle grob as pattern in rect
350grid.newpage()
351grid.rect(gp=gpar(fill=pattern(circleGrob(gp=gpar(fill="grey")))))
352HersheyLabel("single grey filled circle pattern")
353
354## Multiple circles as pattern in rect
355grid.newpage()
356pat <- circleGrob(1:3/4, r=unit(1, "cm"))
357grid.rect(gp=gpar(fill=pattern(pat)))
358HersheyLabel("three unfilled circles pattern")
359
360## Pattern on rect scales with rect
361grid.newpage()
362grid.rect(width=.5, height=.8, gp=gpar(fill=pattern(pat)))
363HersheyLabel("pattern on rect scales with rect")
364
365## Pattern on viewport
366grid.newpage()
367pushViewport(viewport(gp=gpar(fill=pattern(pat))))
368grid.rect()
369HersheyLabel("pattern on viewport
370applied to rect")
371
372## Pattern on viewport stays fixed for rect
373grid.newpage()
374pushViewport(viewport(gp=gpar(fill=pattern(pat))))
375grid.rect(width=.5, height=.8)
376HersheyLabel("pattern on viewport
377applied to rect
378pattern does not scale with rect")
379
380## Patterns have colour
381grid.newpage()
382pat <- circleGrob(1:3/4, r=unit(1, "cm"),
383                  gp=gpar(fill=c("red", "green", "blue")))
384grid.rect(gp=gpar(fill=pattern(pat)))
385HersheyLabel("pattern with colour")
386
387## Pattern with gradient
388grid.newpage()
389pat <- circleGrob(1:3/4, r=unit(1, "cm"),
390                  gp=gpar(fill=linearGradient()))
391grid.rect(gp=gpar(fill=pattern(pat)))
392HersheyLabel("pattern with gradient")
393
394## Pattern with a clipping path
395grid.newpage()
396pat <- circleGrob(1:3/4, r=unit(1, "cm"),
397                  vp=viewport(clip=rectGrob(height=unit(1, "cm"))),
398                  gp=gpar(fill=linearGradient()))
399grid.rect(gp=gpar(fill=pattern(pat)))
400HersheyLabel("pattern with clipping path
401and gradient")
402
403## Tiling patterns
404grid.newpage()
405grob <- circleGrob(r=unit(2, "mm"),
406                   gp=gpar(col=NA, fill="grey"))
407pat <- pattern(grob,
408               width=unit(5, "mm"),
409               height=unit(5, "mm"),
410               extend="repeat")
411grid.rect(gp=gpar(fill=pat))
412HersheyLabel("pattern that tiles page")
413
414grid.newpage()
415pushViewport(viewport(gp=gpar(fill=pat)))
416grid.rect(width=.5)
417HersheyLabel("pattern that fills viewport
418but only drawn within rectangle
419pattern relative to viewport")
420
421grid.newpage()
422grob <- circleGrob(x=0, y=0, r=unit(2, "mm"),
423                   gp=gpar(col=NA, fill="grey"))
424pat <- pattern(grob,
425               x=0, y=0,
426               width=unit(5, "mm"),
427               height=unit(5, "mm"),
428               extend="repeat")
429grid.rect(width=.5, gp=gpar(fill=pat))
430HersheyLabel("pattern as big as the viewport
431but only drawn within rectangle
432pattern relative to rectangle
433(starts at bottom left of rectangle)")
434
435## More tests
436grid.newpage()
437grid.circle(gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
438HersheyLabel("circle with horizontal gradient
439black left to white right")
440
441grid.newpage()
442grid.polygon(c(.2, .8, .7, .5, .3),
443             c(.8, .8, .2, .4, .2),
444             gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
445HersheyLabel("polygon with horizontal gradient
446black left to white right")
447
448grid.newpage()
449grid.path(c(.2, .8, .3, .5, .7),
450          c(.8, .8, .2, .4, .2),
451          gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
452HersheyLabel("path with horizontal gradient
453black left to white right")
454
455grid.newpage()
456grid.text("Reveal", gp=gpar(fontfamily="HersheySans",
457                            fontface="bold", cex=3))
458grid.rect(gp=gpar(col=NA,
459                  fill=radialGradient(c("white", "transparent"),
460                                      r2=.3)))
461HersheyLabel("text with semitransparent radial gradient
462centre of text should be dissolved", y=.2)
463
464grid.newpage()
465pat <-
466    pattern(circleGrob(gp=gpar(col=NA, fill="grey"),
467                       vp=viewport(width=.2, height=.2,
468                                   mask=rectGrob(x=c(1, 3)/4,
469                                                 width=.3,
470                                                 gp=gpar(fill="black")))),
471            width=1/4, height=1/4,
472            extend="repeat")
473grid.rect(width=.5, height=.5, gp=gpar(fill=pat))
474HersheyLabel("rect in centre with pattern fill
475pattern is circle drawn in smaller viewport
476pattern is masked by two tall thin rects
477pattern repeats", y=.15)
478
479grid.newpage()
480pat1 <-
481    pattern(circleGrob(r=.1, gp=gpar(col="black", fill="grey")),
482            width=.2, height=.2,
483            extend="repeat")
484pat2 <-
485    pattern(circleGrob(r=1/4, gp=gpar(col="black", fill=pat1)),
486            width=1/2, height=1/2,
487            extend="repeat")
488grid.rect(width=.5, height=.5, gp=gpar(fill=pat2))
489HersheyLabel("rect in centre with pattern fill
490pattern is small circle with pattern fill
491nested pattern is smaller circle (grey)
492both patterns repeat", y=.15)
493
494