Seeing Through grid Graphics

 

Paul Murrell, paul@stat.auckland.ac.nz

The University of Auckland

```{r echo=FALSE, results="hide", message=FALSE} opts_chunk$set(tidy=FALSE, highlight=TRUE) library(lattice) library(ggplot2) library(grid) library(XML) library(gridSVG) mtcars$trans <- factor(mtcars$am, levels=0:1, labels=c("automatic", "manual")) trellis.pars <- list(plot.symbol=list(pch=16)) ``` Seeing Through grid Graphics ======================

*The* Big Idea: **Don't be a Dead End**
```{r results="hide"} ``` R Graphics ========== ```{r echo=FALSE, fig.keep="none", comment=NA, results="hide"} textbox <- function(text, vp, bg="grey", col="black", fg=NA, label=text) { rg <- roundrectGrob(width=stringWidth(text) + unit(4, "mm"), height=unit(1.5, "lines"), gp=gpar(col=fg, fill=bg), vp=vp, name=label) grid.draw(rg) grid.text(text, gp=gpar(col=col), vp=vp) rg } setupvp <- function(row, col) { pushViewport(viewport(layout.pos.row=row, layout.pos.col=col, name=paste(row, col, sep=""))) upViewport() } arrow <- arrow(type="closed", length=unit(3, "mm"), angle=15) lineDown <- function(from, to, o=270, i=90, c=1) { grid.curve(grobX(from, o), grobY(from, o), grobX(to, i), grobY(to, i), curvature=c*.4, square=FALSE, ncp=10, arrow=arrow, gp=gpar(fill="black")) } svg("Rgraphics.svg", width=6, height=6) grid.newpage() pushViewport(viewport(layout=grid.layout(4, 4))) pushViewport(viewport(layout.pos.row=2:3, layout.pos.col=1:3)) grid.roundrect(gp=gpar(col=NA, fill="grey90")) popViewport() setupvp(1, 2) setupvp(1, 4) setupvp(2, 1) setupvp(2, 3) setupvp(3, 2) setupvp(3, 4) setupvp(4, 1) setupvp(4, 3) lattice <- textbox("lattice", "12", "white", fg="black") ggplot2 <- textbox("ggplot2", "14") graphics <- textbox("graphics", "21") grid <- textbox("grid", "23", "white", fg="black") grDevices <- textbox("grDevices", "32") gridSVG <- textbox("gridSVG", "34", "white", fg="black") PNG <- textbox("PNG", "41") SVG <- textbox("SVG", "43", "black", "white") lineDown(lattice, grid, o=0, c=-1) lineDown(ggplot2, grid, o=180) lineDown(graphics, grDevices, i=180) lineDown(grid, grDevices, i=0, c=-1) lineDown(grid, gridSVG, o=0, c=-1) lineDown(grDevices, PNG, i=0, c=-1) lineDown(grDevices, SVG, i=180) lineDown(gridSVG, SVG, i=0, c=-1) dev.off() ``` An Example Plot ====================== ```{r plot, results="hide"} library(lattice) plot <- xyplot(mpg ~ disp | trans, data=mtcars) ``` ```{r echo=FALSE, results="hide"} svg("plot.svg") trellis.par.set(trellis.pars) print(plot) dev.off() ```
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("plot.svg"))) ```
An Example Plot ====================== What can I do with this plot **AFTER** it has been drawn ?
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("plot.svg"))) ```
Not Interested ==============
     xyplot(x,
            data,
            allow.multiple = is.null(groups) || outer,
            outer = !is.null(groups),
            auto.key = FALSE,
            aspect = "fill",
            panel = lattice.getOption("panel.xyplot"),
            prepanel = NULL,
            scales = list(),
            strip = TRUE,
            groups = NULL,
            xlab,
            xlim,
            ylab,
            ylim,
            drop.unused.levels = lattice.getOption("drop.unused.levels"),
            ...,
Allow More Drawing ====================== ```{r echo=FALSE, results="hide"} svg("plot-draw.svg") trellis.par.set(trellis.pars) print(plot) grid.rect(width=rep(.99, 3), height=rep(.99, 3), gp=gpar(lty=c("solid", "solid", "dashed"), lwd=c(7, 3, 3), col=c("black", "white"), fill=NA)) dev.off() ``` ```{r eval=FALSE} print(plot) grid.rect() ```
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("plot-draw.svg"))) ```
Allow More Drawing ====================== An Example Plot ====================== What can I do with this plot **AFTER** it has been drawn ?
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("plot.svg"))) ```
Remember the Drawing Context ====================== ```{r eval=FALSE} print(plot) showViewport() ``` ```{r echo=FALSE, results="hide"} svg("plot-viewports.svg") print(plot) showViewport(depth=2, newpage=TRUE) grid.remove("text", grep=TRUE, global=TRUE) dev.off() ```
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("plot-viewports.svg"))) ```
Allow Access to the Drawing Context ==================== ```{r eval=FALSE} print(plot) downViewport("plot_01.panel.1.2.vp") grid.text("Ferrari Dino", x=155, y=19.7, just="left", default="native") ``` ```{r echo=FALSE, results="hide"} gridsvg("plot-downvp.svg", res=96) trellis.par.set(trellis.pars) print(plot) downViewport("plot_01.panel.2.1.vp") grid.text("Ferrari Dino", x=155, y=19.7, just="left", default="native", gp=gpar(col="red3")) dev.off() ```
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("plot-downvp.svg"))) ```
Allow Access to the Drawing Context ====================

 

