### R code from vignette source 'MurrellPaths.Rnw' ################################################### ### code chunk number 1: simplepathxy ################################################### x <- c(.1, .5, .9) y <- c(.1, .8, .1) ################################################### ### code chunk number 2: MurrellPaths.Rnw:50-51 ################################################### library(grid) ################################################### ### code chunk number 3: simplepath ################################################### grid.path(x, y, gp=gpar(fill="grey")) ################################################### ### code chunk number 4: mediumpathxy ################################################### x <- c(.1, .5, .9, .1, .2, .3) y <- c(.1, .8, .1, .7, .6, .7) id <- rep(1:2, each=3) ################################################### ### code chunk number 5: MurrellPaths.Rnw:83-84 ################################################### cbind(x, y, id) ################################################### ### code chunk number 6: mediumpath ################################################### grid.path(x, y, id=id, gp=gpar(fill="grey")) ################################################### ### code chunk number 7: mediumpathinsidexy ################################################### x <- c(.1, .5, .9, .4, .5, .6) y <- c(.1, .8, .1, .5, .4, .5) ################################################### ### code chunk number 8: mediumpathpolygon ################################################### grid.polygon(x, y, id=id, gp=gpar(fill="grey")) ################################################### ### code chunk number 9: mediumpathinside ################################################### grid.path(x, y, id=id, gp=gpar(fill="grey")) ################################################### ### code chunk number 10: MurrellPaths.Rnw:177-220 ################################################### bdir <- function(nr, nc) { for (r in 1:nr) { for (c in 1:nc) { i <- (r - 1)*nc + c if (c == nc) j <- i - nc + 1 else j <- i + 1 grid.segments(x[i], y[i], x[j], y[j], arrow=arrow(angle=20, type="closed", length=unit(4, "mm")), gp=gpar(fill="black")) if (c == 1) grid.circle(x[i], y[i], r=unit(1, "mm"), gp=gpar(fill="black")) } } } bdir <- function(nr, nc) { # grid.path(x, y, id=id, gp=gpar(col="grey")) xm <- matrix(x, ncol=nr) ym <- matrix(y, ncol=nr) grid.circle(xm[1, ], ym[1, ], r=unit(1, "mm"), gp=gpar(fill="grey")) xsp <- xsplineGrob(rbind(xm, xm[1, ]), rbind(ym, ym[1, ]), id=rep(1:nr, each=(nc + 1)), shape=-.1) curves <- xsplinePoints(xsp) lapply(curves, function(xy) { grid.lines(xy$x[1:10], xy$y[1:10]) }) grid.circle(xm[1, ], ym[1, ], r=unit(2, "mm"), gp=gpar(col=NA, fill="white")) lapply(curves, function(xy) { grid.lines(xy$x[-(1:9)], xy$y[-(1:9)], arrow=arrow(angle=20, length=unit(3, "mm"), type="closed"), gp=gpar(fill="black")) }) invisible() } ################################################### ### code chunk number 11: mediumpathdirection ################################################### bdir(2, 3) ################################################### ### code chunk number 12: complexpathxy ################################################### x <- c(.1, .5, .9, .4, .5, .6, .4, .6, .5) y <- c(.1, .8, .1, .5, .4, .5, .3, .3, .2) id <- rep(1:3, each=3) ################################################### ### code chunk number 13: complexpathdirection ################################################### bdir(3, 3) ################################################### ### code chunk number 14: complexpath ################################################### grid.path(x, y, id=id, gp=gpar(fill="grey")) ################################################### ### code chunk number 15: complexpathevenodd ################################################### grid.path(x, y, id=id, rule="evenodd", gp=gpar(fill="grey")) ################################################### ### code chunk number 16: MurrellPaths.Rnw:340-385 ################################################### target <- function(xc, yc, size, gp=gpar()) { n <- 49 t <- seq(0, 2*pi, length=n) x <- cos(t) y <- sin(t) xx <- xc + size*x yy <- yc + size*y scale <- size*.7 xxx <- xc + scale*x yyy <- yc + scale*y trix <- c(xc + size*.25, xc + size*1.1, xc + size*1.1, xc - size*.25, xc - size*1.1, xc - size*1.1, xc, xc + size*.2, xc - size*.2, xc, xc - size*.2, xc + size*.2) triy <- c(yc, yc - size*.2, yc + size*.2, yc, yc + size*.2, yc - size*.2, yc + size*.25, yc + size*1.1, yc + size*1.1, yc - size*.25, yc - size*1.1, yc - size*1.1) grid.path(c(xx, rev(xxx), trix), c(yy, rev(yyy), triy), id=c(rep(1:2, each=n), rep(3, 3), rep(4, 3), rep(5, 3), rep(6, 3)), gp=gp) } ################################################### ### code chunk number 17: target ################################################### target(.5, .5, .3) ################################################### ### code chunk number 18: targetfilled ################################################### target(.5, .5, .3, gp=gpar(lwd=3)) target(.5, .5, .3, gp=gpar(col=NA, fill="grey")) ################################################### ### code chunk number 19: highlight ################################################### highlight <- function(name) { target(convertX(unit(mtcars$disp[rownames(mtcars) == name], "native"), "npc", valueOnly=TRUE), convertY(unit(mtcars$mpg[rownames(mtcars) == name], "native"), "npc", valueOnly=TRUE), .07, gp=gpar(col=NA, fill=rgb(1, 0, 0, .5))) } library(lattice) xyplot(mpg ~ disp, mtcars) downViewport("plot_01.panel.1.1.vp") # highlight("Porsche 914-2") highlight("Ferrari Dino") # highlight("Lotus Europa") # highlight("Lincoln Continental") ################################################### ### code chunk number 20: MurrellPaths.Rnw:446-447 ################################################### library(grImport) ################################################### ### code chunk number 21: GNUlogo ################################################### PostScriptTrace("GNU.ps", "GNU.xml") GNU <- readPicture("GNU.xml") grid.picture(GNU, x=.25, width=.4, use.gc=FALSE) grid.picture(GNU, x=.75, width=.4) ################################################### ### code chunk number 22: MurrellPaths.Rnw:468-469 ################################################### library(lattice) ################################################### ### code chunk number 23: GNUplot ################################################### cit <- c("1998"=4, "1999"=15, "2000"=17, "2001"=39, "2002"=119, "2003"=276, "2004"=523, "2005"=945, "2006"=1475, "2007"=2015) barchart(~ cit, main = "Number of Citations per Year", xlab = "", panel = function(...) { grid.picture(GNU) grid.rect(gp = gpar(fill = rgb(1, 1, 1, .9))) panel.barchart(...) }) ################################################### ### code chunk number 24: MurrellPaths.Rnw:500-504 ################################################### load("bus.rda") busdata <- read.csv("CTA_-_Ridership_-_Daily_Boarding_Totals.csv") busdata$date <- as.Date(busdata$service_date, format="%m/%d/%Y") ################################################### ### code chunk number 25: bus ################################################### grid.picture(bus, x=.25, width=.4, use.gc=FALSE, gp=gpar(lwd=.5)) grid.picture(bus, x=.75, width=.4) ################################################### ### code chunk number 26: busplot ################################################### library(lattice) xyplot(bus/1000 ~ date, busdata, subset=1:7, type="l", scales=list(x=list(rot=30))) downViewport("plot_01.panel.1.1.vp") setGeneric("modcolour", function(object, ...) { standardGeneric("modcolour") }) setMethod("modcolour", signature("PictureFill"), function(object, ...) { path <- grobify(object, ...) if (!is.null(path$gp$fill) && !is.na(path$gp$fill) && path$gp$fill == "#000000") path$gp$fill <- trellis.par.get("plot.symbol")$col path }) for (i in 1:7) { grid.picture(bus, unit(busdata$date[i], "native"), unit(busdata$bus[i]/1000, "native"), width=unit(7, "mm"), FUN=modcolour) } ################################################### ### code chunk number 27: nz ################################################### library(maptools) load("full_NZ_shore.RData") polygonsToPath <- function(ps) { # Turn the list of polygons into a single set of x/y x <- do.call("c", sapply(ps, function(p) { p@coords[,1] })) y <- do.call("c", sapply(ps, function(p) { p@coords[,2] })) id.lengths <- sapply(ps, function(p) { nrow(p@coords) }) # Generate vertex set lengths list(x=x, y=y, id.lengths=id.lengths) } path <- polygonsToPath(NZ@polygons[[1]]@Polygons) # xrange <- range(path$x) # yrange <- range(path$y) xrange <- c(167.5, 167.7) yrange <- c(-45.5, -44.5) grid.newpage() grid.rect(gp=gpar(col=NA, fill="azure2")) pushViewport(viewport(layout=grid.layout(widths=diff(xrange), heights=diff(yrange), respect=TRUE)), viewport(layout.pos.col=1, xscale=xrange, yscale=yrange)) grid.path(path$x, path$y, id.lengths=path$id.lengths, default.units="native", gp=gpar(fill=colours()[497])) popViewport(2) grid.rect() ################################################### ### code chunk number 28: dataprep ################################################### library(akima) library(maps) library(gpclib) quakes <- read.csv("quakes-mod.csv") quakes$long <- ifelse(quakes$LONG < 0, 360 + quakes$LONG, quakes$LONG) quakes <- quakes[quakes$LAT < 0 & quakes$long < 190, ] library(MASS) qd <- kde2d(quakes$long, quakes$LAT, n=100) ql <- contourLines(qd$x, qd$y, qd$z, nlevels=10) n <- length(ql) # points(quakes$long, quakes$LAT, pch=".") outline <- map("nz", plot=FALSE) xrange <- range(outline$x, na.rm=TRUE) yrange <- range(outline$y, na.rm=TRUE) xbox <- xrange + c(-2, 2) ybox <- yrange + c(-2, 2) hue <- 240 ################################################### ### code chunk number 29: nzmap ################################################### par(mar=rep(2, 4)) # Plot the data map("nz", col="grey", fill=TRUE) ################################################### ### code chunk number 30: nzcontour ################################################### par(mar=rep(2, 4)) # Plot the data map("nz") mapply(function(c, col) { polygon(c, col=col, border=adjustcolor(col, 1, .9, .9, .9)) }, ql, as.list(hcl(hue, 50, 20 + 60*n:1/(n+1)))) map("nz", add=TRUE) ################################################### ### code chunk number 31: nzpathfill ################################################### par(mar=rep(2, 4)) map("nz", col=NA) polypath(c(outline$x, NA, c(xbox, rev(xbox))), c(outline$y, NA, rep(ybox, each=2)), col="grey", rule="evenodd") box() ################################################### ### code chunk number 32: nzfinal ################################################### par(mar=rep(0, 4)) # Plot the data map("nz") mapply(function(c, col) { polygon(c, col=col, border=adjustcolor(col, 1, .9, .9, .9)) }, ql, as.list(hcl(hue, 50, 20 + 60*n:1/(n+1)))) # grey(.7*n:1/(n+1) + .2))) polypath(c(outline$x, NA, c(xbox, rev(xbox))), c(outline$y, NA, rep(ybox, each=2)), col="white", rule="evenodd") # points(quakes$long[quakes$MAG > 7], # quakes$LAT[quakes$MAG > 7], # pch=21, bg=hcl(hue - 180, 80, 80))