Pomological Colors

Garrick Aden-Buie 2/4/2018

Pomological Plots

• Pomological Plots
• Color Palette
• Setup theme and scales
• Add paper background!
• Demo!
  • Basic iris plot
  • Stacked bar chart
  • Density Plot
  • Points and lines
  • One last plot
• Appendix

Aron Atkins (@aronatkins) gave a great talk at rstudio::conf 2018 about a subject near and dear to my heart: parameterized RMarkdown. And apples.

In his talk, he designed a parameterized RMarkdown report that would provide the user with a customized report for their selected fruit, based on the USDA Pomological Watercolors database. I hade never heard of the USDA watercolor – or the it’s fan club twitter account @pomological until watching his talk. It’s a treasure trove of thousands of watercolor images of fruits; beautiful images with intricate details and a very unique and stunning palette. The perfect palette for a custom ggplot2 theme.

What follows is a set of functions that I plan to pull together into a simple package that will provide a custom, pomological-inspired ggplot2 theme.

Before reading more about ggpomological, you should really check out Aron’s talk or his slides.

Color Palette

The first thing I did was browse through the pomological watercolors collection, downloading images of a wide variety of fruits. I didn’t do this in any systematic way, other than occasionally searching for a particular type of fruit, like ‘grape’ or ‘papaya’.

From these images, I used an application (that I installed forever ago and is no longer around) called ColorSchemer Studio to pull out a set of colors that I felt represented the collection.

I ended up with a lot of colors.

From this list, I chose just a few that worked well together.

pomological_palette <- c(
   "#c03728" #red
  ,"#919c4c" #green darkish
  ,"#fd8f24" #orange brighter
  ,"#f5c04a" #yelloww
  ,"#e68c7c" #pink
  ,"#828585" #light grey
  ,"#c3c377" #green light
  ,"#4f5157" #darker blue/grey
  ,"#6f5438" #lighter brown
)

# Palette colors
scales::show_col(pomological_palette)

pomological_base <- list(
   "paper"       = "#fffeea"
  ,"paper_alt"   = "#f8eed1"
  ,"light_line"  = "#efe1c6"
  ,"medium_line" = "#a89985"
  ,"darker_line" = "#6b452b"
  ,"black"       = "#3a3e3f"
  ,"dark_blue"   = "#2b323f"
)

# Base colors
scales::show_col(unlist(pomological_base))

Setup theme and scales

I created two theme-generating functions, pomological_theme() sets the plot theme to be representative of the paper and styling of the watercolors and includes a paper-colored background, and pomological_theme_nobg() is the same as the first, just with a transparent (or white) background.

A handwriting font is needed for the fully authentic pomological look, and I found a few from Google Fonts that fit the bill.

• Homemade Apple
• Amatic SC
• Mr. Bedfort

Alternatively, use something like calligrapher.com to create your own handwriting font!

pomological_theme <- function(
  base_family = 'Homemade Apple', 
  base_size = 16,
  text.color = NULL,
  plot.background.color = NULL,
  panel.grid.color = NULL,
  panel.grid.linetype = 'dashed',
  axis.text.color = NULL,
  axis.text.size = base_size * 14/16,
  base_theme = ggplot2::theme_minimal()
) {
  pomological_base <- list(
    "paper" = "#fffeea",
    'paper_alt' = "#f8eed1",
    'light_line' = '#efe1c6',
    'medium_line' = "#a89985",
    'darker_line' = "#6b452b",
    'black' = "#3a3e3f",
    "dark_blue" = "#2b323f"
  )
  
  base_theme + 
    ggplot2::theme(
      text = element_text(
        family = base_family, 
        size = base_size, 
        colour = ifelse(hasArg(text.color), text.color, pomological_base$dark_blue)
      ),
      plot.background = element_rect(
        fill = ifelse(hasArg(plot.background.color), plot.background.color, pomological_base$paper), 
        colour = NA
      ),
      panel.grid = element_line(
        colour = ifelse(hasArg(panel.grid.color), panel.grid.color, pomological_base$light_line),
        linetype = panel.grid.linetype),
      panel.grid.major = element_line(
        colour = ifelse(hasArg(panel.grid.color), panel.grid.color, pomological_base$light_line),
        linetype = panel.grid.linetype),
      panel.grid.minor = element_blank(),
      axis.text = element_text(
        colour = ifelse(hasArg(axis.text.color), axis.text.color, pomological_base$medium_line), 
        size = axis.text.size)
    )
}

pomological_theme_nobg <- function(...) {
  dots <- list(...)
  dots$plot.background.color <- 'transparent'
  do.call('pomological_theme', args = dots)
}

Here are the color scales you’ll need: scale_color_pomological and scale_fill_pomological.

# learned this from https://github.com/hrbrmstr/hrbrthemes/blob/13f9b59579f007b8a5cbe5c699cbe3ec5fdd28a1/R/color.r
pomological_pal <- function() scales::manual_pal(pomological_palette)

