Create top-to-bottom fade/gradient geom_density in ggplot2

Question

I would like to create a geom_density that has a top-to-bottom gradient. This is just for aesthetics. For example, the fade of this plot is what I want to achieve:

Minimal working example:

Load libraries:

library(ggplot2)
library(dplyr)

Here's some data

dat <- structure(list(date = structure(c(18335, 18336, 18337, 18338, 
                                         18339, 18340, 18341, 18342, 18343, 18344, 18345, 18346, 18347, 
                                         18348, 18349, 18350, 18351, 18352, 18353, 18354, 18355, 18356, 
                                         18357, 18358, 18359, 18360, 18361, 18362, 18363, 18364, 18365, 
                                         18366, 18367, 18368, 18369, 18370, 18371, 18372, 18373, 18374, 
                                         18375, 18376, 18377, 18378, 18379, 18380, 18381, 18382, 18383, 
                                         18384, 18385, 18386, 18387, 18388, 18389, 18390, 18391, 18392, 
                                         18393, 18394, 18395, 18396, 18397, 18398, 18399, 18400, 18401, 
                                         18402, 18403, 18404, 18405, 18406, 18407, 18408, 18409, 18410, 
                                         18411, 18412, 18413, 18414, 18415, 18416, 18417, 18418, 18419, 
                                         18420, 18421, 18422, 18423, 18424, 18425, 18426, 18427, 18428, 
                                         18429, 18430, 18431, 18432, 18433, 18434, 18435, 18436, 18437, 
                                         18438, 18439, 18440, 18441, 18442), class = "Date"),
                      n = c(49L, 
                            121L, 152L, 142L, 137L, 138L, 129L, 144L, 187L, 245L, 337L, 363L, 
                            360L, 374L, 386L, 399L, 404L, 395L, 402L, 398L, 389L, 392L, 409L, 
                            419L, 402L, 389L, 414L, 391L, 388L, 377L, 402L, 398L, 398L, 398L, 
                            395L, 396L, 275L, 386L, 393L, 394L, 322L, 383L, 388L, 397L, 343L, 
                            399L, 384L, 366L, 358L, 375L, 378L, 373L, 368L, 377L, 369L, 352L, 
                            360L, 367L, 363L, 357L, 357L, 347L, 329L, 361L, 340L, 334L, 359L, 
                            335L, 325L, 322L, 297L, 326L, 350L, 323L, 343L, 275L, 232L, 226L, 
                            234L, 222L, 221L, 191L, 204L, 174L, 138L, 76L, 58L, 52L, 32L, 
                            29L, 27L, 21L, 22L, 20L, 13L, 13L, 10L, 12L, 3L, 3L, 3L, 4L, 
                            3L, 3L, 3L, 3L, 3L, 3L)), row.names = c(NA, -108L),
                 class = c("tbl_df", 
                           "tbl", "data.frame")) %>%
  uncount(n)

And this is the geom_density I would like to fade:

ggplot(dat,
         aes(date)) +
    geom_density(stat = "density",
                 color = "black",
                 fill = "black",
                 lwd = .75)

Here's the plot that the above code produces:

Answer 1

As @teunbrand mentioned, the ggpattern package does provide a solve for this. You'll simply use the geom_density_pattern function, setting pattern = "gradient" like so:

library(ggplot2)
library(ggpattern)

ggplot(dat, aes(x = date)) + 
  geom_density_pattern(pattern = "gradient")

Answer 2

I don't think this is currently supported in vanilla ggplot2. A possible solution would be to have a look at the ggpattern package (https://github.com/coolbutuseless/ggpattern) but this wouldn't install at my machine. In R4.1 (in development), this should become much easier.

Here is a homebrew function that slices up the polygon using polyclip, which you can then use to plot the density. You can control how smooth it is by setting n = ... and the strength of the fade by setting the alpha scale range. I used different data because I couldn't find the uncount function.

library(ggplot2)
library(polyclip)
#> polyclip 1.10-0 built from Clipper C++ version 6.4.0

fade_polygon <- function(x, y, n = 100) {
  poly <- data.frame(x = x, y = y)
  
  # Create bounding-box edges
  yseq <- seq(min(poly$y), max(poly$y), length.out = n)
  xlim <- range(poly$x) + c(-1, 1)
  
  # Pair y-edges
  grad <- cbind(head(yseq, -1), tail(yseq, -1))
  # Add vertical ID
  grad <- cbind(grad, seq_len(nrow(grad)))
  
  # Slice up the polygon
  grad <- apply(grad, 1, function(range) {
    # Create bounding box
    bbox <- data.frame(x = c(xlim, rev(xlim)),
                       y = c(range[1], range[1:2], range[2]))
    
    # Do actual slicing
    slice <- polyclip::polyclip(poly, bbox)
    
    # Format as data.frame
    for (i in seq_along(slice)) {
      slice[[i]] <- data.frame(
        x = slice[[i]]$x,
        y = slice[[i]]$y,
        value = range[3],
        id = c(1, rep(0, length(slice[[i]]$x) - 1))
      )
    }
    slice <- do.call(rbind, slice)
  })
  # Combine slices
  grad <- do.call(rbind, grad)
  # Create IDs
  grad$id <- cumsum(grad$id)
  return(grad)
}

dens <- density(faithful$eruptions)
grad <- fade_polygon(dens$x, dens$y)

ggplot(grad, aes(x, y)) +
  geom_line(data = data.frame(x = dens$x, y = dens$y)) +
  geom_polygon(aes(alpha = value, group = id),
               fill = "blue") +
  scale_alpha_continuous(range = c(0, 1))

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