Make a table, but also make it a Hall of AP-LS Presidents

Efforts towards creating a presidential archive table for the new AP-LS website in a way that makes updating it easy.

Using ideas from the hard work of other people on the interweb to streamline the process of creating a visually appealing “Hall of Presidents” for the new ap-ls.org.

Setup

library(janitor)
library(here)
library(tidyverse)
library(gt)
library(stringr)
library(purrr)
library(htmltools)
library(gtExtras)
library(magick)
library(image.libfacedetection)
library(geomtextpath)
library(ggimage)
library(cropcircles)
library(glue)
library(fs)

Load Data

pres <- readr::read_csv("pres_data.csv")

Creating Profile Pictures

Using modified functions from this blog post I was able to automate the process of centering profile pictures with R using the image.libfacedetection package.

Given that the images I was able to track down of past presidents are from various sources and time-periods, this was a necessary step.

Helper Functions

First, we need a function to find the center of a face in an image:

find_face_center <- function(image) {
  detections <- image.libfacedetection::image_detect_faces(image)$detections
  best_face <- which(detections$confidence == max(detections$confidence))
  dims <- as.list(detections[best_face[[1]], ])
  list(
    x = dims$x + dims$width / 2,
    y = dims$y + dims$height / 2
  )
}

Next, a function to resize images proportionately:

resize_fit <- function(image, size = 600) {
  info <- image_info(image)
  size <- min(size, info$width, info$height)
  image_resize(
    image,
    geometry_size_pixels(
      height = if (info$width >= info$height) size,
      width = if (info$height > info$width) size
    )
  )
}

A function to calculate crop offsets:

crop_offset <- function(point, range, width) {
  if (width >= range) return(0)
  if ((point - width / 2) < 0) {
    return(0)
  }
  if ((point + width / 2) > range) {
    return(range - width)
  }
  point - width / 2
}

Finally, the main function that crops and centers based on face detection. All credit to Garrick Aden-Buie:

resize_crop_to_face <- function(image, size = 600) {
  image <- resize_fit(image, size)
  info <- image_info(image)
  size <- min(info$height, info$width)
  is_image_square <- info$width == info$height
  if (is_image_square) {
    return(image)
  }
  face <- find_face_center(image)
  image_crop(
    image,
    geometry = geometry_area(
      width = size,
      height = size,
      x_off = crop_offset(face$x, info$width, size),
      y_off = crop_offset(face$y, info$height, size)
    )
  )
}

Process All Profile Images

# Read in images
profiles <-
  fs::dir_ls("profiles") |>
  map(image_read) |>
  map(resize_crop_to_face)

# Write images back in cropped format
fs::dir_create("profiles_cropped")
profiles |>
  iwalk(function(image, path) {
    new_path <- fs::path("profiles_cropped", fs::path_file(path))
    image_write(image, new_path)
  })

Adding Curved Text Labels to Images

I created functions to add curved text labels around circular profile images using geomtextpath:

Single Label (Top or Bottom)

plot_image_label <- function(image,
                             label,
                             font_color = "black", 
                             position = "top",
                             hjust = 0.2) {
  
  # Crop the image into a circle shape
  cropped_image <- cropcircles::circle_crop(image)
  
  t <- seq(0, 1, length.out = 100) * pi
  
  # Set up params based on top or bottom
  if (position == "top") {
    data <- data.frame(x = cos(t), y = sin(t))
    vjust <- 1.1
    ymax <- 1.2
    ymin <- -0.9
  } else if (position == "bottom") {
    data <- data.frame(x = cos(t), y = sin(t) * -1)
    vjust <- -0.1
    ymax <- 0.9
    ymin <- -1.2
  }
  
  # Plot
  ggplot() +
    geom_image(aes(x = 0, y = 0, image = cropped_image), asp = 2.4/2.1, size = 0.7) +
    scale_x_continuous(limits = c(-1.2, 1.2)) +
    scale_y_continuous(limits = c(ymin, ymax)) +
    geom_textpath(
      data = data, 
      aes(x, y, label = label), 
      linecolor = NA, 
      color = font_color,
      size = 14.5,
      fontface = "bold", 
      vjust = vjust, 
      hjust = hjust
    ) +
    coord_equal() +
    theme_void()
}

