Skip to content

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)

chapter13-13_01_l_small.png chapter13-13_01_r_small.png

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)

chapter13-13_02_l_small.png chapter13-13_02_r_small.png

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)

chapter13-13_03_l_small.png chapter13-13_03_r_small.png

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)

chapter13-13_04_l_small.png chapter13-13_04_r_small.png

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.

chapter13-13_05_l_small.png

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+.

Rplot001_small.png

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.

chapter13-13_07_l_small.png

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)

chapter13-13_08_l_small.png chapter13-13_08_r_small.png

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.

chapter13-13_09_l_small.png

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)

chapter13-13_10_l_small.png chapter13-13_10_r_small.png

About these ads
4 Comments leave one →
  1. Dave permalink
    August 18, 2009 11:09 pm

    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…

  2. August 24, 2009 4:09 pm

    It’s slow, but it shouldn’t be extremely slow. What simple things are you trying to do?

  3. chrisbeeleyimh permalink
    September 22, 2011 1:43 pm

    +1 internets to you, what an awesome collection of graphics. Now I just need to find some data to go with them…

  4. Tobias Schmidt permalink
    March 8, 2014 1:50 am

    Figure 13.6 doesn’t seem to be working for me (I get only empty circles).

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Follow

Get every new post delivered to your Inbox.

Join 164 other followers

%d bloggers like this: