How to produce a graphic of stacked planes or overlapping diamonds using R (and ideally ggplot2)?

Question

While looking at upskilling myself, I was watching the really quite excellent ggplot2 workshop to get myself better at using the package by understanding how it works at a fundamental level.

As part of that workshop, I was struck by one of the visualisations used in the workshop as being especially useful for explaining a layered hierarchy of dependencies, and I'm looking to figure out how I could generate such a picture (ideally using R).

These two pictures show the two parts of the visualisation I'm trying to reproduce: Stacked Planes with labels:

Stacked Planes, with transparencies for most, and labels (appropriately highlighted):

I have been able to produce something similar, using rgl, but it's not nearly as nice. Given I am trying to upskill myself in ggplot2, I would like to be able to produce it using ggplot2 (or one of it's extensions), as that would enable me to control some of the "nicities" of the graphic much easier).

Is this possible using ggplot2 or an extension package?

The code for producing it in rgl is:

library(rgl)
# Create some dummy data
dat <- replicate(2, 1:3)

# Initialize the scene, no data plotted
# hardcoded user matrix of a particular view (so I can go straight to that view each time)
userMatrix_orig <- matrix(c(-0.7069399, -0.2729415, 0.6524867, 0.0000000, 0.7072651, -0.2773000, 0.6502926, 0.0000000, 0.003442926, 0.921199083, 0.389076293, 0.000000000, 0, 0, 0, 1), nrow = 4 )

plot3d(dat, type = 'n', xlim = c(-1, 1), ylim = c(-1, 1), zlim = c(-10, 10), 
       xlab = '', ylab = '', zlab = '', axes=FALSE) 
view3d(userMatrix=userMatrix_orig)
material3d(alpha=1.0)
# Add planes
planes3d(1, 1, 1, -2, col = 'paleturquoise', alpha = 0.8, name="hello")
planes3d(1, 1, 1, -4, col = 'palegreen', alpha = 0.8)
planes3d(1, 1, 1, -6, col = 'palevioletred', alpha = 0.8)
planes3d(1, 1, 1, -8, col = 'midnightblue', alpha = 0.8)
planes3d(1, 1, 1, 0, col = 'red', alpha = 0.8)
planes3d(1, 1, 1, 2, col = 'green', alpha = 0.8)
planes3d(1, 1, 1, 4, col = 'orange', alpha = 0.8)
planes3d(1, 1, 1, 6, col = 'blue', alpha = 0.8)

# Label the planes
family_val <- c("sans")
adj_val <- 1
cex_val <- 2.5
text3d(x=1, y =-1, z = -6, texts="data", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = -4, texts="mapping", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = -2, texts="statistics", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 0, texts="scales", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 2, texts="geometries", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 4, texts="facets", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 6, texts="coordinates", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 8, texts="theme", adj = adj_val, family = family_val, cex = cex_val )

and the graphic I produced using that is:

Answer 1

Here's an attempt.

Data

library(dplyr)
mydata <- data.frame(
  label = c("THEME", "COORDINATES", "FACETS", "GEOMETRIES", "SCALES", "STATISTICS", "MAPPING", "DATA"),
  ybase = 8:1,
  color = c("#3f969a", "#c52060", "#ffe989", "#8abe5e", "#ff9d35", "#34a5da", "#ef4e47", "#a6aaa9")
) %>%
  rowwise() %>%
  mutate(
    xs = list(c(0, 2, 0, -2)),
    ys = lapply(ybase, `+`, c(1.1, 0, -1.1, 0)),
    ord = list(1:4)
  ) %>%
  ungroup() %>%
  tidyr::unnest(c(xs, ys, ord)) %>%
  arrange(ybase, ord)
spldata <- split(mydata, mydata$label)
spldata <- spldata[order(sapply(spldata, function(z) z$ybase[1]))]

