ggplot2 Version of Figures in “Lattice: Multivariate Data Visualization with R” (Part 12)

> library(lattice)
> library(ggplot2)

> grid <- data.frame(p = 11:30, q = 10)
> grid$k <- with(grid, factor(p/q))

> panel.hypotrochoid <- function(r, d, cycles = 10, density = 30) {
+     if (missing(r))
+         r <- runif(1, 0.25, 0.75)
+     if (missing(d))
+         d <- runif(1, 0.25 * r, r)
+     t <- 2 * pi * seq(0, cycles, by = 1/density)
+     x <- (1 - r) * cos(t) + d * cos((1 - r) * t/r)
+     y <- (1 - r) * sin(t) - d * sin((1 - r) * t/r)
+     panel.lines(x, y)
+ }
> panel.hypocycloid <- function(x, y, cycles = x, density = 30) {
+     panel.hypotrochoid(r = x/y, d = x/y, cycles = cycles,
+         density = density)
+ }
> prepanel.hypocycloid <- function(x, y) {
+     list(xlim = c(-1, 1), ylim = c(-1, 1))
+ }

> pl <- xyplot(p ~ q | k, grid, aspect = 1, scales = list(draw = FALSE),
+     prepanel = prepanel.hypocycloid, panel = panel.hypocycloid)
> print(pl)

> panel.hypotrochoid.gg <- function(r, d, cycles = 10,
+     density = 30) {
+     if (missing(r))
+         r <- runif(1, 0.25, 0.75)
+     if (missing(d))
+         d <- runif(1, 0.25 * r, r)
+     t <- 2 * pi * seq(0, cycles, by = 1/density)
+     x <- (1 - r) * cos(t) + d * cos((1 - r) * t/r)
+     y <- (1 - r) * sin(t) - d * sin((1 - r) * t/r)
+     data.frame(x, y)
+ }
> panel.hypocycloid.gg <- function(x, y, cycles = x, density = 30) {
+     panel.hypotrochoid.gg(r = x/y, d = x/y, cycles = cycles,
+         density = density)
+ }

Note

> df <- ddply(grid, .(p, q, k), function(df) {
+     with(df, panel.hypocycloid.gg(q, p))
+ })

> pg <- ggplot(df, aes(x, y)) + geom_path() + facet_wrap(~k,
+     ncol = 4) + scale_x_continuous("", breaks = NA) +
+     scale_y_continuous("", breaks = NA)
> print(pg)

> set.seed(20070706)

> pl <- xyplot(c(-1, 1) ~ c(-1, 1), aspect = 1, cycles = 15,
+     scales = list(draw = FALSE), xlab = "", ylab = "",
+     panel = panel.hypotrochoid)
> print(pl[rep(1, 42)])

> df2 <- ldply(rep(1:42), function(k) {
+     data.frame(k, panel.hypotrochoid.gg(cycles = 15))
+ })

> pg <- ggplot(df2, aes(x, y)) + geom_path() + facet_wrap(~k,
+     ncol = 6) + scale_x_continuous("", breaks = NA) +
+     scale_y_continuous("", breaks = NA) + opts(panel.margin = 0,
+     strip.text.x = theme_blank())
> print(pg)

> library("logspline")

> prepanel.ls <- function(x, n = 50, ...) {
+     fit <- logspline(x)
+     xx <- do.breaks(range(x), n)
+     yy <- dlogspline(xx, fit)
+     list(ylim = c(0, max(yy)))
+ }
> panel.ls <- function(x, n = 50, ...) {
+     fit <- logspline(x)
+     xx <- do.breaks(range(x), n)
+     yy <- dlogspline(xx, fit)
+     panel.lines(xx, yy, ...)
+ }

> faithful$Eruptions <- equal.count(faithful$eruptions,
+     4)

> pl <- densityplot(~waiting | Eruptions, data = faithful,
+     prepanel = prepanel.ls, panel = panel.ls)
> print(pl)

> fn <- function(data = faithful$eruptions, number = 4,
+     ...) {
+     intrv <<- as.data.frame(co.intervals(data, number,
+         ...))
+     eruptions <- sort(unique(data))
+     intervals <- ldply(eruptions, function(x) {
+         t(as.numeric(x < intrv$V2 & x > intrv$V1))
+     })
+     tmp <- melt(cbind(eruptions, intervals), id.var = 1)
+     tmp[tmp$value > 0, 1:2]
+ }
> faithful2 <- merge(faithful, fn())
> intrv <- with(intrv, paste(V1, V2, sep = "-"))
> faithful2 <- rename(faithful2, c(variable = "erupt"))
> faithful2$erupt <- factor(faithful2$erupt, labels = intrv)

> panel.ls.gg <- function(x, n = 50, ...) {
+     fit <- logspline(x)
+     xx <- do.breaks(range(x), n)
+     yy <- dlogspline(xx, fit)
+     data.frame(xx, yy, ...)
+ }
> a <- ddply(faithful2, .(erupt), function(df) {
+     panel.ls.gg(df$waiting)
+ })

