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")) } devMask <- function(aMask, lMask) { support <- dev.capabilities()$masks if (is.character(support)) { if ("alpha" %in% support) { aMask } else { if ("luminance" %in% support) { as.mask(lMask, type="luminance") } else { FALSE } } } else { FALSE } } ################################################################################ ## Basic sanity checks ## Simple group grob (same as a normal grob) grid.newpage() grid.group(rectGrob(width=.5, height=.5, gp=gpar(fill="grey"))) HersheyLabel("Group = single rect half-width, half-height, grey fill same as normal rect") ################################################################################ ## Compositing operators source("compositing.R") ################################################################################ ## Isolated groups ## Apply mask to isolated group grid.newpage() pushViewport(viewport(layout=grid.layout(2, 2))) pushViewport(viewport(layout.pos.row=1, layout.pos.col=1)) grid.rect(height=.5, gp=gpar(fill="red")) grid.rect(width=.5, gp=gpar(fill="blue")) HersheyLabel("no mask each shape composite over") popViewport() pushViewport(viewport(layout.pos.row=1, layout.pos.col=2), viewport(mask=devMask(circleGrob(gp=gpar(col=NA, fill=rgb(0,0,0,.5))), circleGrob(gp=gpar(col=NA, fill=grey(.5)))))) grid.rect(height=.5, gp=gpar(fill="red")) grid.rect(width=.5, gp=gpar(fill="blue")) popViewport() HersheyLabel("mask each shape masked then composite over") popViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=1), viewport(mask=devMask(circleGrob(gp=gpar(col=NA, fill=rgb(0,0,0,.5))), circleGrob(gp=gpar(col=NA, fill=grey(.5)))))) grid.group(rectGrob(width=.5, gp=gpar(fill="blue")), "over", rectGrob(height=.5, gp=gpar(fill="red"))) popViewport() HersheyLabel("mask and group each shape composite over in group group masked") popViewport() ## Grobs that draw more than one shape ## Circle of small circles, draw over and then compose with alpha mask grid.newpage() t <- seq(30, 360, 30) x <- .5 + .3*cos(pi*t/180) y <- .5 + .3*sin(pi*t/180) circles <- circleGrob(x, y, r=.1, gp=gpar(fill="black")) pushViewport(viewport(layout=grid.layout(2, 2))) pushViewport(viewport(layout.pos.row=1, layout.pos.col=1)) grid.draw(circles) HersheyLabel("circle grob") popViewport() pushViewport(viewport(layout.pos.row=1, layout.pos.col=2, mask=devMask(rectGrob(gp=gpar(col=NA, fill=rgb(0,0,0,.5))), rectGrob(gp=gpar(col=NA, fill=grey(.5)))))) grid.draw(circles) HersheyLabel("masked circle grob") popViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=1)) grid.group(circles) HersheyLabel("group circle grob") popViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=2, mask=devMask(rectGrob(gp=gpar(col=NA, fill=rgb(0,0,0,.5))), rectGrob(gp=gpar(col=NA, fill=grey(.5)))))) grid.group(circles) HersheyLabel("masked group circle grob") popViewport() ################################################################################ ## Inheritance of graphics settings ## Compositing groups inherit graphics settings from "parent" grid.newpage() pushViewport(viewport(gp=gpar(fill="pink"))) grid.rect(x=1/4, width=1/2) grid.group(rectGrob(x=3/4, width=1/2)) HersheyLabel("group inherits current gpar (right rect pink)") popViewport() ## Watch out for alpha level accumulating grid.newpage() pushViewport(viewport(gp=gpar(fill=rgb(1,0,0,.5)))) grid.rect(x=1/4, width=1/2) grid.group(rectGrob(x=3/4, width=1/2)) HersheyLabel("group inherits current gpar (right rect trans red) test with alpha") popViewport() ################################################################################ ## gTrees ## The trick here is that the rectangle is drawn within a viewport, ## which means that there is an upViewport() within the drawing ## of the group, which means 'grid' has to have guards against that ## upViewport() resetting any mask that is in effect outside the group. ## ## This is a proxy for drawing complex things like 'ggplot2' plot gTrees ## within a group (which also works, I just cannot make it a test within ## the 'grid' package). grid.newpage() gt <- gTree(children=gList(rectGrob(vp=viewport()), circleGrob(1:2/3, r=.3, gp=gpar(fill="black")))) pushViewport(viewport(mask=devMask(rectGrob(gp=gpar(col=NA, fill=rgb(0,0,0,.5))), rectGrob(gp=gpar(col=NA, fill=grey(.5)))))) grid.group(gt) HersheyLabel("group is gTree with child with vp group drawn with mask", y=.9) HersheyLabel("mask NOT reset within group definition (circles NOT masked within group)", y=.1) popViewport() ################################################################################ ## Reuse ## Use group in smaller viewport (translate and scale) grid.newpage() grid.group(rectGrob(width=unit(1, "in"), height=unit(1, "in"), gp=gpar(fill="grey")), name="rectGroup") HersheyLabel("draw named group", y=.75) pushViewport(viewport(x=.75, y=.25, width=.5, height=.5)) grid.rect(gp=gpar(fill=NA, lty="dashed")) grid.use("rectGroup") HersheyLabel("reuse group (in smaller viewport) shrunk AND thinner border", y=.25) popViewport() ## Just translate grid.newpage() grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"), gp=gpar(fill="grey")), name="rectGroup") grid.use("rectGroup") HersheyLabel("draw named group", y=.75) pushViewport(viewport(x=.75, y=.25, width=.5, height=.5)) grid.rect(gp=gpar(fill=NA, lty="dashed")) grid.use("rectGroup", viewportTranslate) HersheyLabel("reuse group just with translate transform (in smaller viewport) just shifted", y=.25) popViewport() ## Just scale grid.newpage() grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"), gp=gpar(fill="grey")), name="rectGroup") grid.use("rectGroup") HersheyLabel("draw named group", y=.75) pushViewport(viewport(x=.75, y=.25, width=.5, height=.5)) grid.rect(gp=gpar(fill=NA, lty="dashed")) grid.use("rectGroup", viewportScale) HersheyLabel("reuse group just with scale transform (in smaller viewport) just scaled", y=.25) popViewport() ## Just translate BUT viewport x/y is NOT "centre" grid.newpage() grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"), gp=gpar(fill="grey")), name="rectGroup") grid.use("rectGroup") HersheyLabel("draw named group", y=.75) pushViewport(viewport(x=1, y=0, width=.5, height=.5, just=c("right", "bottom"))) grid.rect(gp=gpar(fill=NA, lty="dashed")) grid.use("rectGroup", viewportTranslate) HersheyLabel("reuse group just with translate transform with vp x/y at bottom-right (in smaller viewport) shifted to new vp x/y", y=.25) popViewport() ## Just scale (which ignores the fact that x/y is NOT "centre") grid.newpage() grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"), gp=gpar(fill="grey")), name="rectGroup") grid.use("rectGroup") HersheyLabel("draw named group", y=.75) pushViewport(viewport(x=1, y=0, width=.5, height=.5, just=c("right", "bottom"))) grid.rect(gp=gpar(fill=NA, lty="dashed")) grid.use("rectGroup", viewportScale) HersheyLabel("reuse group just with scale transform with vp x/y at bottom-right (in smaller viewport) just scaled (new vp x/y ignored)", y=.25) popViewport() ## Rotation grid.newpage() grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"), gp=gpar(fill="grey")), name="rectGroup") grid.use("rectGroup") pushViewport(viewport(angle=15)) grid.rect(gp=gpar(lty="dashed", fill=NA)) grid.use("rectGroup") popViewport() HersheyLabel("reuse group rotated viewport rotated group", y=.25) ## Shear grid.newpage() grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"), gp=gpar(fill="grey")), name="rectGroup") grid.use("rectGroup") trans <- function(group, ...) { viewportTransform(group, shear=groupShear(.5, 0)) } grid.use("rectGroup", transform=trans) HersheyLabel("reuse group shear (skewX) transform sheared group", y=.25) grid.newpage() grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"), gp=gpar(fill="grey")), name="rectGroup") grid.use("rectGroup") trans <- function(group, ...) { viewportTransform(group, shear=groupShear(0, .5)) } grid.use("rectGroup", transform=trans) HersheyLabel("reuse group shear (skewY) transform sheared group", y=.25) grid.newpage() pushViewport(viewport(gp=gpar(col=2))) grid.define(circleGrob(r=.1), name="c", gp=gpar(lwd=5)) grid.use("c") pushViewport(viewport(x=.25, gp=gpar(col="green"))) grid.use("c") popViewport() pushViewport(viewport(x=.75, gp=gpar(col="blue"))) grid.use("c") popViewport() popViewport() HersheyLabel("define circle (no colour) (red from viewport) left viewport sets green (circle stays red) right viewport sets blue (cirlce stays red)", y=.25) grid.newpage() grid.define(rectGrob(gp=gpar(col=NA, fill=radialGradient())), name="gradient") grid.use("gradient") pushViewport(viewport(y=.1, height=.2)) grid.rect(gp=gpar(lty="dashed", fill=NA)) grid.use("gradient") popViewport() HersheyLabel("group with gradient fill reused in viewport with different scale distorted gradient", y=.9) ################################################################################ ## Combinations (masks in groups, groups in groups, ...) ## Text in group grid.newpage() group <- gTree(children=gList(rectGrob(width=.8, height=.5), textGrob("testing", gp=gpar(cex=3)))) grid.group(group) HersheyLabel("group with text", y=.8) ## Pattern in group grid.newpage() grid.group(rectGrob(width=.8, height=.5, gp=gpar(fill=linearGradient()))) HersheyLabel("group with gradient fill", y=.8) ## Clipping path in group grid.newpage() vp <- viewport(clip=circleGrob()) grid.group(rectGrob(gp=gpar(fill="grey")), vp=vp) HersheyLabel("group with vp vp is viewport with clipping path result is grey circle") grid.newpage() vp <- viewport(clip=circleGrob()) grid.group(rectGrob(gp=gpar(fill="grey"), vp=vp)) HersheyLabel("group with grob with vp vp is viewport with clipping path result is grey circle") ## Mask in group grid.newpage() vp <- viewport(mask=devMask(circleGrob(gp=gpar(fill="black")), circleGrob(gp=gpar(col="white", fill="white")))) grid.group(rectGrob(gp=gpar(fill="grey")), vp=vp) HersheyLabel("group with vp vp is viewport with mask result is grey circle") grid.newpage() vp <- viewport(mask=devMask(circleGrob(gp=gpar(fill="black")), circleGrob(gp=gpar(col="white", fill="white")))) grid.group(rectGrob(gp=gpar(fill="grey"), vp=vp)) HersheyLabel("group with grob with vp vp is viewport with mask result is grey circle") ## Path in group grid.newpage() grid.group(fillGrob(circleGrob(1:2/3, r=.3), gp=gpar(fill="grey"))) HersheyLabel("group with (filled) path") ## Group in group grid.newpage() gt <- gTree(children=gList(rectGrob(width=.5, gp=gpar(fill=rgb(1,0,0,.5))), groupGrob(rectGrob(height=.5, gp=gpar(fill=rgb(0,0,1,.5)))))) grid.group(gt) HersheyLabel("group containing group both groups semitransparent see overlap between groups") grid.newpage() rects <- gTree(children=gList(rectGrob(width=unit(5, "mm"), height=unit(5, "mm"), just=c("left", "bottom"), gp=gpar(fill="black")), rectGrob(width=unit(5, "mm"), height=unit(5, "mm"), just=c("right", "top"), gp=gpar(fill="black")))) pat <- pattern(rects, width=unit(1, "cm"), height=unit(1, "cm"), extend="repeat") grid.rect(gp=gpar(fill=pat)) gt1 <- gTree(children=gList(rectGrob(width=.5, gp=gpar(fill=2)), rectGrob(height=.5, gp=gpar(fill=4)))) vp <- viewport(mask=devMask(rectGrob(gp=gpar(col=NA, fill=rgb(0,0,0,.7))), rectGrob(gp=gpar(col=NA, fill=grey(.7))))) g1 <- groupGrob(gt1, vp=vp) gt2 <- gTree(children=gList(g1, segmentsGrob(gp=gpar(lwd=100)))) g2 <- groupGrob(gt2, vp=vp) grid.draw(g2) grid.rect(width=.8, height=.4, gp=gpar(col=NA, fill=rgb(1,1,1,.7))) HersheyLabel("group containing group inner group overlapping rects inner group drawn with semitransparent mask (see through blue rect - no overlap visible) outer group thick black line outer group drawn with semitransparent mask (see through black line - no overlap visible) [white rect just background for this label]") ## Group used with transform in group used with transform grid.newpage() vp1 <- viewport(x=.3, y=.2, width=.3, height=.3) vp2 <- viewport(x=.5, y=.6, width=.1, height=.3) vp3 <- viewport(x=.7, y=.2, width=.3, height=.3) pushViewport(vp1) grid.rect(gp=gpar(col="grey")) grid.define(polygonGrob(c(.2, .5, .8), c(.2, .8, .2), gp=gpar(lwd=10, col=2, fill=3)), name="p") grid.use("p") popViewport() pushViewport(vp2) grid.rect(gp=gpar(col="grey")) grid.use("p") grid.define(useGrob("p"), name="g") popViewport() pushViewport(vp3) grid.rect(gp=gpar(col="grey")) grid.use("g") popViewport() HersheyLabel("bottom left is group-1 definition top is reuse of group-1 with horiz squash top is also group-2 definition bottom right is reuse of group-2 with horiz stretch", y=.9) grid.newpage() vp1 <- viewport(x=.2, y=.2, width=.3, height=.3) vp2 <- viewport(x=.3, y=.5, width=.1, height=.2, angle=-30) vp3 <- viewport(x=.7, y=.7, width=.5, height=.5) pushViewport(vp1) grid.rect(gp=gpar(col="grey")) grid.define(polygonGrob(c(.2, .5, .8), c(.2, .8, .2), gp=gpar(lwd=10, col=2, fill=3)), name="r") grid.use("r") popViewport() pushViewport(vp2) grid.rect(gp=gpar(lty="dotted")) popViewport() g <- useGrob("r", vp=vp2) grid.draw(g) pushViewport(vp3) grid.rect() pushViewport(vp1) grid.rect(gp=gpar(col="grey")) popViewport() pushViewport(vp2) grid.rect(gp=gpar(lty="dotted")) popViewport() grid.define(g, name="g") grid.use("g") popViewport() pushViewport(viewport(.7, .2, width=.5, height=.3)) grid.rect() grid.use("g") popViewport() HersheyLabel("bottom-left is group-1 definition group-1 reused with horiz. stretch and rotation top-right is group-2 definition (based on group-1) bottom-right is group-2 reused with vert. squash", y=.85) ## Raster in group grid.newpage() group <- gTree(children=gList(rectGrob(width=.8, height=.5), rasterGrob(matrix(c(0:1, 1:0), nrow=2), width=.2, height=.2, interpolate=FALSE))) grid.group(group) HersheyLabel("group with raster", y=.8) ## Group with rect with gradient fill grid.newpage() grid.group(rectGrob(width=.5, height=.5, gp=gpar(fill=linearGradient()))) HersheyLabel("group based on rect rect has linear gradient", y=.1) ## Group with gradient fill grid.newpage() grid.group(rectGrob(width=.5, height=.5), gp=gpar(fill=linearGradient())) HersheyLabel("group based on rect GROUP has linear gradient", y=.1) ## Group with multiple shapes with gradient fill grid.newpage() grid.group(gTree(children=gList(rectGrob(.25, .25, .5, .5), rectGrob(.75, .75, .5, .5))), gp=gpar(fill=linearGradient())) HersheyLabel("group based on two rects GROUP has linear gradient", y=.1) ## Subtler problem (need fill captured on definition) grid.newpage() grid.define(rectGrob(width=.5, height=.5), gp=gpar(fill=linearGradient()), name="g") grid.use("g") HersheyLabel("group based on rect GROUP has linear gradient group defined then used", y=.1) ## Group points/coords include src and dst even if they are not drawn ## (so linear gradient starts at bottom left of page NOT at centre of page) grid.newpage() grid.group(circleGrob(.25, .25, .5, gp=gpar(fill="black")), "dest.out", rectGrob(.75, .75, .5, .5), gp=gpar(fill=linearGradient())) HersheyLabel("group based on circle and rect circle clears rect GROUP has linear gradient gradient extent is rect AND circle extent", y=.3) ## Group with shapes that do NOT start at bottom-left grid.newpage() grid.group(circleGrob(3:4/5, 3:4/5, r=.1), gp=gpar(fill=linearGradient())) HersheyLabel("group based on circles GROUP has linear gradient gradient extent is circle extent", y=.3) ################################################################################ TODO <- function() { }