Fade side of panel to indicate ongoing time

Question

The Financial Times has an interesting article on games consoles, "Is it game over for the console?", with a histogram to show the timeline of consoles.

For the current generation (Xbox One and PS4, Switch), the right side of the box is blurred to indicate "on-going". All other boxes have hard edges.

For copyright reasons, I won't show the whole graph, but this is a snipped of it. I believe the graph is produced in R with ggplot2.

I couldn't find how to achieve this effect for boxes - only points. Is there a geom or trick to achieve this blurred edge?

Here is code for a simple graphic to illustrate:

library(tidyverse)
tribble(~device, ~start, ~end, ~num, ~off,
        "x", 2015, 2020, 120, 0,
        "y", 2016, 2022, 150, 120,
        "z", 2017, 2023, 200, 270) %>% 
    ggplot() +
    geom_rect(aes(xmin = start, xmax = end, ymin = off, ymax = off+num, fill = device)) +
    geom_vline(aes(xintercept = 2020.5), lwd = 2, lty = 2) +
    geom_label(aes(x = 2020.5, y = 0, label = "Today")) +
    geom_text(aes(x = 2022, y = 320, label = "The right edge of the\nblue and green boxes\nshould be fuzzy or faded out...")) +
    geom_text(aes(x = 2022, y = 90, label = "...but not the red box")) +
    guides(fill = "none") +
    theme_minimal()

Thank you,

TC

Answer 1

I use the idea of dividing the space and then linearly decreasing the alpha.

Edit:

adding a function for generating new datasets and for appending a plot. Additionally ggplot2 has a new usage of guides function.

data_rect_blur <- function(data, step, edge) {
  stopifnot(inherits(data, "data.frame"))
  stopifnot(is.numeric(step))
  stopifnot(is.numeric(edge))

  require("dplyr", quietly = TRUE)
  require("tidyr", quietly = TRUE)
  require("ggplot2", quietly = TRUE)

  data$edge <- edge
  data$mm <- pmin(data$edge, data$end)
  data$rest <- (data$end - data$edge)
  data$rest_t <- data$rest > 0

  rm_last <- function(x) {
    x[-length(x)]
  }

  df2 <- data %>%
    group_by(device) %>%
    mutate(
      seqe = list(seq(from = edge, to = if_else(rest_t, end, edge), by = step)),
      seqe_s = list(rm_last(seq(from = edge, to = if_else(rest_t, end, edge), by = step))),
      seqe_e = list((seq(from = edge, to = if_else(rest_t, end, edge), by = step))[-1]),
      alps = list(seq(0.8, 0, length = length(seqe[[1]]) - 1))
    )

  df3 <- tidyr::unnest(df2, cols = c(seqe_s, seqe_e, alps))

  res <- list(base = df2, add = df3)

  res
}

df <- dplyr::tribble(
  ~device, ~start, ~end, ~num, ~off,
  "x", 2015, 2020, 120, 0,
  "y", 2016, 2022, 150, 120,
  "z", 2017, 2023, 200, 270
)



gg_rect_blur <- function(df, step, edge) {
  stopifnot(inherits(df, "data.frame"))
  df_blur_list <- data_rect_blur(df, step, edge)
  ggplot(df) +
    geom_rect(data = df_blur_list$base, aes(xmin = start, xmax = mm, ymin = off, ymax = off + num, fill = device)) +
    geom_rect(data = df_blur_list$add, aes(xmin = seqe_s, xmax = seqe_e, ymin = off, ymax = off + num, fill = device, alpha = alps))
}

gg_rect_blur(df, 0.1, 2020.05) +
  geom_vline(aes(xintercept = 2020.5), lwd = 2, lty = 2) +
  geom_label(aes(x = 2020.5, y = 0, label = "Today")) +
  guides(fill = "none") +
  geom_text(aes(x = 2022, y = 320, label = "The right edge of the\nblue and green boxes\nshould be fuzzy or faded out...")) +
  geom_text(aes(x = 2022, y = 90, label = "...but not the red box")) +
  theme_minimal() +
  theme(legend.position = "none")
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union

^{Created on 2021-07-07 by the reprex package (v2.0.0)}

Answer 2

Here is another solution based on the idea in the answer linked by @andrew_reece

You just have to call ggplot_grad_rects in your pipe, with n you can determine how smooth the gradient is:

library(tidyverse)
# this function generates the values for the separate geom_rects and the
# corresponding alpha value
generate_data <- function(xmin, xmax, id_col, threshold, n) {
  # if the rectangle does not fall into the threshold, draw the complete
  # rectangle solid
  if (xmax < threshold) {
    xmin_out <- xmin
    xmax_out <- xmax
    alpha_steps <- 1
  } else {
    # otherwise generate a gradient over the part of the rectangle right of the
    # threshold
    x_steps <- c(xmin,
                 seq(from = threshold, to = xmax, length.out = n + 1))
    xmin_out <- x_steps[-(n + 1)]
    xmax_out <- x_steps[-1]
    alpha_steps <- seq(from = 1, to = 0, length.out = n + 1)
  }
  
  data.frame(device = id_col,
             xmin = xmin_out,
             xmax = xmax_out,
             alpha = alpha_steps)
  
}

# this function calls the data generating function and sets up the ggplot
ggplot_grad_rects <- function(data, threshold, n) {
  
  # generate expanded rectangles
  # input arguments of pmap depend on the order in the data data.frame
  # also, the id_col is hardcoded -> code is not fully abstracted
  data_rect_expanded <- pmap_dfr(data, ~generate_data(xmin = ..2,
                                                      xmax = ..3,
                                                      id_col = ..1,
                                                      threshold = threshold,
                                                      n = n))
  
  # join all the different rectangles with the original data
  data_final <- data %>% 
    full_join(data_rect_expanded, by = "device")
  
  ggplot(data) +
    geom_rect(data = data_final,
              aes(xmin = xmin, xmax = xmax, ymin = off, ymax = off + num,
                  alpha = alpha, fill = device)) +
    guides(alpha = FALSE)
}

tribble(~device, ~start, ~end, ~num, ~off,
        "x", 2015, 2020, 120, 0,
        "y", 2016, 2022, 150, 120,
        "z", 2017, 2023, 200, 270) %>% 
  ggplot_grad_rects(threshold = 2020.5, n = 100) +
  geom_vline(aes(xintercept = 2020.5), lwd = 2, lty = 2) +
  geom_label(aes(x = 2020.5, y = 0, label = "Today")) +
  geom_text(aes(x = 2022, y = 320, label = "The right edge of the\nblue and green boxes\nshould be fuzzy or faded out...")) +
  geom_text(aes(x = 2022, y = 90, label = "...but not the red box")) +
  guides(fill = FALSE) +
  theme_minimal()

^{Created on 2020-09-27 by the reprex package (v0.3.0)}