> pg <- ggplot(a, aes(xx, yy)) + geom_line() + facet_grid(~erupt)
> print(pg)

> data(Chem97, package = "mlmRev")

> panel.bwtufte <- function(x, y, coef = 1.5, ...) {
+     x <- as.numeric(x)
+     y <- as.numeric(y)
+     ux <- sort(unique(x))
+     blist <<- tapply(y, factor(x, levels = ux), boxplot.stats,
+         coef = coef, do.out = FALSE)
+     blist.stats <<- t(sapply(blist, "[[", "stats"))
+     blist.out <<- lapply(blist, "[[", "out")
+     panel.points(y = blist.stats[, 3], x = ux, pch = 16,
+         ...)
+     panel.segments(x0 = rep(ux, 2), y0 = c(blist.stats[,
+         1], blist.stats[, 5]), x1 = rep(ux, 2), y1 = c(blist.stats[,
+         2], blist.stats[, 4]), ...)
+ }

> pl <- bwplot(gcsescore^2.34 ~ gender | factor(score),
+     Chem97, panel = panel.bwtufte, layout = c(6, 1),
+     ylab = "Transformed GCSE score")
> print(pl)

> dt <- ddply(Chem97, .(gender, score), function(df) {
+     boxplot.stats(df$gcsescore^2.34)$stats
+ })

> pg <- ggplot(dt, aes(x = gender)) + geom_linerange(aes(ymin = V1,
+     ymax = V2)) + geom_linerange(aes(ymin = V4, ymax = V5)) +
+     geom_point(aes(y = V3)) + facet_grid(~score)
> print(pg)

> data(Cars93, package = "MASS")
> cor.Cars93 <- cor(Cars93[, !sapply(Cars93, is.factor)],
+     use = "pair")
> ord <- order.dendrogram(as.dendrogram(hclust(dist(cor.Cars93))))
> panel.corrgram <- function(x, y, z, subscripts, at, level = 0.9,
+     label = FALSE, ...) {
+     require("ellipse", quietly = TRUE)
+     x <- as.numeric(x)[subscripts]
+     y <- as.numeric(y)[subscripts]
+     z <- as.numeric(z)[subscripts]
+     zcol <- level.colors(z, at = at, ...)
+     for (i in seq(along = z)) {
+         ell <- ellipse(z[i], level = level, npoints = 50,
+             scale = c(0.2, 0.2), centre = c(x[i], y[i]))
+         panel.polygon(ell, col = zcol[i], border = zcol[i],
+             ...)
+     }
+     if (label)
+         panel.text(x = x, y = y, lab = 100 * round(z,
+             2), cex = 0.8, col = ifelse(z < 0, "white",
+             "black"))
+ }

> pl <- levelplot(cor.Cars93[ord, ord], at = do.breaks(c(-1.01,
+     1.01), 20), xlab = NULL, ylab = NULL, colorkey = list(space = "top"),
+     scales = list(x = list(rot = 90)), panel = panel.corrgram,
+     label = TRUE)
> print(pl)

Ellipses are not supported in ggplot2.

> panel.corrgram.2 <- function(x, y, z, subscripts, at = pretty(z),
+     scale = 0.8, ...) {
+     require("grid", quietly = TRUE)
+     x <- as.numeric(x)[subscripts]
+     y <- as.numeric(y)[subscripts]
+     z <- as.numeric(z)[subscripts]
+     zcol <- level.colors(z, at = at, ...)
+     for (i in seq(along = z)) {
+         lims <- range(0, z[i])
+         tval <- 2 * base::pi * seq(from = lims[1], to = lims[2],
+             by = 0.01)
+         grid.polygon(x = x[i] + 0.5 * scale * c(0, sin(tval)),
+             y = y[i] + 0.5 * scale * c(0, cos(tval)),
+             default.units = "native", gp = gpar(fill = zcol[i]))
+         grid.circle(x = x[i], y = y[i], r = 0.5 * scale,
+             default.units = "native")
+     }
+ }

> pl <- levelplot(cor.Cars93[ord, ord], xlab = NULL, ylab = NULL,
+     at = do.breaks(c(-1.01, 1.01), 101), panel = panel.corrgram.2,
+     scales = list(x = list(rot = 90)), colorkey = list(space = "top"),
+     col.regions = colorRampPalette(c("red", "white",
+         "blue")))
> print(pl)

Not supported in +ggplot2+.

> panel.3d.contour <- function(x, y, z, rot.mat, distance,
+     nlevels = 20, zlim.scaled, ...) {
+     add.line <- trellis.par.get("add.line")
+     panel.3dwire(x, y, z, rot.mat, distance, zlim.scaled = zlim.scaled,
+         ...)
+     clines <- contourLines(x, y, matrix(z, nrow = length(x),
+         byrow = TRUE), nlevels = nlevels)
+     for (ll in clines) {
+         m <- ltransform3dto3d(rbind(ll$x, ll$y, zlim.scaled[2]),
+             rot.mat, distance)
+         panel.lines(m[1, ], m[2, ], col = add.line$col,
+             lty = add.line$lty, lwd = add.line$lwd)
+     }
+ }