The reason I create spldata is because ggplot2 does not (afaik) allow setting the z-order easily, so I will resort (next block) to plotting the polygons iteratively.

Plot, no highlights

library(ggplot2)
ggplot(mydata, aes(xs, ys, group = label)) +
  lapply(spldata, function(dat) {
    geom_polygon(aes(fill = I(color)), data = dat)
  }) +
  geom_text(aes(x = -2.2, y = ybase, label = label),
            hjust = 1, color = "white", size = 7,
            data = ~ filter(., ord == 1)) +
  guides(fill = "none", color = "none", alpha = "none") +
  scale_x_continuous(expand = expansion(add = c(2.5, 0.2))) +
  theme(
    plot.background = element_rect(colour = "black", fill = "black"),
    panel.background = element_rect(colour = "black", fill = "black"),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    axis.text = element_blank(), axis.ticks = element_blank()
  )

Plot, with highlight

The changes here:

• add alpha = if ... to geom_polygons
• split the geom_text into two calls, since I did not want to found colour= aesthetics between polygons and texts

this <- c("THEME", "MAPPING")
ggplot(mydata, aes(xs, ys, group = label)) +
  lapply(spldata, function(dat) {
    geom_polygon(aes(fill = I(color)),
                 alpha = if (dat$label[1] %in% this) 1 else 0.2,
                 data = dat)
  }) +
  {
    if (any(!mydata$label %in% this))
      geom_text(aes(x = -2.2, y = ybase, label = label),
                hjust = 1, color = "gray50", size = 7,
                data = ~ filter(., ord == 1, !label %in% this))
  } +
  {
    if (any(this %in% mydata$label))
      geom_text(aes(x = -2.2, y = ybase, label = label),
                hjust = 1, color = "white", size = 7,
                data = ~ filter(., ord == 1, label %in% this))
  } +
  guides(fill = "none", color = "none", alpha = "none") +
  scale_x_continuous(expand = expansion(add = c(2.5, 0.2))) +
  theme(
    plot.background = element_rect(colour = "#222222", fill = "#222222"),
    panel.background = element_rect(colour = "#222222", fill = "#222222"),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    axis.text = element_blank(), axis.ticks = element_blank()
  )

