R/figures.R

Defines functions figure4.12 figure4.11 figure4.10 figure4.9 figure4.8 figure4.7 figure4.6 figure4.5 figure4.4 figure4.3 figure4.2 figure4.1 figure2.10 figure2.9 figure2.8 figure2.7 figure2.6 figure2.5 figure2.4 figure2.3 figure2.2 figure2.1 figure10.13 figure10.12 figure10.11 figure10.10 figure10.9 figure10.8 figure10.7 figure10.6 figure10.5 figure10.4 figure10.3 figure10.2 figure10.1 figure1.14 figure7.16 figure7.15 figure7.14 figure7.13 figure7.12 figure7.11 figure7.10 figure7.9 figure7.8 figure7.7 figure7.6 figure7.5 figure7.4 figure7.3 figure7.2 figure7.1 figure1.1 faceD faceC faceB faceA figure8.32 makeContent.splitText splitTextGrob figure8.30 splitString figure8.28 yDetails.utextvpDynamic xDetails.utextvpDynamic figure8.26 figure8.25 makeContent.utextvpDynamic makeContext.utextvpDynamic utextvpDynamic figure8.23 figure8.22 figure8.21 figure8.20 makeContent.utextDynamic utextDynamic figure8.18 figure8.17 figure8.16 editDetails.utextvpStatic utextvpStatic utextvpChildren figure8.14 figure8.13 editDetails.utextStatic figure8.11 utextStatic utextChildren figure8.9 figure8.8 figure8.7 grid.utextvp utextvp figure8.5 figure8.4 figure8.3 grid.utext textCorners figure8.1 figure11.14 figure11.13 figure11.12 figure11.11 figure11.10 figure11.9 figure11.8 figure11.7 figure11.6 figure11.5 figure11.4 figure11.3 figure11.2 figure11.1 figure5.16 figure5.15 figure5.14 figure5.13 figure5.12 figure5.11 figure5.10 figure5.9 figure5.8 figure5.7 figure5.6 figure5.5 figure5.4 figure5.3 figure5.2 figure5.1 figure13.14 figure13.13 figure13.12 figure13.11 figure13.10 figure13.9 figure13.8 figure13.7 figure13.6 figure13.5 figure13.4 figure13.3 figure13.2 figure13.1 figure1.13 figure1.12 figure1.11 figure1.10 figure1.9 figure1.8 figure1.7 figure1.6 figure1.5 figure1.4 figure1.3 figure1.2 figure6.26 figure6.25 figure6.24 figure6.23 figure6.22 figure6.21 figure6.20 figure6.19 figure6.18 figure6.17 figure6.16 figure6.15 figure6.14 figure6.13 figure6.12 figure6.11 figure6.10 figure6.9 figure6.8 figure6.7 figure6.6 figure6.5 figure6.4 figure6.3 figure6.2 figure6.1 plot.newclass figure3.29 figure3.28 figure3.27 figure3.26 figure3.25 figure3.24 figure3.23 figure3.22 figure3.21 figure3.20 figure3.19 figure3.18 figure3.17 figure3.16 figure3.15 figure3.14 figure3.13 figure3.12 figure3.11 figure3.10 figure3.9 figure3.8 figure3.7 figure3.6 figure3.5 figure3.4 figure3.3 figure3.2 figure3.1 figure12.7 figure12.6 figure12.5 figure12.4 figure12.3 figure12.2 figure12.1

Documented in faceA faceB faceC faceD figure10.1 figure10.10 figure10.11 figure10.12 figure10.13 figure10.2 figure10.3 figure10.4 figure10.5 figure10.6 figure10.7 figure10.8 figure10.9 figure1.1 figure1.10 figure1.11 figure11.1 figure11.10 figure11.11 figure11.12 figure11.13 figure11.14 figure1.12 figure11.2 figure1.13 figure11.3 figure1.14 figure11.4 figure11.5 figure11.6 figure11.7 figure11.8 figure11.9 figure1.2 figure12.1 figure12.2 figure12.3 figure12.4 figure12.5 figure12.6 figure12.7 figure1.3 figure13.1 figure13.10 figure13.11 figure13.12 figure13.13 figure13.14 figure13.2 figure13.3 figure13.4 figure13.5 figure13.6 figure13.7 figure13.8 figure13.9 figure1.4 figure1.5 figure1.6 figure1.7 figure1.8 figure1.9 figure2.1 figure2.10 figure2.2 figure2.3 figure2.4 figure2.5 figure2.6 figure2.7 figure2.8 figure2.9 figure3.1 figure3.10 figure3.11 figure3.12 figure3.13 figure3.14 figure3.15 figure3.16 figure3.17 figure3.18 figure3.19 figure3.2 figure3.20 figure3.21 figure3.22 figure3.23 figure3.24 figure3.25 figure3.26 figure3.27 figure3.28 figure3.29 figure3.3 figure3.4 figure3.5 figure3.6 figure3.7 figure3.8 figure3.9 figure4.1 figure4.10 figure4.11 figure4.12 figure4.2 figure4.3 figure4.4 figure4.5 figure4.6 figure4.7 figure4.8 figure4.9 figure5.1 figure5.10 figure5.11 figure5.12 figure5.13 figure5.14 figure5.15 figure5.16 figure5.2 figure5.3 figure5.4 figure5.5 figure5.6 figure5.7 figure5.8 figure5.9 figure6.1 figure6.10 figure6.11 figure6.12 figure6.13 figure6.14 figure6.15 figure6.16 figure6.17 figure6.18 figure6.19 figure6.2 figure6.20 figure6.21 figure6.22 figure6.23 figure6.24 figure6.25 figure6.26 figure6.3 figure6.4 figure6.5 figure6.6 figure6.7 figure6.8 figure6.9 figure7.1 figure7.10 figure7.11 figure7.12 figure7.13 figure7.14 figure7.15 figure7.16 figure7.2 figure7.3 figure7.4 figure7.5 figure7.6 figure7.7 figure7.8 figure7.9 figure8.1 figure8.11 figure8.13 figure8.14 figure8.16 figure8.17 figure8.18 figure8.20 figure8.21 figure8.22 figure8.23 figure8.25 figure8.26 figure8.28 figure8.3 figure8.30 figure8.32 figure8.4 figure8.5 figure8.7 figure8.8 figure8.9 grid.utext grid.utextvp plot.newclass splitString splitTextGrob textCorners utextChildren utextDynamic utextStatic utextvp utextvpChildren utextvpDynamic utextvpStatic

