What is collider bias?

In causal inference, the relationships between a network of events are represented in causal diagrams. In the causal diagram below, event A causes event B which causes event C. Here the term “event” refers to a random variable.

The direction in which arrows point into the events (forming a junction) have major implications as to how the model behaves. One junction in particular, which is the focus of this article, is called a collider. This is shown in the causal diagram below.

A collider occurs when an event is independently caused by two other events. In the example, event C is caused by events A and B.

Now, there is no causal relationship between A and B (since there are no arrows between the two). However, if the model were conditioned on C, a correlation between A and B would be induced that does not exist in the unconditional distribution. This is known as collider bias.

A basic example that the book gives is to repeatedly flip two fair coins simultaneously but only keep samples where at least one of the coins shows heads. Let’s do 10,000 flips and tabulate the results:

# Load some packages
require(tidyverse)

# Set the seed
set.seed(123)

# Number of coin flips 
n <- 10000

# Generate random binomials
coin1 <- rbinom(n = n, size = 1, p = 0.5)
coin2 <- rbinom(n = n, size = 1, p = 0.5)

# Make a tibble
tibble(
  `Coin 1` = coin1,
  `Coin 2` = coin2
) %>%
  
  # Convert to factors
  mutate_all(
    ~
      .x %>%
      factor() %>%
      fct_recode(
        Heads = "1",
        Tails = "0"
      ) %>%
      fct_relevel(
        "Heads"
      )
  ) %>%
  
  ### Filter to at least one heads
  filter(
    `Coin 1` == "Heads" |
      `Coin 2` == "Heads"
  ) %>%
  
  # Count the rows
  group_by_all() %>%
  summarise(
    N = n(),
    .groups = "drop"
  ) %>%
  
  # Send over columns
  pivot_wider(
    names_from = `Coin 2`,
    values_from = N,
    values_fill = 0
  ) %>%
  
  # Make a kable
  knitr::kable(
    format = "html",
    caption = str_c("Tabulation of ", n, " simulataneously coin flips excluding cases when both were tails.")
  ) %>%
  kableExtra::kable_styling(
    full_width = FALSE
  ) %>%
  kableExtra::add_header_above(
    c("", "Coin 2" = 2)
  )

Now the question: Is the probability of a heads for one coin the same regardless of what the other coin shows? From our data,

\[P(\text{Coin 1 = Heads | Coin 2 = Heads}) = \frac{2403}{2403 + 2499} \approx 0.49\]

\[P(\text{Coin 1 = Heads | Coin 2 = Tails}) = \frac{2540}{2540 + 0} = 1\]

These results suggest that the coins are not independent. When coin 2 is heads, coin 1 is fair. When coin 2 is tails, coin 1 is certain to be heads. However, we flipped the coins independently so we know there is not a relationship between them. This is an example of collider bias. Here is the causal diagram for this model:

The decision to keep the result depends on the values of both coins. Once we condition on the trials that we kept, a correlation is induced.

Example: selecting patients for a trial

Let’s go through a more practical example. Note this is completely made up.

print(patients, n = 5)

## # A tibble: 1,000 × 2
##   S          N    
##   <fct>      <fct>
## 1 Non-severe Near 
## 2 Severe     Far  
## 3 Severe     Near 
## 4 Non-severe Near 
## 5 Non-severe Near 
## # … with 995 more rows

patients %>%
  
  # Count the rows
  group_by(N, S) %>%
  summarise(
    Count = n(),
    .groups = "drop"
  ) %>%
  
  # Send over the columns
  pivot_wider(
    names_from = N,
    values_from = Count
  ) %>%
  
  # Rename
  rename(
    `Disease severity` = S
  ) %>%
  
  # Make a kable
  knitr::kable(
    format = "html",
    caption = "Tabulation of disease severity and distance from trial center for 1000 sampled patients"
  ) %>%
  kableExtra::kable_styling(
    full_width = FALSE
  ) %>%
  kableExtra::add_header_above(c("", "Distance from trial center" = 2))

prop.test(sum(patients$S == "Severe" & patients$N == "Far"), sum(patients$N == "Far"), p = 0.25)$p.value

## [1] 1.321956e-23

Conclusion

Collider bias is a very interesting and important concept to consider when conducting a statistical analysis. In the examples throughout this article, we had the luxury of knowing the true probabilities of various events so we could easily identify and reconcile problems in the estimates. In practice, these are generally unknown quantities which makes this problem much more subtle and unapparent when relying solely on the data. Thus illustrating the importance of incorporating prior knowledge and subject-matter expertise into the modeling process.

Code appendix

##################### Code snippets

###### Figure 1
DiagrammeR::grViz("
  digraph graph2 {
  
  graph [layout = dot, rankdir = LR]
  
  node [shape = oval]
  a [label = 'A']
  c [label = 'C']
  b [label = 'B']
  
  a -> b -> c
  }
  ", height = 100, width = 250)

###### Figure 2
DiagrammeR::grViz("
  digraph graph2 {
  
  graph [layout = dot, rankdir = LR]
  
  node [shape = oval]
  a [label = 'A']
  c [label = 'C']
  b [label = 'B']
  
  a -> c
  b -> c
  }
  ", height = 100, width = 250)

###### Figure 3
DiagrammeR::grViz("
  digraph graph2 {
  
  graph [layout = dot, rankdir = LR]
  
  node [shape = oval]
  a [label = 'Coin 1']
  c [label = 'Keep trial result']
  b [label = 'Coin 2']
  
  a -> c
  b -> c
  }
  ", height = 100, width = 250)

##### Build trial data set
# Set a seed
set.seed(321)

# Base sample size
base_size <- 100000

# Enrollment size
n <- 1000

# Make a data frame
patients <-
  tibble(
    S = rbinom(base_size, 1, .25), # Disease severity
    N = rbinom(base_size, 1, .65), # Distance from center
  ) %>%
  
  # Add enrollment flag based on
  mutate(
    E = 
      # Determine enrollment probability
      case_when(
        N == 1 ~ 0.85,
        S == 1 ~ 0.50,
        TRUE ~ 0.10
      ) %>%
      
      # Sample based on probability
      rbinom(
        n = base_size,
        size = 1
      )
  ) %>%
  
  # Filter to enrolled patients
  filter(
    E == 1
  ) %>%
  
  # Sample the desired enrollment
  slice_sample(
    n = n
  ) %>%
  
  # Convert to factors
  mutate(
    S = 
      S %>%
      factor() %>%
      fct_recode(
        Severe = "1",
        `Non-severe` = "0"
      ) %>%
      fct_relevel("Severe"),
    N = 
      N %>%
      factor() %>%
      fct_recode(
        `<20 miles` = "1",
        `>20 miles` = "0"
      ) %>%
      fct_relevel("<20 miles")
  ) %>%
  
  # Remove the enrollment indicator
  select(
    -E
  )

#### Figure 3
DiagrammeR::grViz("
  digraph graph2 {
  
  graph [layout = dot, rankdir = LR]
  
  node [shape = oval]
  a [label = 'Distance from center']
  c [label = 'Decision to join trial']
  b [label = 'Disease severity']
  
  a -> c
  b -> c
  }
  ", height = 100, width = 250)