Both Labels (Top and Bottom)

plot_both_labels <- function(image,
                             top_label,
                             bottom_label,
                             font_color = "black", 
                             hjust = 0.5) {
  
  # Crop the image into a circle shape
  cropped_image <- cropcircles::circle_crop(image)
  
  t <- seq(0, 1, length.out = 100) * pi
  
  # Set up params for top label
  top_data <- data.frame(x = cos(t), y = sin(t))
  top_vjust <- 1.4
  
  # Set up params for bottom label
  bottom_data <- data.frame(x = cos(t), y = sin(t) * -1)
  bottom_vjust <- -0.4
  
  # Plot
  ggplot() +
    geom_image(aes(x = 0, y = 0, image = cropped_image), asp = 2.4/2.1, size = 0.7) +
    scale_x_continuous(limits = c(-1.2, 1.2)) +
    scale_y_continuous(limits = c(-1.2, 1.2)) +
    geom_textpath(
      data = top_data, 
      aes(x, y, label = top_label), 
      linecolor = NA, 
      color = font_color,
      size = 14.5,
      fontface = "bold", 
      vjust = top_vjust, 
      hjust = hjust
    ) +
    geom_textpath(
      data = bottom_data, 
      aes(x, y, label = bottom_label), 
      linecolor = NA, 
      color = font_color,
      size = 14.5,
      fontface = "bold", 
      vjust = bottom_vjust, 
      hjust = hjust
    ) +
    coord_equal() +
    theme_void()
}

Example Usage

Here’s how to use the plot_image_label() function for a single label:

image_url <- "https://emmarshall.github.io/runza/img/apls-presidents/eve_brank.jpg"
plot_image_label(image = image_url, label = "Eve Brank")

And here’s plot_both_labels() for name and year:

image_url <- "https://emmarshall.github.io/runza/img/apls-presidents/eve_brank.jpg"
p <- plot_both_labels(
  image = image_url, 
  top_label = "Eve Brank", 
  bottom_label = "2017-2018"
)

# Save the plot
ggsave("plots/eve_brank_example.png", p, width = 6, height = 6, dpi = 300, bg = "white")

Example: Profile with curved text labels

Make President’s Table

Using gt and gtExtras to create a polished table of AP-LS presidents:

library(readxl)
library(webshot2)

base_path <- here::here("about", "presidents")
div41 <- read_excel(here(base_path, "pres_data.xlsx"), sheet = "div41_data")

tbl <- div41 |> 
  select(name, date) |> 
  gt() |> 
  gt_merge_stack(
    col1 = name, 
    col2 = date, 
    palette = c("#343A40", "#737475"),
    font_size = c("16px", "11px")
  ) |> 
  cols_width(name ~ px(500)) |> 
  tab_header(
    title = html("APLS Presidents Prior to Merger with APA Division 41<br><span style='color:#1B3264;'>(1969-1983)</span>"),
    subtitle = html("The American Psychology-Law Society (APLS) operated independently from 1969-1983.<br>APA Division 41 was established in 1981, and APLS merged with it in 1984.")
  ) |> 
  opt_align_table_header(align = "left") |>
  opt_vertical_padding(scale = 0.5) |> 
  tab_style(
    style = list(
      cell_text(
        size = "18px",
        color = "#343A40",
        weight = "bold"
      )
    ),
    locations = list(
      cells_title(groups = "title")
    )
  ) |>
  tab_style(
    style = list(
      cell_text(
        size = "11px",
        color = "#737475",
        weight = "normal",
        style = "italic"
      )
    ),
    locations = list(
      cells_title(groups = "subtitle")
    )
  ) |>
  cols_label(name = "")

tbl |> 
  gtsave(here(base_path, "tbl_1.html"))

Final Table

Back to top