figure12.1 <- function() {

m <- factor(months(zoo::as.yearmon(time(datasets::sunspots))),
            levels=month.name)
plot(m, datasets::sunspots, axes=FALSE)
axis(2)
axis(1, at=1:12, labels=FALSE)


}
figure12.2 <- function() {

m <- factor(months(zoo::as.yearmon(time(datasets::sunspots))),
            levels=month.name)
plot(m, datasets::sunspots, axes=FALSE)
axis(2)
axis(1, at=1:12, labels=FALSE)

vps <- gridBase::baseViewports()
pushViewport(vps$inner, vps$figure, vps$plot)

grid.text(month.name, 
          x=unit(1:12, "native"), y=unit(-1, "lines"),
          just="right", rot=60)
popViewport(3)




}
figure12.3 <- function() {
hc <- hclust(dist(USArrests), "ave")
dend1 <- as.dendrogram(hc)
dend2 <- cut(dend1, h=70)



x <- 1:4
y <- 1:4
height <- factor(round(sapply(dend2$lower, 
                              attr, "height")))



space <- 1.2 * max(stringWidth(rownames(USArrests)))
dendpanel <- function(x, y, subscripts, ...) {
  pushViewport(viewport(gp=gpar(fontsize=8)),
               viewport(y=unit(0.95, "npc"), width=0.9,
                        height=unit(0.95, "npc") - space,
                        just="top"))
  par(plt=gridBase::gridPLT(), new=TRUE, ps=8)
  plot(dend2$lower[[subscripts]], axes=FALSE)
  popViewport(2)
}



trellis.par.set(theme = canonical.theme("postscript", color=FALSE))
plot.new()
print(xyplot(y ~ x | height, subscripts=TRUE, 
             xlab="", ylab="",
             strip=strip.custom(style=4), 
             scales=list(draw=FALSE), 
             panel=dendpanel),
      newpage=FALSE)




}
figure12.4 <- function() {

m <- factor(months(zoo::as.yearmon(time(datasets::sunspots))),
            levels=month.name)
plot(m, datasets::sunspots, axes=FALSE)
axis(2)
axis(1, at=1:12, labels=FALSE)


plot(m, datasets::sunspots)


}
figure12.5 <- function() {

m <- factor(months(zoo::as.yearmon(time(datasets::sunspots))),
            levels=month.name)
plot(m, datasets::sunspots, axes=FALSE)
axis(2)
axis(1, at=1:12, labels=FALSE)


dev.control("enable")
plot(m, datasets::sunspots)
grid.echo()
grid.edit("graphics-plot-1-bottom-axis-labels-1", 
          y=unit(-1, "lines"), hjust=1, vjust=0.5, rot=60)


}
figure12.6 <- function() {
hc <- hclust(dist(USArrests), "ave")
dend1 <- as.dendrogram(hc)
dend2 <- cut(dend1, h=70)



x <- 1:4
y <- 1:4
height <- factor(round(sapply(dend2$lower, 
                              attr, "height")))



dendpanel <- function(x, y, subscripts, ...) {
  pushViewport(viewport(gp=gpar(fontsize=8)),
               viewport(y=unit(0.95, "npc"), 
                        height=unit(0.95, "npc"),
                        just="top"))
  grid.echo(function() {
                par(mar=c(5.1, 0, 1, 0))
                plot(dend2$lower[[subscripts]], axes=FALSE)
            },
            newpage=FALSE, 
            prefix=paste0("dend-", panel.number()))
  popViewport(2)
}


xyplot(y ~ x | height, subscripts=TRUE, 
       xlab="", ylab="",
       strip=strip.custom(style=4), 
       scales=list(draw=FALSE), 
       panel=dendpanel)


}
figure12.7 <- function() {



cpfun <- function() {
    coplot(lat ~ long | depth, datasets::quakes, pch=16, cex=.5,
           given.values=rbind(c(0, 400), c(300, 700)))
}
pushViewport(viewport(y=0, height=.7, just="bottom"))
grid.echo(cpfun, newpage=FALSE, prefix="cp")
upViewport()

pushViewport(viewport(y=1, height=.33, just="top"))
gg <- ggplot(datasets::quakes) + geom_histogram(aes(x=depth)) +
      theme(axis.title.x = element_blank())
print(gg, newpage=FALSE)
upViewport()


}
figure3.1 <- function() {
par(oma=rep(3, 4), bg="gray80")
plot(c(0, 1), c(0, 1), type="n", ann=FALSE, axes=FALSE)
box("outer", col="gray")
# set clipping to figure region
par(xpd=TRUE)
# deliberately draw a stupidly large rectangle
rect(-1, -1, 2, 2, col="gray90")
box("figure")
# set clipping back to plot region
par(xpd=FALSE)
# deliberately draw a stupidly large rectangle
rect(-1, -1, 2, 2, col="gray80")
box("plot", lty="dashed")
text(.5, .5, "Plot Region")
mtext("Figure Region", side=3, line=2)
for (i in 1:4)
    mtext(paste("Outer margin", i), side=i, line=1, outer=TRUE)



}
figure3.2 <- function() {
par(oma=rep(3, 4), mfrow=c(3,2), bg="gray80")
for (i in 1:6) {
    if (i == 3) {
      omar <- par(mar=c(2, 2, 2, 1))  
      plot(c(0, 1), c(0, 1), type="n", ann=FALSE, axes=FALSE)
      par(xpd=TRUE)
      rect(-1, -1, 2, 2, col="gray90")
      box("figure")
      par(xpd=FALSE)
      rect(-1, -1, 2, 2, col="gray80")
      box("plot", lty="dashed")
      text(.5, .5, "Current Plot Region", cex=1.5)
      mtext("Current Figure Region", side=3)
      par(omar)
    } else {
      omar <- par(mar=rep(0, 4))  
      plot(c(0, 1), c(0, 1), type="n", ann=FALSE, axes=FALSE)
      par(xpd=TRUE)
      rect(-1, -1, 2, 2, col="gray90")
      box("figure")
      text(.5, .5, paste("Figure", i), cex=1.5)
      par(omar)
    }
}
box("outer", col="gray")
for (i in 1:4)
    mtext(paste("Outer margin", i), side=i, line=1, outer=TRUE)



}
figure3.3 <- function() {
par(mar=c(3, 6, 2, 2), xaxs="i", yaxs="i", xpd=FALSE, las=1)
    plot(c(0, 1), c(0, 1), type="n", ann=FALSE, axes=FALSE)
    box("figure")
    rect(0, 0, 1, 1, col="light gray", border="gray")
    axis(1, at=c(0, 1), c("", ""))
    mtext("Min x-value", side=1, adj=0, line=1)
    mtext("Max x-value", side=1, adj=1, line=1)
    axis(2, at=c(0, 1), c("", ""))
    mtext("Min y-value", side=2, at=0, adj=1, line=1)
    mtext("Max y-value", side=2, at=1, adj=1, line=1)
    lines(c(.6, .6, 0), c(0, .6, .6), lty="dashed")
    text(.6, .6, expression(paste("The location ", 
            group("(",list(x[i], y[i]),")"))), pos=3)
    points(.6, .6, pch=16)
    axis(1, at=.6, "")
    mtext(expression(x[i]), side=1, at=.6, line=.7)
    axis(2, at=.6, "")
    mtext(expression(y[i]), side=2, at=.6, line=.7)
        



}
figure3.4 <- function() {
pushViewport(viewport(layout=grid.layout(3, 1, 
  heights=unit(rep(1, 3), c("null", "cm", "null")))))
pushViewport(viewport(layout.pos.row=1))
grid.rect()
pushViewport(plotViewport(c(5, 5, 3, 2), xscale=c(0, 11)))
grid.rect(gp=gpar(col="gray"))
grid.text("Current Plot", gp=gpar(col="gray"))
grid.rect(0, unit(-5, "lines"), 1, unit(5, "lines"),
          just=c("left", "bottom"), gp=gpar(col="gray", fill="light gray"))
grid.text("Figure\nMargin\n1", y=unit(-2.5, "lines"))
grid.lines(c(0, 1), c(0, 0))
grid.segments(c(0, 1), c(0, 0), c(0, 1), unit(c(.5, .5), "lines"))
grid.text(c("xmin", "xmax"), c(0, 1), unit(c(1, 1), "lines"))
grid.lines(c(0, 0), unit(c(-1, -4), "lines"))
grid.segments(c(0, 0), unit(c(-1, -4), "lines"), 
              unit(c(-.5, -.5), "lines"), unit(c(-1, -4), "lines"))
grid.text(c("0 lines", "3 lines"),
          unit(c(-1, -1), "lines"), unit(c(-1, -4), "lines"),
          just=c("right", "bottom"))
popViewport(2)
pushViewport(viewport(layout.pos.row=3))
grid.rect()
pushViewport(plotViewport(c(5, 5, 3, 2), yscale=c(0, 11)))
grid.rect(gp=gpar(col="gray"))
grid.text("Current Plot", gp=gpar(col="gray"))
grid.rect(unit(-5, "lines"), 0, unit(5, "lines"), 1,
          just=c("left", "bottom"), gp=gpar(col="gray", fill="light gray"))
grid.text("Figure\nMargin\n2", x=unit(-2.5, "lines"))
grid.lines(c(0, 0), c(0, 1))
grid.segments(c(0, 0), c(0, 1), unit(c(.5, .5), "lines"), c(0, 1))
grid.text(c("ymin", "ymax"), unit(c(1, 1), "lines"), c(0, 1), just="left")
grid.lines(unit(c(0, -3), "lines"), c(0, 0))
grid.segments(unit(c(0, -3), "lines"), c(0, 0), 
              unit(c(0, -3), "lines"), unit(c(-.5, -.5), "lines"))
grid.text(c("0 lines", "3 lines"),
          unit(c(0, -3), "lines"), unit(c(-1, -1), "lines"),
          rot=90, just=c("right", "bottom"))
popViewport(2)
popViewport()



}
figure3.5 <- function() {
pushViewport(viewport(layout=grid.layout(3, 1, 
  heights=unit(c(1, 1, 1), c("null", "cm", "null")))))

# First page
pushViewport(viewport(layout.pos.row=3, 
  layout=grid.layout(3, 4, 
    widths=unit(c(2.5, 1, 1, 1), c("cm", "null", "null", "cm")),
    heights=unit(c(1, 1, 2.5), c("cm", "null", "cm")))))
grid.rect(gp=gpar(col="black"))
for (i in 2) {
  for (j in 2:3) {
    pushViewport(viewport(layout.pos.col=j, layout.pos.row=i))
    grid.rect(gp=gpar(col="gray"))
      pushViewport(plotViewport(c(2, 2, 1, 1), xscale=c(0, 11),
        gp=gpar(col="gray")))
      grid.rect(gp=gpar(col="gray"))
      grid.text(paste("Plot", j - 1))
      popViewport()      
    popViewport()
  }
}
pushViewport(viewport(layout.pos.row=2, layout.pos.col=1))
grid.rect(gp=gpar(col="gray", fill="light gray"))
grid.text("Outer\nMargin\n2")
grid.lines(c(1, 1), c(0, 1))
grid.segments(c(1, 1), c(0, 1), 
              unit(1, "npc") + unit(c(.5, .5), "lines"),
              c(0, 1))
grid.text(0:1, 
          unit(1, "npc") + unit(c(1, 1), "lines"),
	  c(0, 1))
grid.lines(unit(1, "npc") - unit(c(0, 3), "lines"), c(0, 0))
grid.segments(unit(1, "npc") - unit(c(0, 3), "lines"), 
	      c(0, 0), 
              unit(1, "npc") - unit(c(0, 3), "lines"), 
	      unit(c(-.5, -.5), "lines"))
grid.text(c("0 lines", "3 lines"),
          unit(1, "npc") - unit(c(0, 3), "lines"),
          unit(c(-1, -1), "lines"),
          rot=90, just=c("right", "bottom"))
popViewport(2)

# Second page
pushViewport(viewport(layout.pos.row=1, 
  layout=grid.layout(3, 4, 
    widths=unit(c(2.5, 1, 1, 1), c("cm", "null", "null", "cm")),
    heights=unit(c(1, 1, 2.5), c("cm", "null", "cm")))))
grid.rect(gp=gpar(col="black"))
for (i in 2) {
  for (j in 2:3) {
    pushViewport(viewport(layout.pos.col=j, layout.pos.row=i))
    grid.rect(gp=gpar(col="gray"))
      pushViewport(plotViewport(c(2, 2, 1, 1), xscale=c(0, 11),
        gp=gpar(col="gray")))
      grid.rect(gp=gpar(col="gray"))
      grid.text(paste("Plot", j - 1))
      popViewport()      
    popViewport()
  }
}
pushViewport(viewport(layout.pos.row=3, layout.pos.col=2:3))
grid.rect(gp=gpar(col="gray", fill="light gray"))
grid.text("Outer Margin 1")
grid.lines(c(0, 1), c(1, 1))
grid.segments(c(0, 1), 
              unit(c(1, 1), "npc"),
	      c(0, 1),
              unit(c(1, 1), "npc") + unit(.5, "lines"))
# grid.rect(c(0, 1), 
# 	  unit(c(1, 1), "npc") + unit(1, "lines"),
# 	  unit(c(1, 1), "strwidth", list("0", "1")),
# 	  unit(c(1, 1), "strheight", list("0", "1")),
# 	  gp=gpar(col=NULL, fill="white"))
grid.text(c(0, 1), 
          c(0, 1),
          unit(c(1, 1), "npc") + unit(1, "lines"))
grid.lines(c(0, 0), unit(1, "npc") - unit(c(1, 4), "lines"))
grid.segments(c(0, 0), 
              unit(1, "npc") - unit(c(1, 4), "lines"), 
	      unit(c(-.5, -.5), "lines"),
              unit(1, "npc") - unit(c(1, 4), "lines"))
grid.text(c("0 lines", "3 lines"),
          unit(c(-1, -1), "lines"),
	  unit(1, "npc") - unit(c(1, 4), "lines"),
          just=c("right", "bottom"))
popViewport(2)

popViewport()



}
figure3.6 <- function() {
EU1992 <- window(datasets::EuStockMarkets, 1992, 1993)
par(lty="dashed")
plot(EU1992[,"DAX"], ylim=range(EU1992))
lines(EU1992[,"CAC"], lty="solid")
lines(EU1992[,"FTSE"])


}
figure3.7 <- function() {
par(mar=rep(0, 4), cex=0.7)
plot.new()
plot.window(c(0.05, 0.95), 0:1)
family <- c("sans", "serif", "mono")
face <- 1:4
for (i in 1:4)
  for (j in 1:3) {
    par(family=family[j], lheight=1.5)
    text(seq(.15, .85, length=4)[i],
         seq(.25, .75, length=3)[j],
         paste("family=\"", family[j], "\"\nfont=", face[i], sep=""),
         font=face[i])
  }
segments(.02, c(.125, .375, .625, .875), 
         .98, c(.125, .375, .625, .875), col="gray")
segments(.02, c(.125, .375, .625, .875) - .01, 
         .02, c(.125, .375, .625, .875) + .01, col="gray")
segments(.98, c(.125, .375, .625, .875) - .01, 
         .98, c(.125, .375, .625, .875) + .01, col="gray")
rect(c(.27, .5, .73) - .01,
     .1,
     c(.27, .5, .73) + .01,
     .9, col="white", border=NA)



}
figure3.8 <- function() {
par(mar=rep(0, 4), xaxs="i", yaxs="i", cex=0.8)
plot.new()
par(new=TRUE)
grid.rect(gp=gpar(col="gray"))
ncol <- 4
nrow <- 4
xadj <- c(1, 0.5, NA, 0)
yadj <- c(1, 0.5, NA, 0)
size <- unit(3, "mm")
for (i in 1:nrow) {
  for (j in 1:ncol) {
    x <- i/(nrow + 1)
    y <- j/(ncol + 1)
    xu <- unit(x, "npc")
    yu <- unit(y, "npc")
    grid.segments(unit.c(xu - size, xu),
                  unit.c(yu, yu - size),
                  unit.c(xu + size, xu),
                  unit.c(yu, yu + size),
		  gp=gpar(col="gray"))
    text(x, y, paste("c(", xadj[j], ", ", yadj[i], ")", sep=""),
         adj=c(xadj[j], yadj[i]))
  }
}



}
figure3.9 <- function() {
ncol <- 6
nrow <- 1
grid.rect(gp=gpar(col="gray"))
for (i in 1:nrow) {
  for (j in 1:ncol) {
    x <- unit(j/(ncol+1), "npc")
    y <- unit(i/(nrow + 1), "npc")
    pch <- (i - 1)*ncol + j - 1
    grid.points(x + unit(3, "mm"), y, 
      pch=pch, gp=gpar(fill="gray"))
    grid.text(pch, x - unit(3, "mm"), y, gp=gpar(col="gray"))
  }
}



}
figure3.10 <- function() {
x <- -5:5
y <- -x^2 + 25
plottype <- function(type) {
  par(mar=c(1, 0, 1, 0), pty="s")
  plot.new()
  plot.window(c(-6, 6), c(-2, 27))
  box(col="gray")
  points(x, y, type=type)
  mtext(paste("type=\"", type, "\"", sep=""))
}



par(mfrow=c(3, 2))
plottype("p")
plottype("l")
plottype("b")
plottype("o")
plottype("h")
plottype("s")



}
figure3.11 <- function() {
axisfun <- function(mgp=c(3, 1, 0), xaxs="r", tcl=-.5,
                    mgpcol="black", xaxscol="black", tclcol="black") {
  par(mar=c(4, 1, 0, 1), mgp=mgp, xaxs=xaxs, tcl=tcl, pty="s")
  plot.new()
  box(col="gray")
  text(.5, .75, paste("mgp=c(", paste(mgp, collapse=", "), ")", sep=""),
       col=mgpcol)
  text(.5, .5, paste("xaxs=\"", xaxs, "\"", sep=""),
       col=xaxscol)
  text(.5, .25, paste("tcl=", tcl, sep=""),
       col=tclcol)
  axis(1, at=c(0, .5, 1))
  title(xlab="X-axis Label")
}



par(mfrow=c(2, 2))
axisfun()
axisfun(mgp=c(2, 0.3, 0), tcl=0.2, xaxscol="gray")
axisfun(xaxs="i", mgpcol="gray", tclcol="gray")



}
figure3.12 <- function() {

par(oma=rep(3, 4))
vps <- gridBase::baseViewports()
# Annotation helper function
annWidth <- function(x, y, lab, above=TRUE, horiz=TRUE) {
  grid.lines(x=x, y=y, 
             arrow=arrow(ends="both", angle=10, type="closed",
                         length=unit(3, "mm")), 
             gp=gpar(fill="black"))
  nl <- length(lab)
  if (nl > 1) {
    y <- y + unit(c(-0.5, 0.5), "lines")
    if (horiz) {
      vjust <- 1:0
      hjust <- 0.5
      rot <- 0
    } else {
      hjust <- 1:0
      vjust <- 0.5
      rot <- 90
    }
  } else {
    hjust <- 0.5
    rot <- 0
    if (above) {
      y <- y + unit(0.5, "lines")
      vjust <- 0
    } else {
      y <- y - unit(0.5, "lines")
      vjust <- 1
    }
  }
  grid.text(lab,
            x=0.5*sum(x),
            y=y, hjust=hjust, vjust=vjust, rot=rot,
            gp=gpar(fontfamily="mono", cex=1))
}
# Annotate whole page
grid.rect(gp=gpar(col="gray", fill="gray80"))
annWidth(0:1, unit(1, "npc") - unit(1.5, "lines"), "din[1]")
# grid.lines(x=0.5)
annWidth(unit(c(0, 3), "lines"), unit(0.7, "npc"), c("omi[2]", "oma[2]"))
annWidth(unit(1, "npc") - unit(c(0, 3), "lines"),
         unit(0.7, "npc"), c("omi[4]", "oma[4]"))
annWidth(unit(c(0, 3), "lines"), unit(0.3, "npc"), 
         "omd[1]", above=FALSE)
annWidth(unit.c(unit(0, "npc"),
                unit(1, "npc") - unit(3, "lines")),
         unit(2, "lines"), "omd[2]",
         above=FALSE)
# Annotate figure region
pushViewport(do.call("vpStack", vps[1:2]))
grid.rect(gp=gpar(fill="gray90"))
annWidth(0:1, unit(1, "npc") - unit(1.5, "lines"), "fin[1]")
annWidth(unit(c(0, 4.1), "lines"), unit(0.6, "npc"), c("mai[2]", "mar[2]"))
annWidth(unit(1, "npc") - unit(c(0, 2.1), "lines"),
         unit(0.6, "npc"), c("mai[4]", "mar[4]"), horiz=FALSE)
annWidth(unit(c(0, 4.1), "lines"), unit(0.4, "npc"), 
         "plt[1]", above=FALSE)
annWidth(unit.c(unit(0, "npc"),
                unit(1, "npc") - unit(2.1, "lines")),
         unit(4, "lines"), "plt[2]",
         above=FALSE)
# Annotate plot region
pushViewport(vps[[3]])
grid.rect(gp=gpar(lty="dashed", fill="gray80"))
annWidth(0:1, unit(1, "npc") - unit(1.5, "lines"), "pin[1]")
popViewport(3)



}
figure3.13 <- function() {
grid.lshow <- function(i, j, lab, order, nrow, ncol, heights, respect) {
  pushViewport(viewport(layout.pos.col=j, layout.pos.row=i))
  pushViewport(viewport(width=unit(1, "npc") - unit(2, "lines"),
               height=unit(1, "npc") - unit(3, "lines"),
	       y=unit(3, "lines"), just="bottom", 
    layout=grid.layout(nrow, ncol, heights=heights, 
      respect=respect)))
  grid.rect(gp=gpar(col="gray"))
  for (i in 1:nrow) {
    for (j in 1:ncol) {
      pushViewport(viewport(layout.pos.row=i, layout.pos.col=j))
      grid.rect()
      grid.text(order[i, j])
      popViewport()
    }
  }
  popViewport()
  grid.text(lab, y=unit(2, "lines"))
  popViewport()
}
pushViewport(viewport(layout=grid.layout(2, 2)))
grid.lshow(1, 1, "(a)", cbind(c(1, 3, 5), c(2, 4, 6)), 3, 2, rep(1, 3), 
  FALSE)
grid.lshow(1, 2, "(b)", cbind(c(6, 4, 2), c(5, 3, 1)), 3, 2, rep(1, 3), 
  FALSE)
grid.lshow(2, 1, "(c)", matrix(c(1, 2), ncol=1), 2, 1, c(2, 1), FALSE)
grid.lshow(2, 2, "(d)", matrix(c(1, 2), ncol=1), 2, 1, c(2, 1), TRUE)
popViewport()



}
figure3.14 <- function() {
grid.lshow <- function(i, j, lab, locs, nrow, ncol, heights, respect) {
  pushViewport(viewport(layout.pos.col=j, layout.pos.row=i))
  pushViewport(viewport(width=unit(1, "npc") - unit(2, "lines"),
               height=unit(1, "npc") - unit(3, "lines"),
	       y=unit(3, "lines"), just="bottom", 
    layout=grid.layout(nrow, ncol, heights=heights, 
      respect=respect)))
  grid.rect(gp=gpar(col="gray"))
  for (i in locs) {
      pushViewport(viewport(layout.pos.row=i$rows, layout.pos.col=i$cols))
      grid.rect()
      grid.text(i$lab)
      popViewport()
  }
  popViewport()
  grid.text(lab, y=unit(2, "lines"))
  popViewport()
}
pushViewport(viewport(layout=grid.layout(2, 2)))
grid.lshow(1, 1, "(a)", 
  list(
    list(rows=1, cols=1, lab=1),
    list(rows=3, cols=1, lab=2)),
  3, 1,
  unit(c(2, 0.5, 1), c("null", "cm", "null")), 
  TRUE)
grid.lshow(1, 2, "(b)", 
  list(
    list(rows=1, cols=1, lab=1),
    list(rows=3, cols=1:2, lab=2),
    list(rows=1, cols=2, lab=3)), 
  3, 2,
  unit(c(2, 0.5, 1), c("null", "cm", "null")), 
  TRUE)
grid.lshow(2, 1, "(c)", 
  list(
    list(rows=1, cols=1, lab=1),
    list(rows=3, cols=1:2, lab=2),
    list(rows=1, cols=2, lab=3)), 
  3, 2,
  unit(c(2, 0.5, 1), c("null", "cm", "null")), 
  cbind(c(0, 0, 1), c(0, 0, 0)))
popViewport()



}
figure3.15 <- function() {
par(mfrow=c(1, 2), mar=c(1, 1, 2, 1))
par(cex=0.7)
EUdays <- window(datasets::EuStockMarkets, c(1992,1), c(1992,10))
plot(EUdays[,"DAX"], ylim=range(EUdays), ann=FALSE, 
     axes=FALSE, type="l", col="gray")

points(EUdays[,"DAX"])
lines(EUdays[,"CAC"], col="gray")
points(EUdays[,"CAC"], pch=2)
lines(EUdays[,"FTSE"], col="gray")
points(EUdays[,"FTSE"], pch=3)


box(col="gray")
mtext("points() & lines()", side=3, line=0.5)
x <- 1:5
y <- x
plot(x, y, ann=FALSE, axes=FALSE, col="gray", pch=16)

text(x[-3], y[-3], c("right", "top", "bottom", "left"), 
     pos=c(4, 3, 1, 2))
text(3, 3, "overlay")

box(col="gray")
mtext("text()", side=3, line=0.5)



}
figure3.16 <- function() {
t <- seq(60, 360, 30)
x <- cos(t/180*pi)*t/360
y <- sin(t/180*pi)*t/360




source(system.file("extra", "as.raster.R", package="RGraphics"))
  ## Silly warning from pixmap::pixmap() about cellres=NULL
suppressWarnings(
  rlogo <- pixmap::read.pnm(system.file("pictures/logo.pgm", 
                              package="pixmap")[1]))



par(mfrow=c(1, 2), mar=c(1, 1, 2, 1))
par(cex=0.7)

t <- seq(60, 360, 30)
x <- cos(t/180*pi)*t/360
y <- sin(t/180*pi)*t/360


par(mfrow=c(3, 3), mar=rep(1, 4), pty="s")
plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("lines()", side=3, line=.6, cex=.7, family="mono")
lines(x, y)

plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("segments()", side=3, line=.6, cex=.7, family="mono")
segments(0, 0, x, y)

plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("arrows()", side=3, line=.6, cex=.7, family="mono")
arrows(0, 0, x[-1], y[-1], length=.1)

plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("xspline()", side=3, line=.6, cex=.7, family="mono")
xspline(x, y, shape=1)

plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("rect()", side=3, line=.6, cex=.7, family="mono")
rect(min(x), min(y), max(x), max(y), col="gray")

plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("polygon()", side=3, line=.6, cex=.7, family="mono")
polygon(x, y, col="gray")

plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("polypath()", side=3, line=.6, cex=.7, family="mono")
polypath(c(x, NA, .5*x), c(y, NA, .5*y),
         col="gray", rule="evenodd")

plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("xspline()", side=3, line=.6, cex=.7, family="mono")
xspline(x, y, shape=1, open=FALSE, col="gray")

plot(x, y, pch=16, col="gray",
     xlim=c(-.6, 1.1), ylim=c(-1.1, .6),
     axes=FALSE, ann=FALSE)
box(col="gray")
mtext("rasterImage()", side=3, line=.6, cex=.7, family="mono")
rasterImage(rlogo,
            x - .1, y - .1,
            x + .1, y + .1)





}
figure3.17 <- function() {
par(mfrow=c(1, 2), mar=c(1, 1, 2, 1), pty="s")
par(cex=0.7)
plot(datasets::cars, ann=FALSE, axes=FALSE, col="gray", pch=16)

lmfit <- lm(dist ~ speed, datasets::cars)
abline(lmfit)
arrows(15, 90, 19, predict(lmfit, data.frame(speed=19)),
       length=0.1)
text(15, 90, "Line of best fit", pos=2)

box(col="gray")

mtext("abline() & arrows()", side=3, line=0.5)
plot(datasets::cars, ann=FALSE, axes=FALSE, col="gray", pch=16)

rug(datasets::cars$dist, side=2)

box(col="gray")

mtext("rug()", side=3, line=0.5)



}
figure3.18 <- function() {
angle <- seq(0, 2*pi, length=13)[-13]
x <- 0.15*cos(angle)
y <- 0.5 + 0.3*sin(angle)
par(mar=rep(0, 4))
plot.new()
box("outer", col="gray")
polygon(0.25 + x, y, col="gray")
text(0.75 + x[c(1, 5, 9)], y[c(1, 5, 9)], "NA", col="gray")
x[c(1, 5, 9)] <- NA
y[c(1, 5, 9)] <- NA
polygon(0.75 + x, y, col="gray")




}
figure3.19 <- function() {
par(mar=c(2, 2, 1, 1))
par(mfrow=c(2, 1), xpd=NA)

plot(datasets::EuStockMarkets[,"DAX"], type="l", axes=FALSE,
     xlab="", ylab="", main="")
box(col="gray")
mtext("Mid 1991", adj=0, side=3)
lines(x=c(1995, 1995, 1996, 1996), 
      y=c(-1000, 6000, 6000, -1000), 
      lwd=3, col="gray")
mtext("DAX", side=2, line=0)

plot(datasets::EuStockMarkets[,"FTSE"], type="l", axes=FALSE,
     xlab="", ylab="", main="")
box(col="gray")
mtext("Mid 1998", adj=1, side=3)
mtext("1995", at=1995.5, side=1)
lines(x=c(1995, 1995, 1996, 1996), 
      y=c(7000, 2500, 2500, 7000), 
      lwd=3, col="gray")
mtext("FTSE", side=2, line=0)




}
figure3.20 <- function() {
par(mfrow=c(2, 1), mar=c(5, 3, 2, 1), cex=0.5, pty="s")
with(iris,
     plot(Sepal.Length, Sepal.Width, 
          pch=as.numeric(Species), cex=1.2))
legend(6.1, 4.4, c("setosa", "versicolor", "virginica"), 
       cex=1.5, pch=1:3)

barplot(VADeaths[1:2,], angle=c(45, 135), density=30, 
        col="black", names=c("RM", "RF", "UM", "UF"))
legend(0.4, 38, c("55-59", "50-54"), cex=1.5,
       angle=c(135, 45), density=30)




}
figure3.21 <- function() {
nhtempCelsius <- 5*(nhtemp - 32)/9

plot(nhtempCelsius, axes=FALSE, ann=FALSE, ylim=c(0, 13))

axis(2, at=seq(0, 12, 4))
mtext("Degrees Centigrade", side=2, line=3)

axis(1)
axis(4, at=seq(0, 12, 4), labels=seq(0, 12, 4)*9/5 + 32)
mtext(" Degrees Fahrenheit", side=4, line=3)
box()




}
figure3.22 <- function() {
par(mar=rep(1, 4))
plot(0:1, 0:1, type="n", axes=FALSE, ann=FALSE)
usr <- par("usr")
pin <- par("pin")
xcm <- diff(usr[1:2])/(pin[1]*2.54)
ycm <- diff(usr[3:4])/(pin[2]*2.54)

rect(0, 0, 1, 1, col="white")
segments(seq(1, 8, 0.1)*xcm, 0,
         seq(1, 8, 0.1)*xcm, 
         c(rep(c(0.5, rep(0.25, 4), 
                 0.35, rep(0.25, 4)),
               7), 0.5)*ycm)
text(1:8*xcm, 0.6*ycm, 0:7, adj=c(0.5, 0))
text(8.2*xcm, 0.6*ycm, "cm", adj=c(0, 0))




}
figure3.23 <- function() {
layout(matrix(1:2, ncol=1), heights=1:2/6.5)
par(cex=0.7)
drunkenness <- ts(c(3875, 4846, 5128, 5773, 7327, 
                    6688, 5582, 3473, 3186,
                    rep(NA, 51)),
                  start=1912, end=1971)

# Have to copy-and-paste to shrink the mtext text (arggh!)
par(mar=c(5, 6, 2, 4))
plot(drunkenness, lwd=3, col="gray", ann=FALSE, las=2)
mtext("Drunkenness\nRelated Arrests", side=2, line=3.5, cex=0.7)
par(new=TRUE)
plot(nhtemp, ann=FALSE, axes=FALSE)
mtext("Temperature (F)", side=4, line=3, cex=0.7)
title("Using par(new=TRUE) or par(usr=...)")
axis(4)

par(mar=c(5, 4, 4, 2))
with(trees, 
     {
       plot(Height, Volume, pch=3,
            xlab="Height (ft)", 
            ylab=expression(paste("Volume ", (ft^3))))
       symbols(Height, Volume, circles=Girth/12, 
               fg="gray", inches=FALSE, add=TRUE)
     })

mtext("symbols(..., add=TRUE)", font=2, side=3, line=1)



}
figure3.24 <- function() {
x <- as.numeric(time(nhtemp))
y <- as.numeric(nhtemp)
n <- length(x)
mean <- mean(y)



x <- as.numeric(time(nhtemp))
y <- as.numeric(nhtemp)
n <- length(x)
mean <- mean(y)

par(mfrow=c(2,2), mar=c(3, 3, 1, 1))
plot(x, y, type="n", axes=FALSE, ann=FALSE)
polygon(c(x[1], x, x[n]), c(min(y), y, min(y)), 
        col="gray", border=NA)

box(col="gray")
plot(x, y, type="n", axes=FALSE, ann=FALSE)
polygon(c(x[1], x, x[n]), c(min(y), y, min(y)), 
        col="gray", border=NA)

usr <- par("usr")
rect(usr[1], usr[3], usr[2], mean, col="white", border=NA)

box(col="gray")
plot(x, y, type="n", axes=FALSE, ann=FALSE)
polygon(c(x[1], x, x[n]), c(min(y), y, min(y)), 
        col="gray", border=NA)

usr <- par("usr")
rect(usr[1], usr[3], usr[2], mean, col="white", border=NA)

lines(x, y)

box(col="gray")
plot(x, y, type="n", axes=FALSE, ann=FALSE)
polygon(c(x[1], x, x[n]), c(min(y), y, min(y)), 
        col="gray", border=NA)

usr <- par("usr")
rect(usr[1], usr[3], usr[2], mean, col="white", border=NA)

lines(x, y)

abline (h=mean, col="gray")
box()
axis(1)
axis(2) 




}
figure3.25 <- function() {
par(mfrow=c(1, 2), mar=c(3, 3, 1, 1), cex=0.7)
y <- sample(1:10)
midpts <- barplot(y, col=" light gray")
width <- diff(midpts[1:2])/4
left <- rep(midpts, y - 1) - width
right <- rep(midpts, y - 1) + width
heights <- unlist(apply(matrix(y, ncol=10), 
                        2, seq))[-cumsum(y)]
segments(left, heights, right, heights,
         col="white")

with(ToothGrowth, 
     {
       boxplot(len ~ supp, border="gray", 
               col="light gray", boxwex=0.5)
       points(jitter(rep(1:2, each=30), 0.5), 
              unlist(split(len, supp)),
              cex=0.5, pch=16)
     })




}
figure3.26 <- function() {
par(cex=.7)
pairs(iris[1:2], 
      diag.panel=function(x, ...) { 
          boxplot(x, add=TRUE, axes=FALSE,
                  at=mean(par("usr")[1:2])) 
      }, 
      text.panel=function(x, y, labels, ...) { 
          mtext(labels, side=3, line=0) 
      })





}
figure3.27 <- function() {
par(mar=rep(0, 4))
z <- 2 * volcano        
x <- 10 * (1:nrow(z))   
y <- 10 * (1:ncol(z))   
trans <- persp(x, y, z, zlim=c(0, max(z)),
               theta = 150, phi = 12, lwd=.5,
               scale = FALSE, axes=FALSE)

clines <- contourLines(x, y, z)
lapply(clines,
       function(contour) {
           lines(trans3d(contour$x, contour$y, 0, trans))
       })




}
figure3.28 <- function() {
plot.new()
plot.window(range(pressure$temperature), 
            range(pressure$pressure))
plot.xy(pressure, type="p")
box()
axis(1)
axis(2)


}
figure3.29 <- function() {
groups <- dimnames(Titanic)[[1]]
males <- Titanic[, 1, 2, 2]
females <- Titanic[, 2, 2, 2]

par(mar=c(0.5, 3, 0.5, 1))

plot.new()
plot.window(xlim=c(-200, 200), ylim=c(-1.5, 4.5))

ticks <- seq(-200, 200, 100)
y <- 1:4
h <- 0.2

lines(rep(0, 2), c(-1.5, 4.5), col="gray")
segments(-200, y, 200, y, lty="dotted")
rect(-males, y-h, 0, y+h, col="dark gray")
rect(0, y-h, females, y+h, col="light gray")
mtext(groups, at=y, adj=1, side=2, las=2)
par(cex.axis=0.8, mex=0.5)
axis(1, at=ticks, labels=abs(ticks), pos=0)

tw <- 1.5*strwidth("females")
rect(-tw, -1-h, 0, -1+h, col="dark gray")
rect(0, -1-h, tw, -1+h, col="light gray")
text(0, -1, "males", pos=2)
text(0, -1, "females", pos=4)

box("inner", col="gray")



}
plot.newclass <- function(x, y=NULL, 
                          main="", sub="",
                          xlim=NULL, ylim=NULL,
                          axes=TRUE, ann=par("ann"),
                          col=par("col"),
                          ...) {
    xy <- xy.coords(x, y)
    if (is.null(xlim))
        xlim <- range(xy$x[is.finite(xy$x)])
    if (is.null(ylim))
        ylim <- range(xy$y[is.finite(xy$y)])
    opar <- par(no.readonly=TRUE)
    on.exit(par(opar))
    plot.new()
    plot.window(xlim, ylim, ...)
    points(xy$x, xy$y, col=col, ...)
    if (axes) {
        axis(1)
        axis(2)
        box()
    }
    if (ann) 
        title(main=main, sub=sub, 
              xlab=xy$xlab, ylab=xy$ylab, ...)
}


