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(fontface="bold", cex=10)), gp=gpar(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(fontface="bold", cex=10)), gp=gpar(fill=linearGradient(2:3))) HersheyLabel("stroked path based on text filled with linear gradient", y=.8) ################################################################################ ## Points ## Points filled with gradient grid.newpage() grid.points(1:9/10, 1:9/10, default.units="npc", pch=21, gp=gpar(fill=linearGradient())) HersheyLabel("points (pch=21) filled with linear gradient (gradient based on ALL points)", y=.8) ## Points filled with gradient (point not filled) grid.newpage() grid.points(1:9/10, 1:9/10, default.units="npc", pch=1, gp=gpar(fill=linearGradient())) HersheyLabel("points (pch=1) filled with linear gradient (fill ignored)", y=.8) ## Individual points filled with gradient (gradient recycled) grid.newpage() grid.points(1:3/4, 1:3/4, default.units="npc", pch=21, gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("points (pch=21) filled with linear gradient (gradient based on EACH point)", y=.8) ## Individual points filled with individual gradients grid.newpage() gradients <- lapply(2:4, function(x) linearGradient(c(x, "white"), group=FALSE)) grid.points(1:3/4, 1:3/4, default.units="npc", pch=21, gp=gpar(fill=gradients)) HersheyLabel("points (pch=21) filled with linear gradient (different gradient for EACH point)", y=.8) ## points inheriting single gradient grid.newpage() pushViewport(viewport(gp=gpar(fill=linearGradient()))) grid.points(1:2, 1:2, default.units="in", pch=21) HersheyLabel("points (pch=21) filled with linear gradient gradient inherited from viewport (so gradient relative to viewport)") ## points inheriting multiple gradients grid.newpage() pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2), radialGradient(3:4))))) grid.points(1:2, 1:2, default.units="in", pch=21) HersheyLabel("points (pch=21) filled with multiple linear gradients gradients inherited from viewport (so gradients relative to viewport)") ## points recycling inherited multiple gradients grid.newpage() pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2), radialGradient(3:4))))) grid.points(1:9/10, 1:9/10, default.units="npc", pch=21) HersheyLabel("points (pch=21) filled with linear gradients gradients inherited from viewport (so gradient relative to viewport) more points than gradients (so gradients recycled)") ## points recycling inherited multiple gradients with group=FALSE ## so pattern just passed through and resolved relative to points grob grid.newpage() pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2, group=FALSE), radialGradient(3:4, group=FALSE))))) grid.points(1:9/10, 1:9/10, default.units="npc", pch=21) HersheyLabel("points (pch=21) filled with linear gradients group=FALSE gradients inherited from viewport (but unresolved so resolved on EACH point) more points than gradients (so gradients recycled)") ## Using tracing to check that fills are not being resolved more than necessary trace(grid:::resolveFill.GridPattern, print=FALSE, function(...) cat("*** RESOLVE: Viewport pattern resolved\n")) trace(grid:::resolveFill.GridPatternList, print=FALSE, function(...) cat("*** RESOLVE: Viewport pattern list resolved\n")) trace(grid:::resolveFill.GridGrobPattern, print=FALSE, function(...) cat("*** RESOLVE: Grob pattern resolved\n")) trace(grid:::resolveFill.GridGrobPatternList, print=FALSE, function(...) cat("*** RESOLVE: Grob pattern list resolved\n")) doTrace <- function(head, f) { traceOutput <- capture.output(f()) HersheyLabel(paste(head, paste(traceOutput, collapse="\n"), sep="\n")) } grid.newpage() doTrace("points grob (pch=21)\nwith gradient\nONE resolve", function() { grid.points(1:9/10, 1:9/10, default.units="npc", pch=21, gp=gpar(fill=linearGradient())) }) grid.newpage() doTrace("points grob (pch=1)\nwith gradient\nONE resolve\n(even though unused)", function() { grid.points(1:9/10, 1:9/10, default.units="npc", pch=1, gp=gpar(fill=linearGradient())) }) grid.newpage() doTrace("points grob (pch=21)\nwith gradient (group=FALSE)\nTHREE resolves\n(resolve per point)", function() { grid.points(1:3/4, 1:3/4, default.units="npc", pch=21, gp=gpar(fill=linearGradient(group=FALSE))) }) grid.newpage() gradients <- lapply(2:4, function(x) linearGradient(c(x, "white"), group=FALSE)) doTrace("points grob (pch=21)\nwith gradient list (group=FALSE)\nONE resolve\n(all gradients resolved at once)", function() { grid.points(1:3/4, 1:3/4, default.units="npc", pch=21, gp=gpar(fill=gradients)) }) grid.newpage() doTrace("points grob (pch=21)\nwith inherited gradient\nONE resolve\n(gradient resolved when vp pushed)", function() { pushViewport(viewport(gp=gpar(fill=linearGradient()))) grid.points(1:2, 1:2, default.units="in", pch=21) }) grid.newpage() doTrace("points grob (pch=21)\nwith inherited gradient list\nTWO resolves\n(gradient list resolved when vp pushed\nAND gradient list resolved when points drawn\n[no-op because already resolved])", function() { pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2), radialGradient(3:4))))) grid.points(1:2, 1:2, default.units="in", pch=21) }) grid.newpage() doTrace("points grob (pch=21)\nwith inherited gradient list\nAND recycling of gradients\nTWO resolves\n(gradient list resolved when vp pushed\nAND gradient list resolved when points drawn\n[no-op because already resolved])", function() { pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2), radialGradient(3:4))))) grid.points(1:9/10, 1:9/10, default.units="npc", pch=21) }) ## Individual points filled with individual gradients ## *some* group = TRUE and *some* group = FALSE grid.newpage() gradients <- lapply(2:4, function(x) linearGradient(c(x, "white"), group = x %% 2)) grid.points(1:3/4, 1:3/4, default.units="npc", pch=21, gp=gpar(fill=gradients)) HersheyLabel("points (pch=21) filled with linear gradient (different gradient for EACH point) first and third resolved on individual points second resolved on ALL points", y=.8) ## Points filled with pattern (recycled), multiple pch grid.newpage() grid.points(1:3/4, 1:3/4, default.units="npc", pch=21:23, gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("points (pch=21:23) single gradient (group=FALSE) each different point gets its own gradient", y=.8) ################################################################################ ## Rects grid.newpage() grid.rect(x=1:3/4, y=1:3/4, width=.2, height=.2, gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.rect(x=1:3/4, y=1:3/4, width=.2, height=.2, gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## Circles grid.newpage() grid.circle(x=1:3/4, y=1:3/4, r=.1, gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.circle(x=1:3/4, y=1:3/4, r=.1, gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## Polygons grid.newpage() grid.polygon(x=c(.2, .4, .3, .4, .6, .5, .6, .8, .7), y=c(.2, .2, .4, .4, .4, .6, .6, .6, .8), id=rep(1:3, each=3), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.polygon(x=c(.2, .4, .3, .4, .6, .5, .6, .8, .7), y=c(.2, .2, .4, .4, .4, .6, .6, .6, .8), id=rep(1:3, each=3), gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## Segments grid.newpage() grid.segments(x0=c(.2, .4, .6), y0=c(.2, .5, .8), x1=c(.4, .6, .8), y1=c(.2, .5, .8), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.segments(x0=c(.2, .4, .6), y0=c(.2, .5, .8), x1=c(.4, .6, .8), y1=c(.2, .5, .8), gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## Xsplines grid.newpage() grid.xspline(x=c(.2, .4, .3, .4, .6, .5, .6, .8, .7), y=c(.2, .2, .4, .4, .4, .6, .6, .6, .8), id=rep(1:3, each=3), shape=-1, open=FALSE, gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.xspline(x=c(.2, .4, .3, .4, .6, .5, .6, .8, .7), y=c(.2, .2, .4, .4, .4, .6, .6, .6, .8), id=rep(1:3, each=3), shape=-1, open=FALSE, gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## Lines ## ## NOTE that polylines are handled by same underlying C code grid.newpage() grid.lines(x=c(.2, .4, .3), y=c(.2, .2, .4), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.lines(x=c(.2, .4, .3), y=c(.2, .2, .4), gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## MoveTo/LineTo grid.newpage() grid.move.to(x=.2, y=.2) grid.line.to(x=.4, y=.4, gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.move.to(x=.2, y=.2) grid.line.to(x=.4, y=.4, gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## Paths ## Pattern fill on single path consisting of distinct shapes grid.newpage() grid.path(c(.2, .2, .4, .4, .6, .6, .8, .8), c(.2, .4, .4, .2, .6, .8, .8, .6), id=rep(1:2, each=4), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE single path", y=.8) ## Pattern fill on multiple paths, each consisting of distinct shapes grid.newpage() grid.path(c(.2, .2, .4, .4, .25, .25, .35, .35, .6, .6, .8, .8, .65, .65, .75, .75), c(.2, .4, .4, .2, .25, .35, .35, .25, .6, .8, .8, .6, .65, .75, .75, .65), rule="evenodd", id=rep(1:4, each=4), pathId=rep(1:2, each=8), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE multiple paths", y=.8) ## Same thing, list of patterns grid.newpage() grid.path(c(.2, .2, .4, .4, .25, .25, .35, .35, .6, .6, .8, .8, .65, .65, .75, .75), c(.2, .4, .4, .2, .25, .35, .35, .25, .6, .8, .8, .6, .65, .75, .75, .65), rule="evenodd", id=rep(1:4, each=4), pathId=rep(1:2, each=8), gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE)))) HersheyLabel("mulitple gradient fills group = FALSE multiple paths", y=.8) ################################################################################ ## Raster grid.newpage() grid.raster(matrix(1:4/5, ncol=2), interpolate=FALSE, width=.5, height=.5, gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.raster(matrix(1:4/5, ncol=2), interpolate=FALSE, width=.5, height=.5, gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## Text grid.newpage() grid.text(letters[1:3], x=1:3/4, y=1:3/4, gp=gpar(fontfamily="HersheySans", fill=linearGradient(group=FALSE))) HersheyLabel("single gradient fill group = FALSE", y=.8) grid.newpage() grid.text(letters[1:3], x=1:3/4, y=1:3/4, gp=gpar(fontfamily="HersheySans", fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE), linearGradient()))) HersheyLabel("list of gradient fills linear (group=FALSE) radial (group=FALSE) linear (group=TRUE)", y=.8) ################################################################################ ## Arrows grid.newpage() grid.segments(x0=c(.2, .4, .6), y0=c(.2, .5, .8), x1=c(.4, .6, .8), y1=c(.2, .5, .8), arrow=arrow(type="closed"), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("Lines with (closed) arrows gradient fill disallowed on arrow", y=.8) grid.newpage() grid.xspline(x=c(.2, .4, .3, .4, .6, .5, .6, .8, .7), y=c(.2, .2, .4, .4, .4, .6, .6, .6, .8), id=rep(1:3, each=3), shape=-1, arrow=arrow(type="closed"), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("Lines with (closed) arrows gradient fill disallowed on arrow", y=.8) grid.newpage() grid.lines(x=c(.2, .4, .3), y=c(.2, .2, .4), arrow=arrow(type="closed"), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("Lines with (closed) arrows gradient fill disallowed on arrow", y=.8) grid.newpage() grid.move.to(x=.2, y=.2) grid.line.to(x=.4, y=.4, arrow=arrow(type="closed"), gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("Lines with (closed) arrows gradient fill disallowed on arrow", y=.8) ################################################################################ ## Test more complex coords from more complex grobs (gTrees) ################################################################################ ## grobCoords() also used when resolving patterns to generate a bbox ## for temporary viewport (so the pattern is resolved relative to the ## grob bbox). Hence ... ## ## grid/R/patterns.R library(grid) ## Test gTree with pattern fill ## Children are distinct rectangles, pattern is resolved on gTree ## so relative to bbox around both rectangles gt <- gTree(children=gList(rectGrob(1/3, width=.2, height=.2), rectGrob(2/3, width=.2, height=.2)), gp=gpar(fill=linearGradient())) grid.newpage() grid.draw(gt) HersheyLabel("gTree with two rects fill resolved on bbox of both rects", y=.8) ## Test gTree with pattern fill with children that push vp ## (to test that the resolution happens in the gTree context ## NOT the child's vp context) ## Both rects should be filled with gradient that fills whole page gt <- gTree(children=gList(rectGrob(), rectGrob(vp=viewport(width=.5, height=.5))), gp=gpar(fill=linearGradient())) grid.newpage() grid.draw(gt) HersheyLabel("gTree with two rects one rect has vp fill resolved on gTree both rects same fill") ## Test gTree with pattern fill with children with pattern fill ## Left rect gets its own gradient; right rect gets gradient ## relative to both rects gt <- gTree(children=gList(rectGrob(1/3, width=.2, height=.2, gp=gpar(fill=linearGradient())), rectGrob(2/3, width=.2, height=.2)), gp=gpar(fill=linearGradient())) grid.newpage() grid.draw(gt) HersheyLabel("gTree with pattern fill one rect also has pattern fill one rect has gTree pattern fill (resolved on both rects) one rect has its own pattern fill", y=.8) ## Test gTree with pattern fill with gTree as child ## (same result as first gTree test) gt <- gTree(children=gList(gTree(children=gList(rectGrob(1/3, width=.2, height=.2), rectGrob(2/3, width=.2, height=.2)))), gp=gpar(fill=linearGradient())) grid.newpage() grid.draw(gt) HersheyLabel("gTree with pattern fill child is gTree with children pattern resolved on parent gTree" ,y=.8) ## Test gTree with gTree with pattern fill as child ## (same result as first gTree test) gt <- gTree(children=gList(gTree(children=gList(rectGrob(1/3, width=.2, height=.2), rectGrob(2/3, width=.2, height=.2)), gp=gpar(fill=linearGradient())))) grid.newpage() grid.draw(gt) HersheyLabel("gTree child gTree child gTree has pattern fill pattern resolved on child gTree" ,y=.8) ## Test gTree with pattern fill with group = FALSE ## (so pattern fill is resolved separately on each child) gt <- gTree(children=gList(rectGrob(1/3, width=.2, height=.2), rectGrob(2/3, width=.2, height=.2)), gp=gpar(fill=linearGradient(group=FALSE))) grid.newpage() grid.draw(gt) HersheyLabel("gTree with pattern fill with group=FALSE pattern resolved on each child rect", y=.8) ################################################################################ ## groups and (stroked and filled) paths generate gTrees to calculate ## grobCoords(), so they are affected. Hence ... ## ## grid/R/group.R ## grid/R/path.R library(grid) r1 <- rectGrob(x=0, y=0, width=.5, height=.5, just=c("left", "bottom")) r2 <- rectGrob(x=1, y=1, width=.75, height=.75, just=c("right", "top"), gp=gpar(fill="black")) ## Path with hole filled with pattern grid.newpage() grid.fill(gTree(children=gList(r1, r2)), rule="evenodd", gp=gpar(fill=linearGradient())) HersheyLabel("path from two rects pattern fill resolved on bbox of both rects", y=.8) ## Remove r2 from r1 with "group" and fill with gradient ## (bbox is from BOTH rects, hence whole page) grid.newpage() grid.group(r2, "dest.out", r1, gp=gpar(fill=linearGradient())) HersheyLabel("group of two rects big rect takes bite out of small rect pattern fill resolved on bbox of both rects", y=.8) ## NOTE that setting 'gp' on group use has no effect on group ## (graphical parameter settings were fixed at group definition) grid.newpage() grid.define(r1, name="r1") pushViewport(viewport(x=1, y=1)) grid.use("r1", gp=gpar(fill=linearGradient())) upViewport() HersheyLabel("group use with pattern fill pattern IGNORED", y=.2) ## BUT if put the fill on the grob in the group it works ? grid.newpage() grid.define(editGrob(r1, gp=gpar(fill=linearGradient())), name="r1") pushViewport(viewport(x=1, y=1)) grid.use("r1") upViewport() HersheyLabel("group use imposes transformation rect within group has pattern fill pattern resolved on rect on use", y=.2) ## ... even with scaling (as well as translation) transformation grid.newpage() grid.define(editGrob(r1, gp=gpar(fill=linearGradient())), name="r1") pushViewport(viewport(x=1, y=1, width=.5, height=.5)) grid.use("r1") upViewport() HersheyLabel("group use imposes transformation AND scaling rect within group has pattern fill pattern resolved on rect on use", y=.2) ################################################################################ ## Tests of gTree with LIST of patterns ## gTree with LIST of patterns, group = TRUE ## Test gTree with pattern fill with group = FALSE ## (so pattern fill is resolved separately on each child) gt <- gTree(children=gList(rectGrob(1:2/3, 1/3, width=.2, height=.2), rectGrob(1:2/3, 2/3, width=.2, height=.2)), gp=gpar(fill=list(linearGradient(), radialGradient()))) grid.newpage() grid.draw(gt) HersheyLabel("gTree with LIST of pattern fills with group=TRUE patterns resolved on gTree each SHAPE within each child gets different pattern", y=.8) ## gTree with LIST of patterns, group = FALSE gt <- gTree(children=gList(rectGrob(1:2/3, 1/3, width=.2, height=.2), rectGrob(1:2/3, 2/3, width=.2, height=.2)), gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE)))) grid.newpage() grid.draw(gt) HersheyLabel("gTree with LIST of pattern fills with group=FALSE patterns resolved on children each SHAPE within each child RESOLVES different pattern", y=.8) ## gTree with LIST of patterns, group = mix of TRUE/FALSE gt <- gTree(children=gList(rectGrob(1:2/3, 1/3, width=.2, height=.2), rectGrob(1:2/3, 2/3, width=.2, height=.2)), gp=gpar(fill=list(linearGradient(group=TRUE), radialGradient(group=FALSE)))) grid.newpage() grid.draw(gt) HersheyLabel("gTree with LIST of pattern fills with group=TRUE and FALSE patterns resolved on gTree AND children each SHAPE within each child gets OR resolves different pattern", y=.8) ## gTree with LIST of patterns, group = TRUE ## but NO children that have a fill! gt <- gTree(children=gList(segmentsGrob(0, 0:1, 1, 1:0)), gp=gpar(fill=list(linearGradient(), radialGradient()))) grid.newpage() grid.draw(gt) HersheyLabel("gTree with LIST of pattern fills with group=TRUE BUT no children that have a fill patterns resolved on gTree no (pattern) fill", y=.8) ## gTree with LIST of patterns, group = FALSE ## but NO children that have a fill! gt <- gTree(children=gList(segmentsGrob(0, 0:1, 1, 1:0)), gp=gpar(fill=list(linearGradient(group=FALSE), radialGradient(group=FALSE)))) grid.newpage() grid.draw(gt) HersheyLabel("gTree with LIST of pattern fills with group=FALSE BUT no children that have a fill patterns resolved on children no (pattern) fill", y=.8) ## gTree with LIST of patterns, group = mix of TRUE/FALSE ## and MIX of children that have a fill! ## (all combinations of group and child-has-fill) gt <- gTree(children=gList(segmentsGrob(0, 0:1, 1, 1:0), rectGrob(1:2/3, 2/3, width=.2, height=.2)), gp=gpar(fill=list(linearGradient(group=TRUE), radialGradient(group=FALSE)))) grid.newpage() grid.draw(gt) HersheyLabel("gTree with LIST of pattern fills with group=FALSE BUT no children that have a fill patterns resolved on children no (pattern) fill", y=.8) ################################################################################ ## More groups and (stroked and filled) paths library(grid) r1 <- rectGrob(x=0, y=0, width=.5, height=.5, just=c("left", "bottom")) r2 <- rectGrob(x=1, y=1, width=.75, height=.75, just=c("right", "top"), gp=gpar(fill="black")) ## Path with hole filled with pattern, group = FALSE ## Path is a "single shape" so result should be same as group = TRUE grid.newpage() grid.fill(gTree(children=gList(r1, r2)), rule="evenodd", gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("path from two rects group = FALSE pattern fill resolved on bbox of both rects", y=.8) ## Remove r2 from r1 with "group" and fill with gradient, group = FALSE ## Gradient should be applied to individual rects grid.newpage() grid.group(r2, "dest.out", r1, gp=gpar(fill=linearGradient(group=FALSE))) HersheyLabel("group of two rects group = FALSE big rect takes bite out of small rect pattern fill resolved on each rect", y=.8) ## fill on the grob in the group grid.newpage() grid.define(r2, "dest.out", editGrob(r1, gp=gpar(fill=linearGradient())), name="r1") pushViewport(viewport(x=1, y=1)) grid.use("r1") upViewport() HersheyLabel("group use imposes transformation rect within group has pattern fill pattern resolved on rect on use", y=.2) ## ... even with scaling (as well as translation) transformation grid.newpage() grid.define(r2, "dest.out", editGrob(r1, gp=gpar(fill=linearGradient())), name="r1") pushViewport(viewport(x=1, y=1, width=.5, height=.5)) grid.use("r1") upViewport() HersheyLabel("group use imposes transformation AND scaling rect within group has pattern fill pattern resolved on rect on use", y=.2) ## fill on the grob in the group, group = FALSE grid.newpage() grid.define(r2, "dest.out", editGrob(r1, gp=gpar(fill=linearGradient(group=FALSE))), name="gt") pushViewport(viewport(x=1, y=1)) grid.use("gt") upViewport() HersheyLabel("group use imposes transformation rect within group has pattern fill group = FALSE (no effect) pattern resolved on rect on use", y=.2) ## ... even with scaling (as well as translation) transformation, group=FALSE grid.newpage() grid.define(r2, "dest.out", editGrob(r1, gp=gpar(fill=linearGradient(group=FALSE))), name="gt") pushViewport(viewport(x=1, y=1, width=.5, height=.5)) grid.use("gt") upViewport() HersheyLabel("group use imposes transformation AND scaling rect within group has pattern fill group = FALSE (no effect) pattern resolved on rect on use", y=.2) ## Test gTree with pattern fill with children that push vp, group = FALSE ## SO child with vp should get different fill gt <- gTree(children=gList(rectGrob(), rectGrob(vp=viewport(width=.5, height=.5))), gp=gpar(fill=linearGradient(group=FALSE))) grid.newpage() grid.draw(gt) HersheyLabel("gTree with two rects one rect has vp fill resolved on each rect rects get different fill") ## gTree with group as child, fill resolved on gTree bbox ## (so needs group bbox) grid.newpage() group <- groupGrob(r1) gt <- gTree(children=gList(r2, group), gp=gpar(fill=linearGradient())) grid.draw(gt) HersheyLabel("gTree has group as child gTree has pattern fill pattern resolved on gTree", y=.2) ## gTree with group USE as child, fill resolved on gTree bbox ## (so needs group USE bbox) grid.newpage() r3 <- rectGrob(width=.5, height=.5) group <- grid.define(r1, name="r") use <- useGrob("r", vp=viewport(1, 1)) gt <- gTree(children=gList(r3, use), gp=gpar(fill=linearGradient())) grid.rect(.25, .25, .75, .75, just=c("left", "bottom"), gp=gpar(col=NA, fill=linearGradient())) grid.draw(gt) HersheyLabel("gTree has group USE as child gTree has pattern fill pattern resolved on gTree (rect behind shows correct gradient)", y=.2) ## Check grobCoords() from transform with skew produces same outline grid.newpage() c <- circleGrob(r=c(.3, .4)) pts <- grobCoords(c, closed=TRUE) p <- pathGrob(c(pts[[1]]$x, pts[[2]]$x), c(pts[[1]]$y, pts[[2]]$y), default.units="in", id=rep(1:2, each=100), rule="evenodd", gp=gpar(fill="grey")) grid.draw(p) grid.define(p, name="path") use <- useGrob("path", transform=function(group, ...) viewportTransform(group, shear=groupShear(.5), ...)) newPts <- grobCoords(use, closed=TRUE) newPath <- circleGrob(c(newPts[[1]][[1]][[1]]$x, newPts[[1]][[1]][[2]]$x), c(newPts[[1]][[1]][[1]]$y, newPts[[1]][[1]][[2]]$y), default.units="in", r=unit(.5, "mm"), gp=gpar(col="red", fill="red")) grid.draw(use) grid.draw(newPath)