Simulation of "Surpised by the Hot Hand Fallacy" Econometrica

simulation-hot_hand_ecta.R

library(tidyverse)

# %% 
simulation <- function(n, p, k) {
  trials = purrr::map_dbl(1:100000, function(b) {
    # Take 100 shots and record if basket is made
    shots = as.numeric(runif(n) < p)

    # Observe streaks
    hot_hand_shot_results = c()
    streak_count = 0
    for (i in 1:n) {
      # if streak is at least k, then mark this shot
      if (streak_count >= k) {
        hot_hand_shot_results = c(hot_hand_shot_results, shots[i])
      }

      # update count
      streak_count = ifelse(shots[i] == 1, streak_count + 1, 0) 
    }
    
    # Proportion of "hot-hand shots" made
    if (length(hot_hand_shot_results) > 0) {
      mean(hot_hand_shot_results)
    } else {
      NA
    }
  })

  # Filter out trials where the streak was never hit
  trials = trials[!is.na(trials)]
  avg_pct_hot_hand_shots_made = mean(trials)
}

# %% 
simulations = expand_grid(
  # probability of making a basket
  p = c(0.25, 0.5, 0.75), 
  # number of shots recorded
  n = 1:100,
  # number of shots made in a row before testing for hot hand
  k = 1:4,
) |> 
  # need n >= k + 1 shots to record anything
  filter(n >= k + 1) |>
  mutate(simulation_id = cur_group_id(), .by = c("p", "k")) |>
  mutate(color_label = paste0("k = ", k))
  
# Run simulation for each (n, p, k)
simulations = simulations |>
  rowwise() |>
  mutate(
    avg_pct_hot_hand_shots_made = simulation(n, p, k)
  )


# %% 
(p = ggplot(simulations) +
  geom_line(
    aes(
      x = n, y = avg_pct_hot_hand_shots_made, 
      group = simulation_id, color = color_label
    ), 
    size = 1.12
  ) + 
  geom_hline(yintercept = c(0.25, 0.5, 0.75)) + 
  scale_y_continuous(
    breaks = c(0.25, 0.5, 0.75), 
    labels = scales::label_percent(suffix = "\\%")
  ) +
  scale_color_manual(
    values = c("#d1d5db", "#9ca3af", "#6b7280", "#4b5563")
  ) + 
  labs(
    x = "Number of shots recorded per trial",
    y = "Average \\% of hot hand shots made",
    color = NULL
  ) + 
  kfbmisc::theme_kyle(base_size = 13) + 
  theme(
    legend.position = "bottom", 
    legend.key.spacing.x = unit(8, "mm")
  ))

library(tidyverse)

simulation <- function(n, p, k) {
  trials = purrr::map_dbl(1:250000, function(b) {
    # Take 100 shots and record if basket is made
    shots = as.numeric(runif(n) < p)

    # Observe streaks
    hot_hand_shot_results = c()
    streak_count = 0
    for (i in 1:n) {
      # if streak is at least k, then mark this shot
      if (streak_count >= k) {
        hot_hand_shot_results = c(hot_hand_shot_results, shots[i])
      }

      # update count
      streak_count = ifelse(shots[i] == 1, streak_count + 1, 0) 
    }
    
    # Proportion of "hot-hand shots" made
    if (length(hot_hand_shot_results) > 0) {
      mean(hot_hand_shot_results)
    } else {
      NA
    }
  })

  # Filter out trials where the streak was never hit
  trials = trials[!is.na(trials)]
  avg_pct_hot_hand_shots_made = mean(trials)
}

simulations = expand_grid(
  # probability of making a basket
  p = c(0.25, 0.5, 0.75), 
  # number of shots recorded
  n = 1:100,
  # number of shots made in a row before testing for hot hand
  k = 1:4,
) |> 
  # need n >= k + 1 shots to record anything
  filter(n >= k + 1) |>
  mutate(simulation_id = cur_group_id(), .by = c("p", "k")) |>
  mutate(color_label = paste0("k = ", k))
  
# Run simulation for each (n, p, k)
simulations = simulations |>
  rowwise() |>
  mutate(
    avg_pct_hot_hand_shots_made = simulation(n, p, k)
  )

(p = ggplot(simulations) +
  geom_line(
    aes(
      x = n, y = avg_pct_hot_hand_shots_made, 
      group = simulation_id, color = color_label
    ), 
    size = 1.12
  ) + 
  geom_hline(yintercept = c(0.25, 0.5, 0.75)) + 
  scale_y_continuous(
    breaks = c(0.25, 0.5, 0.75), 
    labels = scales::label_percent(suffix = "\\%")
  ) +
  scale_color_manual(
    values = c("#d1d5db", "#9ca3af", "#6b7280", "#4b5563")
  ) + 
  labs(
    x = "Number of shots recorded per trial",
    y = "Average \\% of hot hand shots made",
    color = NULL
  ) + 
  kfbmisc::theme_kyle(base_size = 13) + 
  theme(
    legend.position = "bottom", 
    legend.key.spacing.x = unit(8, "mm")
  ))
#> Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
#> ℹ Please use `linewidth` instead.
#> This warning is displayed once every 8 hours.
#> Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
#> generated.

kfbmisc::tikzsave(
  "hot_hand_ecta_example.pdf",
  p, width = 9, height = 5,
  create_png = TRUE
)

^{Created on 2024-03-19 with reprex v2.1.0}