20  New Tool

I’m going to cheat a little here and use a tool that is probably new to you, but not to me: webmorphR. This is the R companion to webmorph.org, a website I developed to morph and transform faces. It uses the open-source Java libraries from psychomorph, but with an enhanced interface for delineating faces and batch-processing. The R package adds reproducible scripting. There are several vignettes describing the package.

Setup
# remotes::install_github("debruine/webmorphR")
# remotes::install_github("debruine/stimsets")
library(webmorphR)

wm_opts(plot.maxwidth = 850)

Some doofus on Twitter was arguing that they know who is “really” male and female from “bone structure” 100% of the time within milliseconds, and misinterpreted colleagues’ research (and even some of my own) in support of this nonsense. So I’m going to make a quick test to see if you can guess the gender of 15 random faces (we don’t know the cis/trans status of the face models, who I assume have the same probability of being cis or trans as your average Londoner) if you only have info from face shape and internal features (except eyebrows).

20.1 London Faces

There are 102 images in the CC-BY licensed Face Research Lab London Set. You’ll have to install the stimsets package from github first. Load them and resize so they’ll be faster to process for this demo.

Code
# remotes::install_github("debruine/stimsets")

london <- demo_stim("london") %>%
  resize(0.5)

plot(london, nrow = 6)

20.2 Add info

The stimsets package also has a table of info about the images.

Code
head(stimsets::london_info)
face_id face_age face_gender face_eth
001 24 female white
002 24 female white
003 38 female white
004 30 male white
005 28 male east_asian
006 31 female west_asian

Add this to the stimuli. You can use it to subset the images using the subset() function.

Code
london <- london %>%
  add_info(stimsets::london_info)

20.2.1 Reduce Templates

The faces come already delineated (you can add delineations to your own images at webmorph.org, by using the auto_delin() function, or with the yet-to-be-documented quick_delin() function). You can use the delineations to morph and transform the faces, but here we’re going to visualise face shape.

This is the full delineation.

Code
london[42] %>% draw_tem()

And this is a reduced delineation with just the face shape and main features. The crop_tem() function crops the image to just outside the template limits.

Code
london[42] %>% 
  subset_tem(features(c("face", "eyes", "nose", "mouth"))) %>%
  draw_tem() %>%
  crop_tem()

Sample 15 random images, reduce the templates, procrustes align them so they’re all the same approximate size, and crop them.

Code
set.seed(1)
rand_samp <- sample(1:length(london), 15)

tem <- london[rand_samp] %>%
  subset_tem(features(c("face", "eyes", "nose", "mouth"))) %>%
  align(procrustes = TRUE) %>%
  crop_tem()

20.2.2 Draw Templates

I’ll first draw on the template with a neutral purple colour and label them all with numbers. Before you scroll on, can you guess which are male and which are female?

Code
neutral <- tem %>%
  draw_tem(pt.alpha = 0,
           line.color = "purple",
           line.alpha = 1,
           bg = "white") %>%
  label(text = 1:102)

plot(neutral, nrow = 3)

What percent did you get right?

Code
color <- ifelse(
  get_info(tem)$face_gender == "female",
  "hotpink", "dodgerblue")

gendered <- tem %>%
  draw_tem(pt.alpha = 0,
           line.color = color, 
           line.alpha = 1,
           bg = "white") %>%
  label(text = 1:102)

plot(gendered, nrow = 3)

20.3 Save images

Code
plot(neutral) %>%
 write_stim(dir = "images", names = "wm-neutral")

plot(gendered) %>%
 write_stim(dir = "images", names = "wm-gendered")

20.4 Gender differences

So what is the difference between the average male and female face shape? The demo_stim() function gives you female and male composite (average) faces from the London set.

Code
demo_stim() %>% plot()

It’s a little more complicated that I expected to superimpose the templates, but I got there in the end (and this will probably prompt some new functions.)

Code
composites <- demo_stim() %>%
  resize(3) %>%
  subset_tem(features(c("face", "eyes", "nose", "mouth"))) %>%
  align(procrustes = TRUE) %>%
  crop_tem() %>%
  draw_tem(pt.alpha = 0, 
           line.color = c("hotpink", "dodgerblue"),
           line.alpha = 1,
           bg = "#FFFFFF")

plot(composites)

The continuum() function is like seq() for faces. It uses webmorph.org transforming to make a continuum from one face to another.

Code
continuum <- continuum(
  from_img = composites$f_multi,
  to_img = composites$m_multi,
  from = 0,
  to = 1,
  by = 0.1
)

plot(continuum, nrow = 1)

Code
animation <- animate(continuum, fps = 10, rev = TRUE)
write_stim(animation, dir = "images", name = "day20", format = "gif")

knitr::include_graphics("images/day20.gif")