Rev 81925 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
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 grobgrid.newpage()grid.rect(gp=gpar(fill=linearGradient()))HersheyLabel("default linear gradientblack bottom-left to white top-right")## Test linearGradient() argumentsgrid.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 gradient1 inch from bottomred-yellow-red")## Gradient relative to grobgrid.newpage()grid.rect(width=.5, height=.5,gp=gpar(fill=linearGradient()))HersheyLabel("gradient on rectblack bottom-left to white top-right OF RECT")## Gradient on viewportgrid.newpage()pushViewport(viewport(gp=gpar(fill=linearGradient())))grid.rect()HersheyLabel("default linear gradient on viewportblack bottom-left to white top-right")## Gradient relative to viewportgrid.newpage()pushViewport(viewport(gp=gpar(fill=linearGradient())))grid.rect(width=.5, height=.5)HersheyLabel("linear gradient on viewportviewport whole pagerect half height/widthdarker grey (not black) bottom-left OF RECTlighter 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 viewportviewport half height/widthrect whole viewportblack 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 viewportviewport whole pagenested viewport half height/widthrect whole viewportdarker grey (not black) bottom-left OF RECTlighter 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 viewportviewport whole pagerect left third (gradient from whole page)nested viewport whole pagenested viewport green fillrect centre (green)pop to first viewportrect right third (gradient from whole page)")## Translucent gradientgrid.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 transparentover text", y=.1)## Radial gradientgrid.newpage()grid.rect(gp=gpar(fill=radialGradient()))HersheyLabel("default radial gradientblack centre to white radius", y=.1)## Test radialGradient() argumentsgrid.newpage()grid.rect(gp=gpar(fill=radialGradient(c("white", "black"),cx1=.8, cy1=.8)))HersheyLabel("radial gradientwhite to blackstart centre top-right")## Gradient on a gTreegrid.newpage()grid.draw(gTree(children=gList(rectGrob(gp=gpar(fill=linearGradient())))))HersheyLabel("gTree with rect childgradient on rectblack bottom-left to white top-right")grid.newpage()grid.draw(gTree(children=gList(rectGrob()), gp=gpar(fill=linearGradient())))HersheyLabel("gTree with rect childgradient on gTreeblack bottom-left to white top-right")## Rotated gradientgrid.newpage()pushViewport(viewport(width=.5, height=.5, angle=45,gp=gpar(fill=linearGradient())))grid.rect()HersheyLabel("rotated gradientblack bottom-left to white top-right OF RECT")######################################## Tests of replaying graphics engine display list## Resize graphics devicegrid.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 devicegrid.newpage()grid.rect(gp=gpar(fill=linearGradient()))x <- recordPlot()HersheyLabel("default gradientfor recordPlot()black bottom-left to white top-right")replayPlot(x)HersheyLabel("default gradientfrom 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 viewportfor recordPlot()black bottom-left to white top-right")replayPlot(x)HersheyLabel("gradient on viewportfrom 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 gradientfor 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 gradientfrom replayPlot()AFTER white-red gradient(should be default gradient)")## Similar to previous, except involving viewportsgrid.newpage()pushViewport(viewport(gp=gpar(fill=linearGradient())))grid.rect()x <- recordPlot()HersheyLabel("gradient on viewportfor 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 viewportfrom replayPlot()AFTER white-red gradient(should be default gradient)")######################################## Test of 'grid' display listgrid.newpage()grid.rect(name="r")HersheyLabel("empty rect")grid.edit("r", gp=gpar(fill=linearGradient()))HersheyLabel("edited rectto 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 gradientfrom grid.grab()")grid.newpage()pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))grid.rect()HersheyLabel("gradient on viewportviewport half height/widthfor grid.grab")x <- grid.grab()grid.newpage()grid.draw(x)HersheyLabel("gradient on viewportviewport half height/widthfrom 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 grobtraceHead <- "ONE resolve for rect grob with gradient"grid.newpage()traceOutput <- capture.output(grid.rect(gp=gpar(fill=linearGradient())))HersheyLabel("default gradientfor tracing", y=.9)HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))## ONCE for multiple rects from single grobtraceHead <- "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 rectsfor tracing", y=.9)HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))## ONCE for viewport with recttraceHead <- "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 viewportviewport half height/widthfor tracing", y=.8)HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))## ONCE for viewport with rect, revisiting multiple timestraceHead <- "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 viewportviewport half width/heightrect (thick black border)nested viewport (inherits gradient)rect (medium red border)navigate to original viewportrect (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 rectgrid.newpage()grid.rect(gp=gpar(fill=pattern(circleGrob(gp=gpar(fill="grey")))))HersheyLabel("single grey filled circle pattern")## Multiple circles as pattern in rectgrid.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 rectgrid.newpage()grid.rect(width=.5, height=.8, gp=gpar(fill=pattern(pat)))HersheyLabel("pattern on rect scales with rect")## Pattern on viewportgrid.newpage()pushViewport(viewport(gp=gpar(fill=pattern(pat))))grid.rect()HersheyLabel("pattern on viewportapplied to rect")## Pattern on viewport stays fixed for rectgrid.newpage()pushViewport(viewport(gp=gpar(fill=pattern(pat))))grid.rect(width=.5, height=.8)HersheyLabel("pattern on viewportapplied to rectpattern does not scale with rect")## Patterns have colourgrid.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 gradientgrid.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 pathgrid.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 pathand gradient")## Tiling patternsgrid.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 viewportbut only drawn within rectanglepattern 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 viewportbut only drawn within rectanglepattern relative to rectangle(starts at bottom left of rectangle)")## More testsgrid.newpage()grid.circle(gp=gpar(fill=linearGradient(y1=.5, y2=.5)))HersheyLabel("circle with horizontal gradientblack 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 gradientblack 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 gradientblack 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 gradientcentre 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 fillpattern is circle drawn in smaller viewportpattern is masked by two tall thin rectspattern 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 fillpattern is small circle with pattern fillnested pattern is smaller circle (grey)both patterns repeat", y=.15)######################################## Test for expanding pattern resourcesgrid.newpage()for (i in 1:21) {grid.rect(gp=gpar(fill=linearGradient()))HersheyLabel(paste0("rect ", i, " with gradientpattern released every time"))}grid.newpage()for (i in 1:65) {pushViewport(viewport(gp=gpar(fill=linearGradient())))grid.rect()HersheyLabel(paste0("viewport ", i, " with gradientnew pattern every time"))}grid.newpage()for (i in 1:21) {grid.rect(gp=gpar(fill=linearGradient()))HersheyLabel(paste0("rect ", i, " with gradientAFTER grid.newpage()pattern released every time"))}###################################### Additional tests## gTree with gradient fillgrid.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 childrengTree has gradient fillgradient relative to circle bounds(black at left to white at right)", y=.8)## gTree with gradient fill with gTreegrid.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 childinner gTree has circles as childrenouter gTree has gradient fillgradient relative to circle bounds(black at left to white at right)", y=.8)## Pattern including textgrid.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 patternpattern based on (repeating) text", y=.9)## Text (path) filled with patterngrid.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 textfilled with checkerboard pattern", y=.8)## Pattern including rastergrid.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 patternpattern is based on raster (checkerboard)", y=.8)## Radial gradient where start circle and final circle overlapgrid.newpage()x1 <- .7y1 <- .7r1 <- .2x2 <- .4y2 <- .4r2 <- .4grid.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 circlesgradient is from semitransparent greento semitransparent redstart circle is greenfinal circle is red")## Text (path) filled with patterngrid.newpage()grid.fill(textGrob("test", gp=gpar(fontface="bold", cex=10)),gp=gpar(fill=linearGradient(2:3)))HersheyLabel("stroked path based on textfilled with linear gradient", y=.8)################################################################################## Points## Points filled with gradientgrid.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 gradientsgrid.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 gradientgrid.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 gradientgradient inherited from viewport(so gradient relative to viewport)")## points inheriting multiple gradientsgrid.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 gradientsgradients inherited from viewport(so gradients relative to viewport)")## points recycling inherited multiple gradientsgrid.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 gradientsgradients 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 grobgrid.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 gradientsgroup=FALSEgradients 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 necessarytrace(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 = FALSEgrid.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 pointssecond resolved on ALL points", y=.8)## Points filled with pattern (recycled), multiple pchgrid.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)################################################################################## Rectsgrid.newpage()grid.rect(x=1:3/4, y=1:3/4, width=.2, height=.2,gp=gpar(fill=linearGradient(group=FALSE)))HersheyLabel("single gradient fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## Circlesgrid.newpage()grid.circle(x=1:3/4, y=1:3/4, r=.1,gp=gpar(fill=linearGradient(group=FALSE)))HersheyLabel("single gradient fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## Polygonsgrid.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 fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## Segmentsgrid.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 fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## Xsplinesgrid.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 fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## Lines#### NOTE that polylines are handled by same underlying C codegrid.newpage()grid.lines(x=c(.2, .4, .3),y=c(.2, .2, .4),gp=gpar(fill=linearGradient(group=FALSE)))HersheyLabel("single gradient fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## MoveTo/LineTogrid.newpage()grid.move.to(x=.2, y=.2)grid.line.to(x=.4, y=.4,gp=gpar(fill=linearGradient(group=FALSE)))HersheyLabel("single gradient fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## Paths## Pattern fill on single path consisting of distinct shapesgrid.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 fillgroup = FALSEsingle path", y=.8)## Pattern fill on multiple paths, each consisting of distinct shapesgrid.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 fillgroup = FALSEmultiple paths", y=.8)## Same thing, list of patternsgrid.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 fillsgroup = FALSEmultiple paths", y=.8)################################################################################## Rastergrid.newpage()grid.raster(matrix(1:4/5, ncol=2),interpolate=FALSE,width=.5, height=.5,gp=gpar(fill=linearGradient(group=FALSE)))HersheyLabel("single gradient fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## Textgrid.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 fillgroup = 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 fillslinear (group=FALSE)radial (group=FALSE)linear (group=TRUE)", y=.8)################################################################################## Arrowsgrid.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) arrowsgradient 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) arrowsgradient 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) arrowsgradient 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) arrowsgradient 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.Rlibrary(grid)## Test gTree with pattern fill## Children are distinct rectangles, pattern is resolved on gTree## so relative to bbox around both rectanglesgt <- 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 rectsfill 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 pagegt <- gTree(children=gList(rectGrob(),rectGrob(vp=viewport(width=.5, height=.5))),gp=gpar(fill=linearGradient()))grid.newpage()grid.draw(gt)HersheyLabel("gTree with two rectsone rect has vpfill resolved on gTreeboth 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 rectsgt <- 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 fillone rect also has pattern fillone 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 fillchild is gTree with childrenpattern 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 gTreechild gTree has pattern fillpattern 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 fillwith group=FALSEpattern 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.Rlibrary(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 patterngrid.newpage()grid.fill(gTree(children=gList(r1, r2)),rule="evenodd",gp=gpar(fill=linearGradient()))HersheyLabel("path from two rectspattern 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, "clear", r1, gp=gpar(fill=linearGradient()))HersheyLabel("group of two rectsbig rect takes bite out of small rectpattern 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 fillpattern 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 transformationrect within group has pattern fillpattern resolved on rect on use", y=.2)## ... even with scaling (as well as translation) transformationgrid.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 scalingrect within group has pattern fillpattern 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 fillswith group=TRUEpatterns resolved on gTreeeach SHAPE within each child gets different pattern", y=.8)## gTree with LIST of patterns, group = FALSEgt <- 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 fillswith group=FALSEpatterns resolved on childreneach SHAPE within each child RESOLVES different pattern", y=.8)## gTree with LIST of patterns, group = mix of TRUE/FALSEgt <- 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 fillswith group=TRUE and FALSEpatterns resolved on gTree AND childreneach 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 fillswith group=TRUEBUT no children that have a fillpatterns resolved on gTreeno (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 fillswith group=FALSEBUT no children that have a fillpatterns resolved on childrenno (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 fillswith group=FALSEBUT no children that have a fillpatterns resolved on childrenno (pattern) fill", y=.8)################################################################################## More groups and (stroked and filled) pathslibrary(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 = TRUEgrid.newpage()grid.fill(gTree(children=gList(r1, r2)),rule="evenodd",gp=gpar(fill=linearGradient(group=FALSE)))HersheyLabel("path from two rectsgroup = FALSEpattern 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 rectsgrid.newpage()grid.group(r2, "clear", r1, gp=gpar(fill=linearGradient(group=FALSE)))HersheyLabel("group of two rectsgroup = FALSEbig rect takes bite out of small rectpattern fill resolved on each rect", y=.8)## fill on the grob in the groupgrid.newpage()grid.define(r2, "clear",editGrob(r1, gp=gpar(fill=linearGradient())),name="r1")pushViewport(viewport(x=1, y=1))grid.use("r1")upViewport()HersheyLabel("group use imposes transformationrect within group has pattern fillpattern resolved on rect on use", y=.2)## ... even with scaling (as well as translation) transformationgrid.newpage()grid.define(r2, "clear",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 scalingrect within group has pattern fillpattern resolved on rect on use", y=.2)## fill on the grob in the group, group = FALSEgrid.newpage()grid.define(r2, "clear",editGrob(r1, gp=gpar(fill=linearGradient(group=FALSE))),name="gt")pushViewport(viewport(x=1, y=1))grid.use("gt")upViewport()HersheyLabel("group use imposes transformationrect within group has pattern fillgroup = FALSE (no effect)pattern resolved on rect on use", y=.2)## ... even with scaling (as well as translation) transformation, group=FALSEgrid.newpage()grid.define(r2, "clear",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 scalingrect within group has pattern fillgroup = 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 fillgt <- 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 rectsone rect has vpfill resolved on each rectrects 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 childgTree has pattern fillpattern 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 childgTree has pattern fillpattern resolved on gTree(rect behind shows correct gradient)", y=.2)## Check grobCoords() from transform with skew produces same outlinegrid.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)