# Scale color
scale_colour_pomological <- function(...) ggplot2::discrete_scale("colour", "pomological", pomological_pal(), ...)
scale_color_pomological <- scale_colour_pomological

# Scale fill
scale_fill_pomological <- function(...) ggplot2::discrete_scale('fill', 'pomological', pomological_pal(), ...)

In the future, I might come back to this to

1. Increase colors in discrete scale

2. Setup a color-pairs plot. Lots of great color pairs in the extracted colors.

3. Set up continuous scale colors (we’ll see…)

Add paper background!

Great, but I want my plots to look even more pomological, you say?

Perfect! This function uses the magick package to add a pomological watercolor paper background and a subtle texture overlay.

paint_pomological <- function(
  pomo_gg, 
  width = 800, 
  height = 500, 
  pointsize = 16, 
  pomological_background = 'pomological_bg.png', 
  pomological_overlay = "pomological_overlay.jpg",
  outfile = NULL,
  ...
) {
  requireNamespace('magick', quietly = TRUE)
  requireNamespace('glue', quietly = TRUE)
  if (!file.exists(pomological_background)) {
    warning(glue::glue("Cannot find file \"{pomological_background}\", so you can have your plot back!"))
    return(pomo_gg)
  }
  
  # Paint figure
  gg_fig <- magick::image_graph(width, height, bg = 'transparent', pointsize = pointsize, ...)
  print(pomo_gg)
  dev.off()
  
  if (!is.null(pomological_overlay) && file.exists(pomological_overlay)) {
    pomo_over <- magick::image_read(pomological_overlay)
    pomo_over <- magick::image_resize(pomo_over, glue::glue("{width}x{height}!"))
    gg_fig <- magick::image_composite(gg_fig, pomo_over, "blend", compose_args = "15")
  }
  
  # Paint background
  pomo_bg <- magick::image_read(pomological_background)
  pomo_bg <- magick::image_resize(pomo_bg, glue::glue("{width}x{height}!"))
  pomo_bg <- magick::image_crop(pomo_bg, glue::glue("{width}x{height}"))
  
  # Paint figure onto background
  pomo_img <- magick::image_composite(pomo_bg, gg_fig)
  if (!is.null(outfile)) {
    # Do you want your picture framed?
    magick::image_write(pomo_img, outfile)
  }
  pomo_img
}

Demo!

We’ll need dplyr and ggplot2

library(dplyr)

## 
## 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

library(ggplot2)

Basic iris plot

# Base plot
basic_iris_plot <- ggplot(iris) +
  aes(x = Sepal.Length, y = Sepal.Width, color = Species) +
  geom_point(size = 2)

# Just your standard Iris plot
basic_iris_plot 

# With pomological theme
basic_iris_plot +
  pomological_theme() +
  scale_color_pomological()

# With transparent background
pomological_iris <- basic_iris_plot +
  pomological_theme_nobg() +
  scale_color_pomological()
pomological_iris 

# Painted!
paint_pomological(pomological_iris, res = 110) %>% 
  magick::image_write("Readme_files/figure-gfm/plot-demo-painted.png")

Stacked bar chart

stacked_bar_plot <- ggplot(diamonds) +
  aes(price, fill = cut) +
  geom_histogram(binwidth = 850) + 
  xlab('Price (USD)') + 
  ylab('Count') + 
  scale_x_continuous(label = scales::dollar_format()) +
  scale_fill_pomological()

stacked_bar_plot + pomological_theme()

paint_pomological(
  stacked_bar_plot + pomological_theme_nobg(),
  res = 110
) %>% 
  magick::image_write("Readme_files/figure-gfm/plot-bar-chart-painted.png")

Density Plot

density_plot <- mtcars %>% 
  mutate(cyl = factor(cyl)) %>% 
  ggplot() +
  aes(mpg, fill = cyl, color = cyl)+
  geom_density(alpha = 0.75) + 
  labs(fill = 'Cylinders', colour = 'Cylinders', x = 'MPG', y = 'Density') +
  scale_color_pomological() +
  scale_fill_pomological()

density_plot + pomological_theme()

paint_pomological(
  density_plot + pomological_theme_nobg(),
  res = 110
) %>% 
  magick::image_write("Readme_files/figure-gfm/plot-density-demo-painted.png")

Points and lines

Data from the Texas Housing

big_volume_cities <- txhousing %>% 
  group_by(city) %>% 
  summarize(mean_volume = mean(volume, na.rm = TRUE)) %>% 
  arrange(-mean_volume) %>% 
  top_n(length(pomological_palette)) %>% 
  pull(city)

## Selecting by mean_volume

