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

August 18, 2009
By

(This article was first published on Learning R, and kindly contributed to R-bloggers)

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

To leave a comment for the author, please follow the link and comment on their blog: Learning R.

R-bloggers.com offers daily e-mail updates about R news and tutorials on topics such as: Data science, Big Data, R jobs, visualization (ggplot2, Boxplots, maps, animation), programming (RStudio, Sweave, LaTeX, SQL, Eclipse, git, hadoop, Web Scraping) statistics (regression, PCA, time series, trading) and more...



If you got this far, why not subscribe for updates from the site? Choose your flavor: e-mail, twitter, RSS, or facebook...

Tags: , , , , , , ,

Comments are closed.

Sponsors

Mango solutions



RStudio homepage



Zero Inflated Models and Generalized Linear Mixed Models with R

Quantide: statistical consulting and training

datasociety

http://www.eoda.de





ODSC

ODSC

CRC R books series





Six Sigma Online Training









Contact us if you wish to help support R-bloggers, and place your banner here.

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)