+

Remember What was Drawn ====================== ```{r eval=FALSE} print(plot) showGrob() ``` ```{r echo=FALSE, results="hide"} svg("plot-grobs.svg") print(plot) mylabel <- function(grob, ...) { if (inherits(grob, "text")) { grid:::grobLabel(grob, ...) } else { grob } } showGrob(labelfun=mylabel, gp=gpar(col=NA, fill=rgb(1, 0, 0, 0.2))) dev.off() ```
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("plot-grobs.svg"))) ```
Allow Access to What was Drawn ==================== ```{r eval=FALSE} print(plot) grid.edit("plot_01.xlab", label="Engine Displacement") ``` ```{r echo=FALSE, results="hide"} svg("plot-editgrob.svg") trellis.par.set(trellis.pars) print(plot) grid.edit("plot_01.xlab", label="Engine Displacement") showGrob(gPath="plot_01.xlab", gp=gpar(col=NA, fill=rgb(1, 0, 0, 0.2))) dev.off() ```

Allow Access to What was Drawn ====================

 

 → 

Allow Labels and Structure ====================== ```{r eval=FALSE} grid.roundrect(gp=gpar(col=NA, fill=rgb(1,0,0,.5)), name="box") grid.text("Ferrari Dino", name="label") ``` ```{r echo=FALSE, results="hide"} gridsvg("labels.svg", width=4, height=1, res=96) grid.roundrect(gp=gpar(col=NA, fill=rgb(1,0,0,.5)), r=unit(.5, "in"), name="box") grid.text("Ferrari Dino", gp=gpar(cex=4), name="label") dev.off() ```
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("labels.svg"))) ```
```{r eval=FALSE} grid.ls() ``` ```{r echo=FALSE, fig.keep="none", comment=NA} grid.roundrect(gp=gpar(col=NA, fill=rgb(1,0,0,.5)), name="box") grid.text("Ferrari Dino", name="label") grid.ls() ``` Allow Labels and Structure ====================== ```{r eval=FALSE} gTree(children=gList(roundrectGrob(gp=gpar(col=NA, fill=rgb(1,0,0,.5)), name="box"), textGrob("Ferrari Dino", name="label")), name="boxedLabel") ``` ```{r echo=FALSE, results="hide"} gridsvg("labels.svg", width=4, height=1, res=96) grid.draw( gTree(children=gList(roundrectGrob(gp=gpar(col=NA, fill=rgb(1,0,0,.5)), r=unit(.5, "in"), name="box"), textGrob("Ferrari Dino", gp=gpar(cex=4), name="label")), name="boxedLabel") ) dev.off() ```
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("labels.svg"))) ```
```{r eval=FALSE} grid.ls() ``` ```{r echo=FALSE, fig.keep="none", comment=NA} grid.draw( gTree(children=gList(roundrectGrob(gp=gpar(col=NA, fill=rgb(1,0,0,.5)), name="box"), textGrob("Ferrari Dino", name="label")), name="boxedLabel") ) grid.ls() ``` The Example Plot ======================
```{r echo=FALSE, results="asis"} cat(saveXML(xmlParse("plot.svg"))) ```
Provide Labels and Structure ====================== ```{r eval=FALSE} print(plot) grid.ls(viewports=TRUE) ``` ```{r echo=FALSE, fig.keep="none", comment=NA} print(plot) temp <- grid.ls(viewports=TRUE, fullNames=TRUE, print=FALSE) cl <- class(temp) temp <- lapply(temp, "[", 1:10) temp <- lapply(temp, "[", !grepl("vpUpListing", temp$type)) class(temp) <- cl temp ``` Export Labels and Structure ================== Export Labels and Structure ================== R code ...
library(gridSVG)
print(plot)
grid.export()
SVG code ...
<svg>
  <rect id="plot_01.background.1.1"/>
  <g id="plot_01.toplevel.vp.1">
    <g id="plot_01.toplevel.vp::plot_01.xlab.vp.1">
      <text id="plot_01.xlab.1">
...
Export Labels and Structure ========== The Royal Society of New Zealand: Languages in Aotearoa New Zealand Export Labels and Structure ========== ```{r echo=FALSE, fig.keep="none", comment=NA} textbox <- function(text, vp, bg="grey", col="black", label=text) { grid.roundrect(width=stringWidth(text) + unit(4, "mm"), height=unit(1.5, "lines"), gp=gpar(col=NA, fill=bg), vp=vp, name=label) grid.text(text, gp=gpar(col=col), vp=vp) } gridsvg("diagram.svg", width=6, height=3) pushViewport(viewport(layout=grid.layout(2, 4))) pushViewport(viewport(layout.pos.row=2, layout.pos.col=1, name="21")) upViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=2, name="22")) upViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=3, name="23")) upViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=4, name="24")) upViewport() pushViewport(viewport(layout.pos.row=1, layout.pos.col=4, name="14")) upViewport() textbox("grid", "21") textbox("lattice", "22") textbox("gridSVG", "23") textbox("SVG", "24", "black", "white") textbox("javascript", "14") arrow <- arrow(type="closed", length=unit(3, "mm"), angle=15) grid.segments(grobX("grid", 0), grobY("grid", 0), grobX("lattice", 180), grobY("lattice", 180), arrow=arrow, gp=gpar(fill="black")) grid.segments(grobX("lattice", 0), grobY("lattice", 0), grobX("gridSVG", 180), grobY("gridSVG", 180), arrow=arrow, gp=gpar(fill="black")) grid.segments(grobX("gridSVG", 0), grobY("gridSVG", 0), grobX("SVG", 180), grobY("SVG", 180), arrow=arrow, gp=gpar(fill="black")) grid.segments(grobX("javascript", 270), grobY("javascript", 270), grobX("SVG", 90), grobY("SVG", 90), arrow=arrow, gp=gpar(fill="black")) dev.off() ``` Export Labels and Structure ========== R code ...
pushViewport(viewport(name="viewport"))
grid.polygon("ID:1")
grid.polygon("ID:2")
...
SVG code ...
<svg>
  <g id="viewport">
    <polygon id="ID:1" .../>
    <polygon id="ID:2" .../>
...
Javascript code ...
svgRoot = root.getElementById("viewport");
...
Don't be a Dead End ========== The Royal Society of New Zealand: Languages in Aotearoa New Zealand (**original**) Don't be a Dead End ========== The Royal Society of New Zealand: Languages in Aotearoa New Zealand (**recycled**) Don't be a Dead End ========== ```{r echo=FALSE, fig.keep="none", comment=NA} gridsvg("diagram-2.svg", width=6, height=3) pushViewport(viewport(layout=grid.layout(2, 6))) pushViewport(viewport(layout.pos.row=2, layout.pos.col=1, name="21")) upViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=2, name="22")) upViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=3, name="23")) upViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=4, name="24")) upViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=5, name="25")) upViewport() pushViewport(viewport(layout.pos.row=2, layout.pos.col=6, name="26")) upViewport() pushViewport(viewport(layout.pos.row=1, layout.pos.col=4, name="14")) upViewport() textbox("grid", "21") textbox("lattice", "22") textbox("gridSVG", "23") textbox("SVG", "24", "black", "white") textbox("javascript", "14") textbox("XML", "25") textbox("SVG", "26", "black", "white", label="SVG2") arrow <- arrow(type="closed", length=unit(3, "mm"), angle=15) grid.segments(grobX("grid", 0), grobY("grid", 0), grobX("lattice", 180), grobY("lattice", 180), arrow=arrow, gp=gpar(fill="black")) grid.segments(grobX("lattice", 0), grobY("lattice", 0), grobX("gridSVG", 180), grobY("gridSVG", 180), arrow=arrow, gp=gpar(fill="black")) grid.segments(grobX("gridSVG", 0), grobY("gridSVG", 0), grobX("SVG", 180), grobY("SVG", 180), arrow=arrow, gp=gpar(fill="black")) grid.segments(grobX("javascript", 270), grobY("javascript", 270), grobX("SVG", 90), grobY("SVG", 90), arrow=arrow, gp=gpar(fill="black")) grid.segments(grobX("SVG", 0), grobY("SVG", 0), grobX("XML", 180), grobY("XML", 180), arrow=arrow, gp=gpar(fill="black")) grid.segments(grobX("XML", 0), grobY("XML", 0), grobX("SVG2", 180), grobY("SVG2", 180), arrow=arrow, gp=gpar(fill="black")) dev.off() ``` Summary ======= Don't be a Dead End - grid - Allow more drawing - Record the drawing context - Allow access to the drawing context - Record what was drawn - Allow access to what was drawn - Allow labels and structure - lattice - Provide a naming scheme - Provide structure - gridSVG - Export labels and structure Acknowledgements ========= - The plot with lots of extra drawing was adapted from Felgate, Bickler, and Murrell (2013) "Estimating parent population of pottery vessels from a sample of fragments: a case study from inter-tidal surface collections, Roviana Lagoon, Solomon Islands", Journal of Archaeological Science, 40 (2013) 1319-1328. - The raster map plot used NASA light data from Steve Mosher and a Google Map tile (copyright 2011 Google, Map Data and copyright 2011 Tele Atlas). - The forest plot was generated using the 'metaplot' package by Murrell, Scott, and Lu - The map of Multilingualism in New Zealand was created by Paul Behrens for the Royal Society of New Zealand