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

This is the 12th post in a series attempting to recreate the figures in Lattice: Multivariate Data Visualization with R (R code available here) with ggplot2.

Previous parts in this series: Part 1, Part 2, Part 3, Part 4, Part 5, Part 6, Part 7, Part 8, Part 9, Part 10, Part 11.

---

Chapter 13 – Advanced Panel Functions

Topics covered:

• Built-in panel and accessors functions
• Examples

Figure 13.1

> 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)) + }

lattice

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

ggplot2

> 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	panel.lines(x, y) replaced with data.frame(x, y) in the panel.hypotrochoid.gg function.

> 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)

Figure 13.2

lattice

> 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)])

ggplot2

> 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)

Figure 13.3

> library("logspline")

lattice

> 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)

ggplot2

> 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)

Figure 13.4

> data(Chem97, package = "mlmRev")

lattice

> 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)

ggplot2

> 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)

Figure 13.5

lattice

> 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)

ggplot2

Ellipses are not supported in ggplot2.

Figure 13.6

lattice

> 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)

ggplot2

Not supported in +ggplot2+.

Figure 13.7

lattice

> 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

ggplot2 currently does not support true 3d surfaces.

Figure 13.8

lattice

> 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)

ggplot2

> 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)

Figure 13.9

lattice

> 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

ggplot2 currently does not support true 3d surfaces.

Figure 13.10

> 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)

lattice

> 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)

ggplot2

> 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)