(I borrowed From AllanCameron the idea of "one or more" for this in order to be able to highlight more than one (or perhaps none).

Answer 2

After working on it a while myself, I came up with the following function:

library(ggplot2)

generate_layer_diagram <- function(highlight_layers = "all", num_layers = 8, 
                                   overwrite_layer_labels = c('DATA','MAPPING','SCALES','STATISTICS','GEOMETRIES','FACETS','COORDINATES','THEMES'), 
                                   overwrite_colours = c('grey','blue','red','orange','paleturquoise','palegreen','palevioletred','midnightblue'),
                                   base_colour_set_name="Set3",
                                   base_num_colours=12L,
                                   save_path="",
                                   transparent_background=FALSE) {
  base_image_height <- 20.32
  base_image_width <- 21.77
  scaling_factor <- 0.69
  alpha_highlight <- 1.0
  alpha_mute <- 0.2
  font_size <- 8*scaling_factor
  font_weight <- "bold"
  if(transparent_background) {
    font_colour <- "black"
    background_color <- "transparent"
  } else {
    font_colour <- "white"
    background_color <- "black"
  }
  
  diamond <- function(side_length, centre) {
    base <- matrix(c(1, 0, 0, 1, -1, 0, 0, -1), nrow = 2) * sqrt(2) / 2
    trans <- (base * side_length) + centre
    as.data.frame(t(trans))
  }
  
  if(is.character(highlight_layers) && highlight_layers == "all") {
    highlight_layers = c(1:num_layers)
  }
  highlights <- c(rep(FALSE,num_layers))
  highlights[highlight_layers] <- TRUE
  
  layer_labels <- paste0(c("layer_"),c(1:num_layers)) %>% data.table
  layer_labels[,labels:=.][,.:=NULL]
  if(length(overwrite_layer_labels) > num_layers) {
    overwrite_layer_labels <- overwrite_layer_labels[1:num_layers]
  }
  layer_labels[1:length(overwrite_layer_labels),labels:=overwrite_layer_labels]
  
  base_colour_set <- RColorBrewer::brewer.pal(base_num_colours,base_colour_set_name) %>% data.table()
  base_colour_set <- base_colour_set[,colours:=.][,.:=NULL]
  if(num_layers > base_num_colours) {
    base_colour_set <- base_colour_set[rep(seq_len(nrow(base_colour_set)), ceiling(num_layers/base_num_colours)), ]
  }
  base_colour_set <- base_colour_set[1:num_layers]
  colour_set <- base_colour_set
  if(length(overwrite_colours) > num_layers) {
    overwrite_colours <- overwrite_colours[1:num_layers]
  }
  colour_set[1:length(overwrite_colours),colours:=overwrite_colours]
  
  dt <- data.table(side_lengths = rep(c(2),num_layers),
                   centres = matrix(c(1 + rep(0,num_layers),2 + 0:(num_layers-1)),nrow=num_layers),
                   colours = colour_set,
                   labels = layer_labels,
                   highlights = highlights)
  
  dt[,alphas:=(as.numeric(highlights)*alpha_highlight + as.numeric(!highlights)*alpha_mute)]
  
  
  myplot <- ggplot() + lapply(c(1:num_layers),function(x) {geom_polygon(data = diamond(dt$side_lengths[x], c(dt$centres.V1[x],dt$centres.V2[x])), mapping = aes(x = V1, y = V2), fill = dt$colours[x], alpha = dt$alphas[x])}) +
    lapply(c(1:num_layers),function(z) {annotate("text", x = -(dt$centres.V1[z]/2)*1.1, y = dt$centres.V2[z], label = dt$labels[z], alpha = dt$alphas[z], size=font_size, 
                                        fontface = font_weight, hjust=1, colour=font_colour)}) + 
    coord_cartesian(xlim = c(-2,3), ylim =c(-1, (num_layers+4) )) +
    theme_void() + 
    #theme_classic() + # gets rid of the ugly bounding box
    theme( plot.background = element_rect(fill = background_color)
           ,axis.line = element_blank(), axis.ticks = element_blank(), axis.title = element_blank(), axis.text = element_blank()
           #,plot.margin = element_blank()
           ,panel.grid = element_blank()
           ,panel.grid.major = element_blank()
           ,panel.grid.minor = element_blank()
           ,panel.background = element_rect(fill=NA)
           ,panel.border = element_rect(fill=NA)
           ,validate=TRUE) # sets the background and removes the various axes
  
  option_markers <- c(rep(0,num_layers))
  option_markers[highlight_layers] <- 1
  
  suffix <- paste0(option_markers,collapse = "_")
  
  if(save_path != ""){
    ggsave(paste0(save_path,"\\pic",suffix,".png"), myplot, height=base_image_height*scaling_factor, width=base_image_width*scaling_factor, units = "cm")
  } else {
    myplot
  }
  
  return(myplot)
}

highlight_layers = "all"
num_layers <- 5
overwrite_layer_labels <- c('DATA','MAPPING','SCALES','STATISTICS','GEOMETRIES','FACETS','COORDINATES','THEMES')
overwrite_colours <- c('grey','blue','red','orange','paleturquoise','palegreen','palevioletred','midnightblue')

Ans the various example function calls produce:

generate_layer_diagram()

generate_layer_diagram(c(1:3),num_layers = num_layers)

generate_layer_diagram(1)

generate_layer_diagram(2)

# Data Mapping and Geometries
generate_layer_diagram(c(1,2,5))

which produces:

Thanks to @AllenCameron's excellent answer for the inspiration of passing a vector to highlight multiple layers at once.