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

I would recreate the image in ggplot with a function like this:

make_graphic <- function(highlight = 1:8) {
  
  library(ggplot2)
  alpha_vals <- c(0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2)
  
  alpha_vals[highlight] <- 1
  
  df <- data.frame(x = rep(c(0.5, 0.75, 1, 0.75, 0.5), 8),
                   y = rep(c(0.5, 0, 0.5, 1, 0.5), 8) + rep(0:7, each = 5)/2,
                   z = rep(LETTERS[1:8], each = 5))
  
  ggplot(df, aes(x, y)) +
    geom_polygon(aes(fill = z, alpha = z)) +
    geom_text(data = data.frame(x = 0.48, y = rev(0.5 + (0:7)/2),
                                z = rev(LETTERS[1:8]),
                                a = c("THEME", "COORDINATES", "FACETS",
                                      "GEOMETRIES", "SCALES", "STATISTICS", 
                                      "MAPPING", "DATA")), fontface = 2,
              family = "opencondensed",
              aes(label = a, alpha = z), colour = "white", size = 10, hjust = 1) +
    scale_x_continuous(limits = c(0.2, 1)) +
    scale_fill_manual(values = c("#a6aaa9", "#ef4e47", "#34a5da", "#ff9d35", 
                                 "#8abe5e", "#ffe989", "#c52060", "#3f969a")) +
    scale_alpha_manual(values = alpha_vals) +
    theme_void() +
    theme(legend.position = "none",
          plot.background = element_rect(fill = "#222222"))
}

This allows the graphic to be recreated easily by doing:

make_graphic()

And if you want to just highlight the second bottom item, you can do:

make_graphic(2)

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

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.