figure6.1 <- function() {
pushViewport(viewport(layout=grid.layout(2, 2), gp=gpar(cex=0.6, fill=NA)))
pushViewport(viewport(layout.pos.col=1, layout.pos.row=1))
pushViewport(plotViewport(c(5, 4, 2, 2)))
pushViewport(dataViewport(pressure$temperature, 
                          pressure$pressure,
                          name="plotRegion"))

grid.points(pressure$temperature, pressure$pressure, 
  gp=gpar(cex=0.5))
grid.rect()
grid.xaxis()
grid.yaxis()
grid.text("temperature", y=unit(-3, "line"))
grid.text("pressure", x=unit(-3, "line"), rot=90)

popViewport(3)
pushViewport(viewport(layout.pos.col=2, layout.pos.row=1))
pushViewport(plotViewport(c(5, 4, 2, 2)))
pushViewport(dataViewport(pressure$temperature, 
                          pressure$pressure,
                          name="plotRegion"))

grid.points(pressure$temperature, pressure$pressure, pch=2, 
  gp=gpar(cex=0.5))
grid.rect()
grid.xaxis()
grid.yaxis()
grid.text("temperature", y=unit(-3, "line"))
grid.text("pressure", x=unit(-3, "line"), rot=90)

popViewport(3)
pushViewport(viewport(layout.pos.col=2, layout.pos.row=2))
pushViewport(plotViewport(c(5, 4, 2, 2)))
pushViewport(dataViewport(pressure$temperature, 
                          pressure$pressure,
                          name="plotRegion"))

grid.points(pressure$temperature, pressure$pressure, pch=2, 
  gp=gpar(cex=0.5))
grid.rect()
grid.xaxis()
grid.yaxis()
grid.text("temperature", y=unit(-3, "line"))
grid.text("pressure", x=unit(-3, "line"), rot=90)

upViewport(2)
grid.rect(gp=gpar(lty="dashed"))

downViewport("plotRegion")
grid.text("Pressure (mm Hg)\nversus\nTemperature (Celsius)",
          x=unit(150, "native"), y=unit(600, "native"))




}
figure6.2 <- function() {
grid.rect(gp=gpar(col="gray"))
grid.circle(x=seq(0.1, 0.9, length=100), 
            y=0.5 + 0.4*sin(seq(0, 2*pi, length=100)),
            r=abs(0.1*cos(seq(0, 2*pi, length=100))))




}
figure6.3 <- function() {
grid.rect(gp=gpar(col="gray"))
grid.circle(c(.1, .3, .4, .6, .7, .9), 
            c(.25, .75), r=unit(1, "mm"),
            gp=gpar(col=NA, fill="gray"))
grid.curve(x1=.1, y1=.25, x2=.3, y2=.75)
grid.curve(x1=.4, y1=.25, x2=.6, y2=.75,
           square=FALSE, ncp=8, curvature=.5)
grid.curve(x1=.7, y1=.25, x2=.9, y2=.75,
           square=FALSE, angle=45, shape=-1)




}
figure6.4 <- function() {
grid.rect(gp=gpar(col="gray"))
angle <- seq(0, 2*pi, length=50)
grid.lines(x=seq(0.1, 0.5, length=50), 
           y=0.5 + 0.3*sin(angle), arrow=arrow())
grid.segments(6:8/10, 0.2, 7:9/10, 0.8,
              arrow=arrow(angle=15, type="closed"))




}
figure6.5 <- function() {
grid.rect(gp=gpar(col="gray"))
angle <- seq(0, 2*pi, length=10)[-10]
grid.polygon(x=0.25 + 0.15*cos(angle), y=0.5 + 0.3*sin(angle), 
             gp=gpar(fill="gray"))
grid.polygon(x=0.75 + 0.15*cos(angle), y=0.5 + 0.3*sin(angle), 
             id=rep(1:3, each=3),
             gp=gpar(fill="gray"))




}
figure6.6 <- function() {
grid.rect(gp=gpar(col="gray"))
angle <- seq(0, 2*pi, length=10)[-10]
grid.path(x=0.25 + 0.15*cos(angle), y=0.5 + 0.3*sin(angle), 
          gp=gpar(fill="gray"))
grid.path(x=c(0.75 + 0.15*cos(angle), .7, .7, .8, .8),
          y=c(0.5 + 0.3*sin(angle),  .4, .6, .6, .4), 
          id=rep(1:2, c(9, 4)),
          gp=gpar(fill="gray"))




}
figure6.7 <- function() {
grid.rect(gp=gpar(col="gray"))
pushViewport(viewport(gp=gpar(col="gray")))
grid.text("very snug", 0.4, unit(1, "in"), just=c("left", "bottom"))
grid.lines(x=0.4, y=unit(0:1, "in"), arrow=arrow(ends="both",
                                       length=unit(1, "mm")))
grid.text("1 inch", unit(0.4, "npc") + unit(0.5, "line"), 
  unit(0.5, "in"), rot=90)
grid.lines(x=c(0, 0.4), y=unit(1, "in"), arrow=arrow(ends="both",
                                           length=unit(1, "mm")))
grid.text(unit(0.4, "npc"), 0.2, unit(1, "in") + unit(0.5, "line"))
popViewport()
pushViewport(viewport(gp=gpar(fill=NA)))
grid.rect(x=unit(0.4, "npc"), y=unit(1, "in"),
          width=stringWidth("very snug"), 
          height=unit(1, "line"),
          just=c("left", "bottom"))




}
figure6.8 <- function() {
grid.rect(gp=gpar(col="gray"))
pushViewport(viewport(gp=gpar(fontsize=10)))
grid.rect(x=0.33, height=0.7, width=0.2, gp=gpar(fill="black"))
grid.rect(x=0.66, height=0.7, width=0.2)
grid.text("grid.rect()", x=0.66, rot=90)
grid.text("grid.rect(gp=gpar(fill=\"black\"))", x=0.33, rot=90, 
  gp=gpar(fontsize=8, col="white"))
popViewport()



}
figure6.9 <- function() {
grid.rect(gp=gpar(col="gray"))
levels <- round(seq(90, 10, length=25))
grays <- paste("gray", c(levels, rev(levels)), sep="")
grid.circle(x=seq(0.1, 0.9, length=100), 
            y=0.5 + 0.4*sin(seq(0, 2*pi, length=100)),
            r=abs(0.1*cos(seq(0, 2*pi, length=100))),
            gp=gpar(col=grays))




}
figure6.10 <- function() {
grid.rect(gp=gpar(col="gray"))
angle <- seq(0, 2*pi, length=11)[-11]
grid.polygon(x=0.25 + 0.15*cos(angle), y=0.5 + 0.3*sin(angle), 
             id=rep(1:2, c(7, 3)),
             gp=gpar(fill=c("gray", "white")))
angle[4] <- NA
grid.polygon(x=0.75 + 0.15*cos(angle), y=0.5 + 0.3*sin(angle), 
             id=rep(1:2, c(7, 3)),
             gp=gpar(fill=c("gray", "white")))

angle <- seq(0, 2*pi, length=11)[4]
grid.text("NA", x=0.75 + 0.15*cos(angle), y=0.5 + 0.3*sin(angle),
          gp=gpar(col="gray"))



}
figure6.11 <- function() {
vp1 <- 
viewport(x=unit(0.4, "npc"), y=unit(1, "cm"),
         width=stringWidth("very very snug indeed"), 
         height=unit(6, "line"),
         just=c("left", "bottom"))

grid.show.viewport(scale.col="gray", border.fill="white", vp.col="black", vp.fill="gray", vp1)
grid.rect(gp=gpar(col="white", fill=NA, lwd=3))
pushViewport(viewport(.5, .5, .8, .8))
pushViewport(vp1)
grid.rect(gp=gpar(fill=NA))
grid.text("very very snug indeed", 
          gp=gpar(col="white"))
popViewport(2)



}
figure6.12 <- function() {
grid.rect(gp=gpar(col="gray"))
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))
pushViewport(viewport(width=0.8, height=0.5, angle=10, 
             name="vp1"))