full_bar_stack_plot <- txhousing %>% 
  filter(city %in% big_volume_cities) %>% 
  group_by(city, year) %>% 
  summarize(mean_volume = mean(volume, na.rm = TRUE)) %>% 
  ungroup %>% 
  mutate(city = factor(city, big_volume_cities)) %>% 
  ggplot() +
  aes(year, mean_volume, fill = city, group = city) +
  geom_col(position = 'fill', width = 0.9) +
  labs(x = 'City', y = 'Mean Volume', color = 'City') +
  theme(panel.grid.minor.x = element_blank()) +
  scale_fill_pomological()

full_bar_stack_plot + pomological_theme()

paint_pomological(
  full_bar_stack_plot + pomological_theme_nobg(),
  res = 110
) %>% 
  magick::image_write("Readme_files/figure-gfm/plot-full-bar-stack-painted.png")

One last plot

(in my handwriting)

ridges_pomological <- ggplot(diamonds) + 
  aes(x = carat, y = clarity, color = clarity, fill = clarity) + 
  ggridges::geom_density_ridges(alpha = 0.75) + 
  pomological_theme_nobg(
    base_family = 'gWriting',
    base_size = 20,
    base_theme = ggridges::theme_ridges()
    ) + 
  scale_fill_pomological() + 
  scale_color_pomological()

paint_pomological(ridges_pomological, res = 110) %>% 
  magick::image_write("Readme_files/figure-gfm/plot-ridges-painted.png")

## Picking joint bandwidth of 0.057

Appendix

Some functions I wrote while exploring colors, that may or may not work here.

# load all colors
x <- readLines("pomological.css")
x <- stringr::str_extract(x, "#[0-9a-f]{6}")
x <- x[!is.na(x)]

gg_color_hue <- function(n) {
  hues = seq(15, 375, length = n + 1)
  hcl(h = hues, l = 65, c = 100)[1:n]
}

col2hsv <- function(x) rgb2hsv(col2rgb(x))


dist2ref_color <- function(color, ref_color) {
  stopifnot(length(ref_color) == 1)
  x <- col2hsv(c(color, ref_color)) %>% 
    t %>%
    dist %>%
    as.matrix %>%
    {tibble('ref_color' = .[length(color) + 1, 1:length(color)])}
  names(x) <- ref_color
  x
}

compare_to_ggplot <- function(compare_to_ggplot) {
  pomo_gg <- map_dfr(set_names(compare_to_ggplot), ~ as_tibble(t(col2hsv(.))), .id = "color") %>% 
    bind_cols(
      map_dfc(gg_color_hue(set_names(length(compare_to_ggplot))), ~ dist2ref_color(compare_to_ggplot, .))
    ) %>% 
    tidyr::gather('ggplot_color', 'dist', -color:-v) %>% 
    # group_by(color) %>% 
    # do(dist = min(.$dist), ggplot_color = filter(., dist == min(.$dist))$ggplot_color) %>% 
    # mutate(dist = map_dbl(dist, ~ .), ggplot_color = map_chr(ggplot_color, ~ .)) %>% 
    # ungroup %>% 
    mutate(ggplot_color = factor(ggplot_color, gg_color_hue(length(compare_to_ggplot)))) %>% 
    arrange(ggplot_color)
  warning(glue::glue("Palette has {length(compare_to_ggplot)} colors"), call. = FALSE)
  ggplot(pomo_gg) +
    aes(x = ggplot_color, y = dist, fill = color, label = color) +
    geom_label(color = 'white')+
    # geom_point(shape = 15, size = 5) +
    scale_fill_identity()
}

data_frame(
  'color' = color_options,
  # 'group' = sample(c('pomo', 'logical'), length(color_options), replace = TRUE),
  'x' = pmap_chr(tidyr::crossing(letters, letters), ~paste0(..1, ..2))[1:length(color_options)],
  'y' = 1:length(color_options)
) %>% 
  ggplot() +
  aes(x, y, fill = color) +
  # geom_point(size = 8)+
  geom_col()+
  geom_text(aes(label = color), hjust = -0.1) +
  scale_fill_identity() +
  coord_flip() +
  theme_minimal() +
  #theme_xkcd() +
  theme(
    text = element_text(family = 'gWriting', size = 16),
    plot.background = element_rect(fill = base_colors["paper_light"], color = NA),
    panel.grid = element_line(color = "#efe1c6"),
    axis.text = element_text(color = "#655843", size = 14)
  )

ordered_plot <- function(color_options, dichromat = FALSE) {
  if (dichromat) {
    dichr_type <- sample(c("deutan", "protan", "tritan"), 1)
    message(glue::glue("color blindness: {dichr_type}"))
    color_options <- dichromat::dichromat(color_options, dichr_type)
  }
  data_frame(
    color = color_options,
    x = 1,
    y = 1:length(color_options)
  ) %>% 
    ggplot() +
    aes(x, y, fill = color, label = color) +
    geom_tile() +
    geom_label(color = 'white') +
    scale_fill_identity()+
    scale_y_continuous(breaks = 1:length(color_options), labels = 1:length(color_options))+
    theme_minimal()
}