> pl <- wireframe(volcano, zlim = c(90, 250), nlevels = 10,
+     aspect = c(61/87, 0.3), panel.aspect = 0.6, panel.3d.wireframe = "panel.3d.contour",
+     shade = TRUE, screen = list(z = 20, x = -60))
> print(pl)

ggplot2 currently does not support true 3d surfaces.

> library("maps")
> county.map <- map("county", plot = FALSE, fill = TRUE)

> data(ancestry, package = "latticeExtra")
> ancestry <- subset(ancestry, !duplicated(county))
> rownames(ancestry) <- ancestry$county
> freq <- table(ancestry$top)
> keep <- names(freq)[freq > 10]
> ancestry$mode <- with(ancestry, factor(ifelse(top %in%
+     keep, top, "Other")))
> modal.ancestry <- ancestry[county.map$names, "mode"]

> library("RColorBrewer")
> colors <- brewer.pal(n = nlevels(ancestry$mode), name = "Pastel1")

> pl <- xyplot(y ~ x, county.map, aspect = "iso", scales = list(draw = FALSE),
+     xlab = "", ylab = "", par.settings = list(axis.line = list(col = "transparent")),
+     col = colors[modal.ancestry], border = NA, panel = panel.polygon,
+     key = list(text = list(levels(modal.ancestry), adj = 1),
+         rectangles = list(col = colors), x = 1, y = 0,
+         corner = c(1, 0)))
> print(pl)

> counties <- map_data("county")
> counties$reg <- with(counties, paste(region, subregion,
+     sep = ","))
> co_anc <- merge(counties, ancestry, by.x = "reg", by.y = "county")
> co_anc <- co_anc[order(co_anc$order), ]

> pg <- ggplot(co_anc, aes(long, lat, fill = mode, group = group)) +
+     geom_polygon() + scale_fill_brewer("", palette = "Pastel1")
> print(pg)

> rad <- function(x) {
+     pi * x/180
+ }
> county.map$xx <- with(county.map, cos(rad(x)) * cos(rad(y)))
> county.map$yy <- with(county.map, sin(rad(x)) * cos(rad(y)))
> county.map$zz <- with(county.map, sin(rad(y)))
> panel.3dpoly <- function(x, y, z, rot.mat = diag(4),
+     distance, ...) {
+     m <- ltransform3dto3d(rbind(x, y, z), rot.mat, distance)
+     panel.polygon(x = m[1, ], y = m[2, ], ...)
+ }
> aspect <- with(county.map, c(diff(range(yy, na.rm = TRUE)),
+     diff(range(zz, na.rm = TRUE)))/diff(range(xx, na.rm = TRUE)))

> pl <- cloud(zz ~ xx * yy, county.map, par.box = list(col = "grey"),
+     aspect = aspect, panel.aspect = 0.6, lwd = 0.01,
+     panel.3d.cloud = panel.3dpoly, col = colors[modal.ancestry],
+     screen = list(z = 10, x = -30), key = list(text = list(levels(modal.ancestry),
+         adj = 1), rectangles = list(col = colors), space = "top",
+         columns = 4), scales = list(draw = FALSE), zoom = 1.1,
+     xlab = "", ylab = "", zlab = "")
> print(pl)

ggplot2 currently does not support true 3d surfaces.

> library("latticeExtra")
> library("mapproj")
> data(USCancerRates)
> rng <- with(USCancerRates, range(rate.male, rate.female,
+     finite = TRUE))
> nbreaks <- 50
> breaks <- exp(do.breaks(log(rng), nbreaks))
> breaks2 <- c(unique(breaks[1 + (0:(nbreaks - 1)%/%10) *
+     10]), max(breaks) - 0.1)

> pl <- mapplot(rownames(USCancerRates) ~ rate.male + rate.female,
+     data = USCancerRates, breaks = breaks, map = map("county",
+         plot = FALSE, fill = TRUE, projection = "tetra"),
+     scales = list(draw = T), xlab = "", main = "Average yearly deaths due to cancer per 100000")
> print(pl)

> USCancerRates.df <- namerows(USCancerRates, col.name = "reg")
> co_cancer <- merge(counties, USCancerRates.df, by = c("reg"))
> co_cancer <- co_cancer[order(co_cancer$order), ]
> co_cancer.m <- melt(co_cancer, measure.vars = c("rate.male",
+     "rate.female"), na.rm = TRUE)
> co_cancer.m$fill <- with(co_cancer.m, as.numeric(as.character(cut(value,
+     breaks, labels = comma(breaks[-1])))))

> brewer.div <- colorRampPalette(brewer.pal(11, "Spectral"))

> pg <- ggplot(co_cancer.m, aes(long, lat, group = reg,
+     fill = fill)) + geom_polygon() + coord_map(projection = "tetra") +
+     facet_wrap(~variable, ncol = 1) + scale_fill_gradientn("",
+     colours = brewer.div(nbreaks), trans = "log") + opts(title = "Average yearly deaths due to cancer per 100000")
> print(pg)