grid.rect()
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))




}
figure6.13 <- function() {
grid.rect(gp=gpar(col="gray"))
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))
pushViewport(viewport(width=0.8, height=0.5, angle=10, 
             name="vp1"))
grid.rect()
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))

pushViewport(viewport(width=0.8, height=0.5, angle=10, 
             name="vp2"))
grid.rect()
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))




}
figure6.14 <- function() {
grid.rect(gp=gpar(col="gray"))
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))
pushViewport(viewport(width=0.8, height=0.5, angle=10, 
             name="vp1"))
grid.rect()
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))

pushViewport(viewport(width=0.8, height=0.5, angle=10, 
             name="vp2"))
grid.rect()
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))

popViewport()
grid.text("bottom-right corner", 
          x=unit(1, "npc") - unit(1, "mm"),
          y=unit(1, "mm"), just=c("right", "bottom"))




}
figure6.15 <- function() {
pushViewport(viewport(gp=gpar(fill=NA)))
grid.rect(gp=gpar(col="gray"))
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))
pushViewport(viewport(width=0.8, height=0.5, angle=10, 
             name="vp1"))
grid.rect()
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))

pushViewport(viewport(width=0.8, height=0.5, angle=10, 
             name="vp2"))
grid.rect()
grid.text("top-left corner", x=unit(1, "mm"),
          y=unit(1, "npc") - unit(1, "mm"), 
          just=c("left", "top"))

