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