ggplot2 Version of Figures in “Lattice: Multivariate Data Visualization with R” (Part 12)
August 18, 2009
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) |
4 Comments
leave one →
Perhaps you could also comment on the time it takes each to make the plots. I’ve tried ggplot2 but found it to be extremely slow even for simple things. Maybe I’m doing something wrong…
It’s slow, but it shouldn’t be extremely slow. What simple things are you trying to do?
+1 internets to you, what an awesome collection of graphics. Now I just need to find some data to go with them…
Figure 13.6 doesn’t seem to be working for me (I get only empty circles).