collider_bias.R

library(tidyverse)

set.seed(1)

df <- tibble(x=rnorm(2000),
             y=rnorm(2000)) %>%
  mutate(flag = x+y > 1.5)

df %>%
  ggplot() +
  aes(x=x, y=y) +
  geom_point() +
  theme_minimal() +
  coord_equal() +
  labs(title="Consider a population where beauty and talent are uncorrelated.",
       x="Beauty",
       y="Talent")

ggsave("1.pdf", width=8, height=5, dpi=500, units = "in")

df %>%
  ggplot() +
  aes(x=x, y=y) +
  geom_point() +
  geom_smooth(method="lm") +
  theme_minimal() +
  coord_equal() +
  labs(title="Consider a population where beauty and talent are uncorrelated.\nWe see that the regression line is flat.",
       x="Beauty",
       y="Talent")

ggsave("2.pdf", width=8, height=5, dpi=500, units = "in")

df %>%
  ggplot() +
  aes(x=x, y=y) +
  geom_point() +
  geom_abline(mapping=aes(intercept=1.5, slope=-1), linetype=2, color="grey", size=1) +
  theme_minimal() +
  coord_equal() +
  labs(title="Now consider that someone is famous if their talent + beauty exceeds a certain threshold.",
       x="Beauty",
       y="Talent")

ggsave("3.pdf", width=8, height=5, dpi=500, units = "in")

df %>%
  ggplot() +
  aes(x=x, y=y) +
  geom_point() +
  geom_abline(mapping=aes(intercept=1.5, slope=-1), linetype=2, color="grey", size=1) +
  geom_point(mapping=aes(x=x, y=y), data=df %>% filter(flag==TRUE), color="red") +
  theme_minimal() +
  coord_equal() +
  labs(title="Now consider that someone is famous if their talent + beauty exceeds a certain threshold.\nThose colored in red are famous, according to this criterion.",
       x="Beauty",
       y="Talent")

ggsave("4.pdf", width=8, height=5, dpi=500, units = "in")

df %>%
  ggplot() +
  aes(x=x, y=y) +
  geom_point() +
  geom_point(mapping=aes(x=x, y=y), data=df %>% filter(flag==TRUE), color="red") +
  geom_smooth(mapping=aes(x=x, y=y), data=df %>% filter(flag==TRUE), method="lm") +
  theme_minimal() +
  coord_equal() +
  labs(title="Conditioning on being famous, there is now a negative correlation between talent and beauty, \neven though there was no such correlation in the original population.",
       x="Beauty",
       y="Talent")

ggsave("5.pdf", width=8, height=5, dpi=500, units = "in")