popViewport()
grid.text("bottom-right corner", 
          x=unit(1, "npc") - unit(1, "mm"),
          y=unit(1, "mm"), just=c("right", "bottom"))

upViewport()
grid.text("bottom-right corner", 
          x=unit(1, "npc") - unit(1, "mm"),
          y=unit(1, "mm"), just=c("right", "bottom"))
downViewport("vp1")
grid.rect(width=unit(1, "npc") + unit(2, "mm"),
          height=unit(1, "npc") + unit(2, "mm"))




}
figure6.16 <- function() {
pushViewport(viewport(layout=grid.layout(1, 3)))
pushViewport(viewport(layout.pos.col=1, gp=gpar(fill=NA)))
grid.rect(width=.9, height=.9, gp=gpar(col="gray"))
pushViewport(viewport(width=.5, height=.5, clip="on"))
grid.rect()
grid.circle(r=.7, gp=gpar(lwd=20))

popViewport(2)
pushViewport(viewport(layout.pos.col=2, gp=gpar(fill=NA)))
grid.rect(width=.9, height=.9, gp=gpar(col="gray"))
pushViewport(viewport(width=.5, height=.5, clip="on"))
grid.rect()
grid.circle(r=.7, gp=gpar(lwd=20))

pushViewport(viewport(clip="inherit"))
grid.circle(r=.7, gp=gpar(lwd=10, col="gray"))

popViewport(3)
pushViewport(viewport(layout.pos.col=3, gp=gpar(fill=NA)))
grid.rect(width=.9, height=.9, gp=gpar(col="gray"))
pushViewport(viewport(width=.5, height=.5, clip="on"))
grid.rect()
grid.circle(r=.7, gp=gpar(lwd=20))

pushViewport(viewport(clip="inherit"))
grid.circle(r=.7, gp=gpar(lwd=10, col="gray"))

pushViewport(viewport(clip="off"))
grid.circle(r=.7)
popViewport(3)

popViewport()



}
figure6.17 <- function() {
circText <- function(lab, x, y, suffix) {
    grid.circle(x, y, r=unit(3, "mm"), 
                name=paste(lab, suffix, sep="-"))
    grid.text(lab, x, y,
              gp=if (lab == "ROOT") gpar(cex=.7) else NULL)
}
edge <- function(a, b, angle) {
    grid.segments(grobX(a, angle), grobY(a, angle),
                  grobX(b, 180 + angle), grobY(b, 180 + angle),
                  arrow=arrow(length=unit(2, "mm"),
                    type="closed"),
                  gp=gpar(fill="black"))
}
grid.newpage()
pushViewport(viewport(width=.9, height=.9,
                      layout=grid.layout(2, 2),
                      gp=gpar(cex=.5)))
pushViewport(viewport(layout.pos.col=1, 
                      layout.pos.row=1))
grid.rect(width=.9, height=.9, gp=gpar(col="gray"))
circText("ROOT", .5, .8, 1)
circText("A", .3, .6, 1)
circText("B", .5, .6, 1)
circText("C", .7, .6, 1)
edge("ROOT-1", "A-1", 225)
edge("ROOT-1", "B-1", 270)
edge("ROOT-1", "C-1", 315)
popViewport()
pushViewport(viewport(layout.pos.col=2, 
                      layout.pos.row=1))
grid.rect(width=.9, height=.9, gp=gpar(col="gray"))
circText("ROOT", .5, .8, 2)
circText("A", .5, .6, 2)
circText("B", .5, .4, 2)
circText("C", .5, .2, 2)
edge("ROOT-2", "A-2", 270)
edge("A-2", "B-2", 270)
edge("B-2", "C-2", 270)
popViewport()
pushViewport(viewport(layout.pos.col=1, 
                      layout.pos.row=2))
grid.rect(width=.9, height=.9, gp=gpar(col="gray"))
circText("ROOT", .5, .8, 3)
circText("A", .5, .6, 3)
circText("B", .4, .4, 3)
circText("C", .6, .4, 3)
edge("ROOT-3", "A-3", 270)
edge("A-3", "B-3", 244)
edge("A-3", "C-3", 296)
popViewport()



}
figure6.18 <- function() {
grid.rect(gp=gpar(col="gray"))
pushViewport(viewport(gp=gpar(fill="gray", fontsize=10)))
grid.text("viewport(gp=gpar(fill=\"gray\"))", y=0.925)
grid.rect(x=0.33, height=0.7, width=0.2)
grid.text("grid.rect()", x=0.33, rot=90)
grid.rect(x=0.66, height=0.7, width=0.2, gp=gpar(fill="black"))
grid.text("grid.rect(gp=gpar(fill=\"black\"))", x=0.66, rot=90, 
  gp=gpar(fontsize=8, col="white"))
popViewport()



}
figure6.19 <- function() {
labelvp <- function(name, col="gray", tcol="white", clipOff=TRUE) {
  seekViewport(name)
  if (clipOff)
    pushViewport(viewport(clip="off"))
  grid.rect(gp=gpar(col=col, lwd=5, fill=NA))
  grid.rect(x=0, y=1, width=unit(1, "strwidth", name) + unit(2, "mm"),
    height=unit(1, "line"), just=c("left", "top"),
    gp=gpar(fill=col, col=NA))
  grid.text(name, x=unit(1, "mm"), y=unit(1, "npc") - unit(1, "mm"),
    just=c("left", "top"), gp=gpar(col=tcol))
  upViewport(0)
}



vplay <- grid.layout(3, 3, 
                     respect=rbind(c(0, 0, 0), 
                                   c(0, 1, 0), 
                                   c(0, 0, 0)))



pushViewport(viewport(width=0.95, height=0.95))
grid.rect(gp=gpar(col="light gray"))
pushViewport(viewport(layout=vplay))

pushViewport(viewport(layout.pos.col=2, name="col2"))
upViewport()
pushViewport(viewport(layout.pos.row=2, name="row2"))

labelvp("col2", "black")
labelvp("row2")



}
figure6.20 <- function() {
unitlay <- 
  grid.layout(3, 3, 
              widths=unit(c(1, 1, 2), 
                          c("in", "null", "null")), 
              heights=unit(c(3, 1, 1), 
                           c("line", "null", "null")))



pushViewport(viewport(gp=gpar(cex=0.8)))
grid.show.layout(unitlay, bg="white", 
                 cell.border="black", cell.fill="gray90", 
                 label.col="black", unit.col="black",
                 newpage=FALSE)
grid.rect(gp=gpar(col="white", lwd=3, fill=NA))
popViewport()



}
figure6.21 <- function() {
gridfun <- function() {
  pushViewport(viewport(layout=grid.layout(1, 2)))
  pushViewport(viewport(layout.pos.col=1))
  grid.rect()
  grid.text("black")
  grid.text("&", x=1)
  popViewport()
  pushViewport(viewport(layout.pos.col=2, clip="on"))
  grid.rect(gp=gpar(fill="black"))
  grid.text("white", gp=gpar(col="white"))
  grid.text("&", x=0, gp=gpar(col="white"))
  popViewport(2)
}



grid.rect(gp=gpar(col="gray"))
w <- unit(1, "npc") - unit(15, "mm")
x <- unit.c(unit(5, "mm"),
            unit(5, "mm") + 1/3*w,
            unit(5, "mm") + 1/3*w + unit(5, "mm"),
	    unit(1, "npc") - unit(5, "mm"))
y <- unit.c(unit(5, "mm"),
            unit(5, "mm") + 2/3*w,
            unit(5, "mm") + 2/3*w + unit(5, "mm"),
	    unit(1, "npc") - unit(5, "mm"))
grid.segments(x, 0, x, 1,
  gp=gpar(col="gray", lty="dashed"))
grid.segments(0, y, 1, y,
  gp=gpar(col="gray", lty="dashed"))
pushViewport(
  viewport(
    layout=grid.layout(5, 5, 
                       widths=unit(c(5, 1, 5, 2, 5),
                                   c("mm", "null", "mm",
                                     "null", "mm")),  
                       heights=unit(c(5, 1, 5, 2, 5),
                                    c("mm", "null", "mm",
                                      "null", "mm")))))
pushViewport(viewport(layout.pos.col=2, layout.pos.row=2))
gridfun()
popViewport()

pushViewport(viewport(layout.pos.col=4, layout.pos.row=4))
gridfun()
popViewport(2)




}
figure6.22 <- function() {

n <- 7
primtest2 <- function(nas, na) {
  angle <- seq(0, 2*pi, length=n+1)[-(n+1)]
  y <- 0.5 + 0.4*sin(angle)
  x <- 0.5 + 0.4*cos(angle)
  if (any(nas))
    grid.text(paste("NA", (1:n)[nas], sep=""),
              x[nas], y[nas], gp=gpar(col="gray"))
  x[nas] <- na
  y[nas] <- na
  grid.polygon(x, y, gp=gpar(fill="light gray", col=NA))
  grid.lines(x, y, arrow=arrow(), gp=gpar(lwd=5))
  grid.move.to(x[1], y[1])
  for (i in 2:n) {
    grid.line.to(x[i], y[i], gp=gpar(col="white"))
  }
}
celltest <- function(r, c, nas, na) {
  pushViewport(viewport(layout.pos.col=c,
                        layout.pos.row=r))
  primtest2(nas, na)
  grid.rect(width=0.9, height=0.9, gp=gpar(col="gray", fill=NA))
  popViewport()
}
cellnas <- function(i) {
  temp <- rep(FALSE, n)
  temp[i] <- TRUE
  temp[n-3+i] <- TRUE
  temp
}
pushViewport(viewport(width=.8, height=.8, 
                      layout=grid.layout(2, 2),
                      gp=gpar(cex=0.7)))
celltest(1, 1, rep(FALSE, n), NA)
celltest(1, 2, cellnas(1), NA)
celltest(2, 1, cellnas(2), NA)
celltest(2, 2, cellnas(3), NA)
popViewport()



}
figure6.23 <- function() {
trellis.par.set(theme = canonical.theme("postscript", color=FALSE))
trellis.par.set(list(layout.widths=list(left.padding=0, right.padding=0, ylab.axis.padding=0, axis.right=0, key.ylab.padding=0)))
print(
xyplot(mpg ~ disp | factor(gear), data=mtcars,
       panel=function(subscripts, ...) {
           grid.text(paste("n =", length(subscripts)),
                     unit(1, "npc") - unit(1, "mm"),
                     unit(1, "npc") - unit(1, "mm"),
                     just=c("right", "top"))
           panel.xyplot(subscripts=subscripts, ...)
       })

)



}
figure6.24 <- function() {
trellis.par.set(theme = canonical.theme("postscript", color=FALSE))
grid.newpage()
pushViewport(viewport(x=0, width=.4, just="left"))
print(barchart(table(mtcars$gear)),
      newpage=FALSE)
popViewport()
pushViewport(viewport(x=.4, width=.6, just="left"))
print(xyplot(mpg ~ disp, data=mtcars,
             group=gear, 
             auto.key=list(space="right"),
             par.settings=list(
                 superpose.symbol=list(pch=c(1, 3, 16),
                                       fill="white"))),
      newpage=FALSE)
popViewport()



}
figure6.25 <- function() {
mtcars2 <- mtcars
mtcars2$trans <- factor(mtcars$am, 
                        levels=0:1, 
                        labels=c("automatic", "manual"))
mtcars2$gear <- as.factor(mtcars$gear)
mtcars2$am <- NULL
mtcars2$vs <- NULL
mtcars2$drat <- NULL
mtcars2$carb <- NULL

# To keep R CMD check happy
mpg <- mtcars2$mpg



print(
ggplot(mtcars2, aes(x=disp, y=mpg)) +
    geom_point()

)
# Navigate to ROOT viewport so that this code works for example(figure6.25)
# in 'RGraphics' package
upViewport(0)
grid.force()
panelvp <- grid.grep("panel", grobs=FALSE, 
                     viewports=TRUE, grep=TRUE)
downViewport(panelvp)
grid.text(paste("n =", nrow(mtcars2)),
          x=unit(1, "npc") - unit(1, "mm"), 
          y=unit(1, "npc") - unit(1, "mm"),
          just=c("right", "top"))




}
figure6.26 <- function() {
mtcars2 <- mtcars
mtcars2$trans <- factor(mtcars$am, 
                        levels=0:1, 
                        labels=c("automatic", "manual"))
mtcars2$gear <- as.factor(mtcars$gear)
mtcars2$am <- NULL
mtcars2$vs <- NULL
mtcars2$drat <- NULL
mtcars2$carb <- NULL

# To keep R CMD check happy
mpg <- mtcars2$mpg



grid.newpage()
pushViewport(viewport(x=0, width=1/3, just="left"))
print(ggplot(mtcars2, aes(x=trans)) + 
      geom_bar(),
      newpage=FALSE)
popViewport()
pushViewport(viewport(x=1/3, width=2/3, just="left"))
print(ggplot(mtcars2, aes(x=disp, y=mpg)) +
      geom_point(aes(color=trans)) +
      scale_color_manual(values=gray(2:1/3)),
      newpage=FALSE)
popViewport()



}
figure1.2 <- function() {


#
#  Comment:
# 
#  Examples of the use of standard high-level plotting functions.
# 
#  In each case, extra output is also added using low-level 
#  plotting functions.
#


par(mfrow=c(3, 2))

# Scatterplot
x <- c(0.5, 2, 4, 8, 12, 16)
y1 <- c(1, 1.3, 1.9, 3.4, 3.9, 4.8)
y2 <- c(4, .8, .5, .45, .4, .3)
par(las=1, mar=c(4, 4, 2, 4), cex=.7)
plot.new()
plot.window(range(x), c(0, 6))
lines(x, y1)
lines(x, y2)
points(x, y1, pch=16, cex=2)
points(x, y2, pch=21, bg="white", cex=2)
par(col="gray50", fg="gray50", col.axis="gray50")
axis(1, at=seq(0, 16, 4))
axis(2, at=seq(0, 6, 2))
axis(4, at=seq(0, 6, 2))
box(bty="u")
mtext("Travel Time (s)", side=1, line=2, cex=0.8)
mtext("Responses per Travel", side=2, line=2, las=0, cex=0.8)
mtext("Responses per Second", side=4, line=2, las=0, cex=0.8)
text(4, 5, "Bird 131")
par(mar=c(5.1, 4.1, 4.1, 2.1), col="black", fg="black", col.axis="black")

# Histogram
# Random data
Y <- rnorm(50)
# Make sure no Y exceed [-3.5, 3.5]
Y[Y < -3.5 | Y > 3.5] <- NA
x <- seq(-3.5, 3.5, .1)
dn <- dnorm(x)
par(mar=c(4.5, 4.1, 3.1, 0))
hist(Y, breaks=seq(-3.5, 3.5), ylim=c(0, 0.5), 
     col="gray80", freq=FALSE)
lines(x, dnorm(x), lwd=2)
par(mar=c(5.1, 4.1, 4.1, 2.1))

# Barplot
# Modified from example(barplot)
par(mar=c(2, 3.1, 2, 2.1))
midpts <- barplot(VADeaths, 
                  col=gray(0.1 + seq(1, 9, 2)/11), 
                  names=rep("", 4))
mtext(sub(" ", "\n", colnames(VADeaths)),
      at=midpts, side=1, line=0.5, cex=0.5)
text(rep(midpts, each=5), apply(VADeaths, 2, cumsum) - VADeaths/2,
     VADeaths, 
     col=rep(c("white", "black"), times=3:2), 
     cex=0.8)
par(mar=c(5.1, 4.1, 4.1, 2.1))

# Boxplot
# Modified example(boxplot) - itself from suggestion by Roger Bivand
par(mar=c(3, 4.1, 2, 0))
     boxplot(len ~ dose, data = ToothGrowth,
             boxwex = 0.25, at = 1:3 - 0.2,
             subset= supp == "VC", col="white",
             xlab="",
             ylab="tooth length", ylim=c(0,35))
     mtext("Vitamin C dose (mg)", side=1, line=2.5, cex=0.8)
     boxplot(len ~ dose, data = ToothGrowth, add = TRUE,
             boxwex = 0.25, at = 1:3 + 0.2,

             subset= supp == "OJ")
     legend(1.5, 9, c("Ascorbic acid", "Orange juice"), 
            fill = c("white", "gray"), 
            bty="n")
par(mar=c(5.1, 4.1, 4.1, 2.1))

# Persp
# Almost exactly example(persp)
    x <- seq(-10, 10, length= 30)
     y <- x
     f <- function(x,y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }
     z <- outer(x, y, f)
     z[is.na(z)] <- 1
# 0.5 to include z axis label
par(mar=c(0, 0.5, 0, 0), lwd=0.5)
     persp(x, y, z, theta = 30, phi = 30, 
 
           expand = 0.5)
par(mar=c(5.1, 4.1, 4.1, 2.1), lwd=1)

# Piechart
# Example 4 from help(pie)
par(mar=c(0, 2, 1, 2), xpd=FALSE, cex=0.5)
     pie.sales <- c(0.12, 0.3, 0.26, 0.16, 0.04, 0.12)
     names(pie.sales) <- c("Blueberry", "Cherry",
         "Apple", "Boston Cream", "Other", "Vanilla")
     pie(pie.sales, col = gray(seq(0.3,1.0,length=6))) 




}
figure1.3 <- function() {

#
# Comment:
#
# A sophisticated example of adding further output to a basic plot.
# 
# Most of the functions defined are just for calculating values
# relevant to the data analysis.  
# 
# The function plotPars() is the one of interest for seeing how
# the drawing of the plot is done.
#


params <- function(N, breaks, p=seq(0.001, 1, length=100)) {
  list(N=N, T=1/breaks, p=p, q=1-p)
}

pdfcomp <- function(comp, params) {
  n <- params$T
  p <- params$p
  q <- params$q
  y <- round(comp/n)
  choose(n, comp)*p^comp*q^(n-comp) / (1 - q^n)
}

# Expected num sherds (for a vessel) [=completeness]
expcomp <- function(params) {
  params$T*params$p/(1-params$q^params$T)
}

# Variance of num sherds (for a vessel)
varcomp <- function(params) {
  n <- params$T
  p <- params$p
  q <- params$q
  # From Johnson & Kotz
  (n*p*q / (1 - q^n)) - (n^2*p^2*q^n / (1 - q^n)^2)
  # n^2 times Thomas Yee's formula
  # n^2*((p*(1 + p*(n - 1)) / (n*(1 - q^n))) - (p^2 / (1 - q^n)^2))
}

# Expected value of completeness (for a sample of vessels)
expmeancomp <- function(params) {
  expcomp(params)
}

# Variance of completeness (for a sample of vessels)
# Use the expected number of vessels in sample as denominator
varmeancomp <- function(params) {
  varcomp(params)/(numvess(params))
}

numvess <- function(params) {
  params$N*(1-params$q^params$T)
}

ecomp <- function(p, T, comp) {
  q <- 1 - p
  T*p/(1 - q^T) - comp
}

estN <- function(comp, broke, n) {
  T <- 1/broke
  n / (1 - (1 - uniroot(ecomp, c(0.00001, 1), T=T, comp=comp)$root)^T)
}

nvessscale <- function(params, xlim, ylim, new=TRUE) {
  if (new)
    par(new=TRUE)
  plot(0:1, c(1, params$N), type="n", axes=!new, ann=FALSE,
       xlim=xlim, ylim=ylim)
}

compscale <- function(params, xlim, ylim, new=TRUE) {
  if (new)
    par(new=TRUE)
  plot(0:1, c(1, params$T), type="n", axes=!new, ann=FALSE,
       xlim=xlim, ylim=ylim)
}

lowerCI <- function(p, N, breaks, lb) {
  params <- params(N, breaks, p)
  expmeancomp(params) - 2*sqrt(varmeancomp(params)) - lb
}

upperCI <- function(p, N, breaks, lb) {
  params <- params(N, breaks, p)
  expmeancomp(params) + 2*sqrt(varmeancomp(params)) - lb
}

critP <- function(comp, params) {
  c(uniroot(lowerCI, c(0.00001, 1), N=params$N,
            breaks=1/params$T, lb=max(comp))$root,
    if (upperCI(0.00001, params$N, 1/params$T, min(comp)) > 0) 0
    else uniroot(upperCI, c(0.00001, 1), N=params$N,
                 breaks=1/params$T, lb=min(comp))$root)
}

anncomp <- function(params, comp, xlim, ylim, cylim) {
  cp <- critP(comp, params)
  nv <- numvess(params(params$N, 1/params$T, cp))
  nvessscale(params, xlim, ylim)
  polygon(c(cp[2], cp[2], 0, 0, cp[1], cp[1]),
          c(0, nv[2], nv[2], nv[1], nv[1], 0),
          col="gray90", border=NA)
  text(0, nv[1], paste(round(nv[1]),
                       " (", round(100*nv[1]/params$N), "%)", sep=""),
       adj=c(0, 0), col="gray")
  text(0, nv[2], paste(round(nv[2]), 
                       " (", round(100*nv[2]/params$N), "%)", sep=""),
       adj=c(0, 1), col="gray")
  compscale(params, xlim, cylim)
  segments(1, min(comp), cp[2], comp, col="gray")
  segments(1, max(comp), cp[1], comp, col="gray")
  text(1, comp, paste(comp, collapse="-"), adj=c(1, 0), col="gray")
}

plotPars <- function(params, comp, xlim=NULL, ylim=NULL) {
  mean <- expmeancomp(params)
  var <- 2*sqrt(varmeancomp(params))
  lb <- mean - var
  ub <- mean + var
  par(mar=c(5, 4, 4, 4))
  if (is.null(ylim))
    cylim <- ylim
  else
    cylim <- c(1 + ((ylim[1] - 1)/(params$N - 1))*(params$T - 1),
               1 + ((ylim[2] - 1)/(params$N - 1))*(params$T - 1))
  nvessscale(params, xlim, ylim, new=FALSE)
  compscale(params, xlim, cylim)
  polygon(c(params$p, rev(params$p)), c(lb, rev(ub)),
          col="gray90", border=NA)
  anncomp(params, comp, xlim, ylim, cylim)
  nvessscale(params, xlim, ylim)
  mtext("Number of Vessels", side=2, line=3)
  mtext("Sampling Fraction", side=1, line=3)
  lines(params$p, numvess(params))
  par(new=TRUE)
  compscale(params, xlim, cylim)
  mtext("Completeness", side=4, line=3)
  axis(4)
  lines(params$p, mean, lty="dashed")
  lines(params$p, lb, lty="dotted")
  lines(params$p, ub, lty="dotted")
  mtext(paste("N = ", round(params$N),
              "     brokenness = ", round(1/params$T, 3), sep=""),
        side=3, line=2)
}

par(cex=0.8, mar=c(3, 3, 3, 3))
p6 <- params(estN(1.2, 0.5, 200), 0.5)
plotPars(p6, 1.2)
nvessscale(p6, NULL, NULL)
pcrit <- 1 - (1 - 200/estN(1.2, 0.5, 200))^(1/p6$T)
lines(c(0, pcrit), c(200, 200))
lines(c(pcrit, pcrit), c(200, 0))



}
figure1.4 <- function() {
# Produce a plot of tiger populations with picture as background
# Source: http://www.globaltiger.org/population.htm
year <- c(1993, 1996, 1998, 2001)
minpop <- c(20, 50, 50, 115)
maxpop <- c(50, 240, 240, 150)

PostScriptTrace(system.file("extra", "tiger.ps", 
                            package="RGraphics"))
tiger <- grImport::readPicture("tiger.ps.xml")[-1]


source(system.file("extra", "grayify.R", package="RGraphics"))

# grid.newpage()
pushViewport(plotViewport(c(3, 2, 2, 1)),
             viewport(xscale=c(1991, 2003), yscale=c(0, 250)))
grid.rect()
# tiger backdrop in gray
grImport::grid.picture(tiger, x=0.45, FUN=grayify, min=.8)
grid.xaxis(at=year, gp=gpar(cex=0.7))
grid.yaxis(gp=gpar(cex=0.7))
# black bars
grid.rect(x=unit(year, "native"), y=0,
          width=unit(1, "native"), height=unit(maxpop, "native"),
          just="bottom", gp=gpar(fill="black"))
# tiger in bars
tigerGrob <- grImport::pictureGrob(tiger, x=0.45, 
 FUN=grImport::grobify)
# Start from 2 because bar 1 does not overlap with tiger
for (i in 2:length(year)) {
    grid.clip(x=unit(year[i], "native"), y=0,
              width=unit(1, "native"), height=unit(maxpop[i], "native"),
              just="bottom")
    # tiger backdrop (shift slightly to left so get one eye in one bar)
    grid.draw(tigerGrob)
}
grid.clip()
# redo bar borders
grid.rect(x=unit(year, "native"), y=0,
          width=unit(1, "native"), height=unit(maxpop, "native"),
          just="bottom", gp=gpar(fill=NA))
grid.text("Estimated Population (max.) of Bengal Tigers\n(in Bhutan)",
          y=unit(1, "npc") + unit(1, "lines"))
popViewport(2)



}
figure1.5 <- function() {

#
# Comment:
#
# A slightly modified version of Figure 1.1 from 
# Cleveland's book "Visualizing Data"
#


trellis.par.set(list(fontsize=list(text=6),
	             par.xlab.text=list(cex=1.5),
                     add.text=list(cex=1.5),
                     superpose.symbol=list(cex=.5)))
key <- simpleKey(levels(lattice::barley$year), space = "right")
key$text$cex <- 1.5
print(
     dotplot(variety ~ yield | site, data = lattice::barley, groups = year,
             key = key,
             xlab = "Barley Yield (bushels/acre) ",
             aspect=0.5, layout = c(1,6), ylab=NULL)
)



}
figure1.6 <- function() {

#
# Comment:
#
# Inspired by Figure 3.3 from 
# Wickham's book "ggplot2"
#

print(
ggplot(data=ggplot2::mpg, aes(x=displ, y=hwy, shape=factor(cyl))) + 
    geom_point() +
    stat_smooth(method="lm", colour="black") +
    scale_shape_manual(values=c(1, 16, 3, 17)) + 
    theme_bw() 
)



}
figure1.7 <- function() {

#
# Comment:
#
# map positioned correctly;  this provides an example of calling a 
# plotting function to perform calculations but do no drawing (see the
# second call to the map() function).
#
# Makes use of the "maps", "mapdata", and "mapproj" packages to draw the maps.
#

par(mar=rep(1, 4))
maps::map("mapdata::nzHires", fill=TRUE, col="gray80",
    regions=c("North Island", "South Island", "Stewart Island"))
points(174.75, -36.87, pch=16, cex=2,
       col=rgb(0,0,0,.5))
arrows(172, -36.87, 174, -36.87, lwd=3)
text(172, -36.87, "Auckland  ", adj=1, cex=2)
# mini world map as guide
maplocs <- maps::map(projection="sp_mercator", wrap=TRUE, lwd=0.1, 
               col="gray", ylim=c(-60, 75),
               interior=FALSE, orientation=c(90, 180, 0), add=TRUE,
               plot=FALSE)
xrange <- range(maplocs$x, na.rm=TRUE)
yrange <- range(maplocs$y, na.rm=TRUE)
aspect <- abs(diff(yrange))/abs(diff(xrange))
# customised to 6.5 by 4.5 figure size
par(fig=c(0.99 - 0.5, 0.99, 0.01, 0.01 + 0.5*aspect*4.5/6.5), 
    mar=rep(0, 4), new=TRUE)
plot.new()
plot.window(xlim=xrange,
            ylim=yrange)
maps::map(projection="sp_mercator", wrap=TRUE, lwd=0.5, ylim=c(-60, 75),
    interior=FALSE, orientation=c(90, 180, 0), add=TRUE)
symbols(-.13, -0.8, circles=1, inches=0.1, add=TRUE, bg=rgb(0,0,0,.2))
box()


}
figure1.8 <- function() {
notrun <- function() {
    # 'AABA' distributed with 'RGraphics' package 
    quantmod::getSymbols("AABA")
    dump("AABA", "AABA.R")
}
quantmod::chartSeries(AABA, subset='2007::2008-01'
 )


}
figure1.9 <- function() {

# CLASSIFICATION
# fitting
data("GlaucomaM", package = "TH.data", envir=environment())
glau <- GlaucomaM
levels(glau$Class) <- c("glau", "norm")
fm.class <- party::ctree(Class ~ ., data = glau)

# visualization
pushViewport(viewport(gp=gpar(cex=0.6)))
plot(fm.class, new=FALSE, terminal.panel=myNode)
popViewport()



}
figure1.10 <- function() {

#
# Comment:
#
# Some simple ideas as a basis for meta-analysis plots.
# 
# The code is modular so that something similar could be achieved
# with different data quite simply.  The actual drawing for these data
# only occurs in the last 10 or so lines of code.
#


# The horizontal gap between columns with content
colgap <- unit(3, "mm")

# The data for column 1
# 
# Of course, many other possible ways to represent the data
# One advantage with this way is that col1$labels can be used
# directly in the calculation of the column widths for the
# main table (see below)
#
# NOTE:  textGrobs are used here so that the fontface (bold in
# some cases) is associated with the label.  In this way, the
# calculation of column widths takes into account the font face.
col1 <- list(labels=
             list(textGrob("Centre", x=0, just="left",
                           gp=gpar(fontface="bold", col="white")),
                  textGrob("Thailand", x=0, just="left"),
                  textGrob("Philippines", x=0, just="left"),
                  textGrob("All in situ", x=0, just="left",
                           gp=gpar(fontface="bold.italic")),
                  textGrob("Colombia", x=0, just="left"),
                  textGrob("Spain", x=0, just="left"),
                  textGrob("All invasive", x=0, just="left",
                           gp=gpar(fontface="bold.italic")),
                  textGrob("All", x=0, just="left",
                           gp=gpar(fontface="bold"))),
             rows=c(1, 5, 6, 8, 11, 12, 14, 16))

# Labels in col 1 which are not used to calculate the
# column width (they spill over into col 2)
col1plus <- list(labels=
                 list(textGrob("Carcinoma in situ", x=0, just="left",
                               gp=gpar(fontface="bold.italic")),
                      textGrob("Invasive cancer", x=0, just="left",
                               gp=gpar(fontface="bold.italic"))),
                 rows=c(4, 10))

# Data for column 2
col2 <- list(labels=
             list(textGrob("Cases", x=1, just="right",
                           gp=gpar(fontface="bold", col="white")),
                  textGrob("327", x=1, just="right"),
                  textGrob("319", x=1, just="right"),
                  textGrob("1462", x=1, just="right",
                           gp=gpar(fontface="bold")),
                  textGrob("96", x=1, just="right"),
                  textGrob("115", x=1, just="right"),
                  textGrob("211", x=1, just="right",
                           gp=gpar(fontface="bold")),
                  textGrob("1673", x=1, just="right",
                           gp=gpar(fontface="bold"))),
             rows=c(1, 5, 6, 8, 11, 12, 14, 16))

# Data for column 3 (width specified as a physical size below)
col3 <- list(OR=c(0.72, 1.27, 1.17, 2.97, 1.86, 2.01, 1.20),
             LL=c(0.52, 0.87, 1.03, 1.42, 0.46, 1.09, 1.07),
             UL=c(1.00, 1.85, 1.32, 6.21, 7.51, 3.71, 1.35),
             rows=c(5, 6, 8, 11, 12, 14, 16),
             # "s" means summary, "n" means normal
             type=c("n", "n", "s", "n", "n", "s", "s"))

# Sizes of boxes
information <- sqrt(1 / ((log(col3$UL) - log(col3$OR))/1.96))
col3$sizes <- information/max(information)

# Width of column 3
col3width <- unit(1.5, "inches")

# Range on the x-axis for column 3
col3$range <- c(0, 4)

# Function to draw a cell in a text column
drawLabelCol <- function(col, j) {
  for (i in 1:length(col$rows)) {
    pushViewport(viewport(layout.pos.row=col$rows[i], layout.pos.col=j))
    # Labels are grobs containing their location so just
    # have to grid.draw() them
    grid.draw(col$labels[[i]])
    popViewport()
  }
}

# Function to draw a non-summary rect-plus-CI
drawNormalCI <- function(LL, OR, UL, size) {
  # NOTE the use of "native" units to position relative to
  # the x-axis scale, and "snpc" units to size relative to
  # the height of the row
  # ("snpc" stands for "square normalised parent coordinates"
  #  which means that the value is calculated as a proportion
  #  of the width and height of the current viewport and the
  #  physically smaller of these is used)
  grid.rect(x=unit(OR, "native"),
            width=unit(size, "snpc"), height=unit(size, "snpc"),
            gp=gpar(fill="black"))
  # Draw arrow if exceed col range
  # convertX() used to convert between coordinate systems
  if (convertX(unit(UL, "native"), "npc", valueOnly=TRUE) > 1)
    grid.lines(x=unit(c(LL, 1), c("native", "npc")), y=.5,
               arrow=arrow(length=unit(0.05, "inches")))
  else {
    # Draw line white if totally inside rect
    lineCol <- if ((convertX(unit(OR, "native") + unit(0.5*size, "lines"),
                             "native", valueOnly=TRUE) > UL) &&
                   (convertX(unit(OR, "native") - unit(0.5*size, "lines"),
                             "native", valueOnly=TRUE) < LL))
      "white"
    else
      "black"
    grid.lines(x=unit(c(LL, UL), "native"), y=0.5,
               gp=gpar(col=lineCol))
  }
}

# Function to draw a summary "diamond"
drawSummaryCI <- function(LL, OR, UL, size) {
  # Not sure how to calc the heights of the diamonds so
  # I'm just using half the height of the equivalent rect
  grid.polygon(x=unit(c(LL, OR, UL, OR), "native"),
               y=unit(0.5 + c(0, 0.25*size, 0, -0.25*size), "npc"))
}

# Function to draw a "data" column
drawDataCol <- function(col, j) {
  pushViewport(viewport(layout.pos.col=j, xscale=col$range))
  grid.lines(x=unit(1, "native"), y=0:1)
  # Assume that last value in col is "All"
  grid.lines(x=unit(col$OR[length(col$OR)], "native"),
             y=0:1, gp=gpar(lty="dashed"))
  grid.xaxis(gp=gpar(cex=0.6))
  grid.text("OR", y=unit(-2, "lines"))
  popViewport()
  for (i in 1:length(col$rows)) {
    pushViewport(viewport(layout.pos.row=col$rows[i], layout.pos.col=j,
                          xscale=col$range))
    if (col$type[i] == "n")
      drawNormalCI(col$LL[i], col$OR[i], col$UL[i], col$sizes[i])
    else
      drawSummaryCI(col$LL[i], col$OR[i], col$UL[i], col$sizes[i])
    popViewport()
  }
}

# Draw the table
#
# The table is just a big layout
#
# All rows are the height of 1 line of text
# 
# Widths of column 1 and 2 are based on widths of labels in
# col$labels and col2$labels 
pushViewport(viewport(layout=grid.layout(16, 5,
                        widths=
                        unit.c(max(unit(rep(1, 8), "grobwidth", col1$labels)),
                               colgap,
                               max(unit(rep(1, 8), "grobwidth", col2$labels)),
                               colgap,
                               col3width),
                        heights=unit(c(1, 0, rep(1, 14)), "lines"))))
pushViewport(viewport(layout.pos.row=1))
grid.rect(gp=gpar(col=NA, fill="black"))
popViewport()
for (i in c(8, 14, 16)) {
    pushViewport(viewport(layout.pos.row=i))
    grid.rect(gp=gpar(col=NA, fill="gray80"))
    popViewport()
}
drawLabelCol(col1, 1)
drawLabelCol(col1plus, 1)
drawLabelCol(col2, 3)
drawDataCol(col3, 5)
popViewport()
                          



}
figure1.11 <- function() {

#
# Comment:
#
# Code by Arden Miller (Department of Statistics, The University of Auckland).
# 
# Lots of coordinate transformations being done "by hand".
# This code is not really reusable;  just a demonstration that very 
# pretty results are possible if you're sufficiently keen.
#


par(mfrow=c(2, 1), pty="s", mar=rep(1, 4)) 
# Create plotting region and plot outer circle
plot(c(-1.1, 1.2), c(-1.1, 1.2),
     type="n", xlab="", ylab="", 
     xaxt="n", yaxt="n", cex.lab=2.5)
angs <- seq(0, 2*pi, length=500)
XX <- sin(angs)
YY <- cos(angs)
lines(XX, YY, type="l")

# Set constants
phi1 <- pi*2/9
k1 <- sin(phi1)
k2 <- cos(phi1)

# Create gray regions
obsphi <- pi/12
lambdas <- seq(-pi, pi, length=500)
xx <- cos(pi/2 - obsphi)*sin(lambdas)
yy <- k2*sin(pi/2 - obsphi)-k1 * cos(pi/2 - obsphi)*cos(lambdas)
polygon(xx, yy, col="gray")
lines(xx, yy, lwd=2)
theta1sA <- seq(-obsphi, obsphi, length=500)
theta2sA <- acos(cos(obsphi)/cos(theta1sA))
theta1sB <- seq(obsphi, -obsphi, length=500)
theta2sB <-  -acos(cos(obsphi)/cos(theta1sB))
theta1s <- c(theta1sA, theta1sB)
theta2s <- c(theta2sA, theta2sB)
xx <- cos(theta1s)*sin(theta2s+pi/4)
yy <- k2*sin(theta1s)-k1*cos(theta1s)*cos(theta2s+pi/4)
polygon(xx, yy, col="gray")
lines(xx, yy, lwd=2)
xx <- cos(theta1s)*sin(theta2s-pi/4)
yy <- k2*sin(theta1s)-k1*cos(theta1s)*cos(theta2s-pi/4)
polygon(xx, yy, col="gray")
lines(xx, yy, lwd=2)

# Plot longitudes
vals <- seq(0, 7, 1)*pi/8
for(lambda in vals){
sl <- sin(lambda)
cl <- cos(lambda)
phi <- atan(((0-1)*k2*cl)/(k1))
angs <- seq(phi, pi+phi, length=500)
xx <- cos(angs)*sl
yy <- k2*sin(angs)-k1*cos(angs)*cl
lines(xx, yy, lwd=.5)
}

# Grey out polar cap
phi <- 5.6*pi/12
lambdas <- seq(-pi, pi, length=500)
xx <- cos(phi)*sin(lambdas)
yy <- k2*sin(phi)-k1 * cos(phi)*cos(lambdas)
polygon(xx, yy, col="gray")

# Plot Latitudes
vals2 <- seq(-2.8, 5.6, 1.4)*pi/12
for(phi in vals2){
  if (k1*sin(phi) > k2 * cos(phi)) 
    crit <- pi 
  else 
    crit <- acos((-k1*sin(phi))/(k2*cos(phi)))
  lambdas <- seq(-crit, crit, length=500)
  xx <- cos(phi)*sin(lambdas)
  yy <- k2*sin(phi)-k1 * cos(phi)*cos(lambdas)
  lines(xx, yy, lwd=.5)
}


# Plots axes and label
lines(c(0.00, 0.00), c(k2*sin(pi/2), 1.11), lwd=4)
lines(c(0.00, 0.00), c(-1, -1.12), lwd=4)
a2x <- sin(-pi/4)
a2y <- cos(-pi/4)*(-k1)
lines(c(a2x, 1.5*a2x), c(a2y, 1.5*a2y), lwd=4)
k <- sqrt(a2x^2+a2y^2)
lines(c(-a2x/k, 1.2*(-a2x/k)), c(-a2y/k, 1.2*(-a2y/k)), lwd=4)
a3x <- sin(pi/4)
a3y <- cos(pi/4)*(-k1)
lines(c(a3x, 1.5*a3x), c(a3y, 1.5*a3y), lwd=4)
k <- sqrt(a3x^2+a3y^2)
lines(c(-a3x/k, 1.2*(-a3x/k)), c(-a3y/k, 1.2*(-a3y/k)), lwd=4)
text(0.1, 1.12, expression(bold(X[1])))
text(-1.07, -.85, expression(bold(X[2])))
text(1.11, -.85, expression(bold(X[3])))

# set plot region and draw outer circle
plot(c(-1.1, 1.2),  c(-1.1, 1.2),
     type="n", xlab="", ylab="", 
     xaxt="n", yaxt="n", cex.lab=2.5)
angs <- seq(0, 2*pi, length=500)
XX <- sin(angs)
YY <- cos(angs)
lines(XX, YY, type="l")

# set constants
phi1 <- pi*2/9
k1 <- sin(phi1)
k2 <- cos(phi1)
obsphi <- pi/24

# create X2X3 gray region and plot boundary
crit <- acos((-k1*sin(obsphi))/(k2 * cos(obsphi)))
lambdas <- seq(-crit, crit, length=500)