Today’s Red Card Is Too Harsh on the Team, and Arbitrary

1,140 matches of StatsBomb data show a sanction that halves a team’s attack, never ends, and is priced by the clock. A 20-minute power play fixes it.

football
StatsBomb
red cards
rules
Author

Juan Franceschini

Published

October 10, 2026

Executive summary

Today’s red card is too harsh on the offending team. It strips the team of half its attack, keeps doing so until the final whistle, and charges a price set by the clock rather than the foul.

  1. It halves the team’s attack and hands the match to the opponent. In the 20 minutes after a red card, the ten-man side creates about half the chances of matched 11-v-11 games, and its share of the match’s chances falls from 44% to 27%.
  2. The punishment never ends. After 40 minutes a ten-man side is as outgunned as after ten, while the opponent’s advantage keeps growing.
  3. The price is set by the clock, not the foul. A red card costs the team 0.34 points per game on average: 0.91 points before half-time, 0.06 after the 75th minute.

Where we go from here: keep the sending-off and the ban for the player, and replace the team’s open-ended penalty with a 20-minute power play. The team is still punished, at about 0.21 points, but the punishment is limited, not perpetual.

The thesis: a red card punishes the team far more than the offence deserves

A red card is meant to punish a player for a serious offence. In practice the heavier punishment falls on his team: ten players who did nothing wrong play the rest of the match a man short, however long that is. The evidence below, drawn from 292 red cards in 1,140 matches across the 2015/16 Premier League, La Liga and Serie A, shows how large, how lasting and how arbitrary that team penalty is.

A red card halves the team’s attack and hands the match to the opponent

Show the code: chart 1, chances around the red card 
bins <- seq(-20, 15, 5)
tilt <- rbindlist(lapply(c("focal", "opponent"), function(r) rbindlist(lapply(bins, function(b) {
  e <- est(sets, "npxg", r, after = c(b, b + 5))
  data.table(role = r, start = b, mid = b + 2.5, treated = e$treated_after, control = e$control_after)
}))))
tilt[, role_lab := factor(ifelse(role == "focal", "The team down to ten", "Their opponent"), c("The team down to ten", "Their opponent"))]
tilt_long <- melt(tilt, id.vars = c("role", "role_lab", "start", "mid"), variable.name = "group", value.name = "rate")
tilt_long[, colour := fifelse(group == "control", GREY, fifelse(role == "focal", RED, BLUE))]
tilt_long[, tip := sprintf("<b>%s</b><br>%d to %d min from the red<br>%s: %s npxG per 20'", role_lab, start, start + 5,
                           ifelse(group == "control", "Matched 11-v-11 games", "Red-card games"), num(rate))]
p1 <- ggplot(tilt_long, aes(mid, rate, group = group)) +
  annotate("rect", xmin = 0, xmax = 20, ymin = -Inf, ymax = Inf, fill = "#fbeeec") +
  geom_vline(xintercept = 0, colour = RED, linewidth = .6) +
  geom_line(aes(colour = colour, linetype = group), linewidth = 1.1) +
  geom_point_interactive(aes(colour = colour, tooltip = tip, data_id = paste(role, group, start)), size = 2.8) +
  geom_text(data = tilt_long[start == 15], aes(label = ifelse(group == "control", "Twins", "With a red"), colour = colour),
            hjust = 0, nudge_x = .9, size = 3.4, fontface = "bold") +
  annotate("text", x = .6, y = Inf, label = "Red card", hjust = 0, vjust = 1.6, size = 3.3, colour = RED, fontface = "bold") +
  facet_wrap(~ role_lab) + scale_colour_identity() + scale_linetype_manual(values = c(treated = "solid", control = "22")) +
  scale_x_continuous(breaks = seq(-20, 20, 10), labels = function(x) ifelse(x > 0, paste0("+", x), x), expand = expansion(add = c(1, 7))) +
  scale_y_continuous(limits = c(0, NA), expand = expansion(mult = c(0, .12))) +
  labs(title = "The red card flips who is attacking",
       subtitle = sprintf("Non-penalty expected goals (npxG) per 20 minutes around the first red card (%d cases) vs matched 11-v-11 twins", length(sets)),
       x = "Minutes from the red card", y = "npxG per 20 minutes") +
  coord_cartesian(clip = "off") + theme_sb()
sb_chart(p1, 4.8)
Data: StatsBomb Open Data · 2015/16 Premier League, La Liga and Serie A StatsBomb

Before the card, the team that will be reduced to ten creates chances exactly like its matched 11-v-11 twins. In the 20 minutes after it, its non-penalty expected goals fall by 0.13 per 20 minutes [−0.17, −0.09], about half of what it would otherwise create, and the opponent’s rise by 0.10 [+0.05, +0.14]. The ten-man side’s share of the match’s chances drops from 44% to 27%.

So what One player’s offence turns an even contest into one-way traffic. Ten teammates carry the cost, and the opponent collects a reward it did nothing to earn.

The punishment never ends: after 40 minutes the gap is as wide as after ten

Show the code: chart 2, the 40-minute cohort 
per <- rbindlist(lapply(c("focal", "opponent"), function(r) rbindlist(lapply(list(c(0, 20), c(20, 40)), function(w) {
  e <- est(long, "npxg", r, after = w); cbind(role = r, window = sprintf("%d to %d minutes after", w[1], w[2]), e)
}))))
per[, role_lab := factor(c(focal = "Team down to ten", opponent = "Opponent")[role], c("Team down to ten", "Opponent"))]
per[, colour := c(focal = RED, opponent = BLUE)[role]]
per[, tip := sprintf("<b>%s</b>, %s the red<br>%s npxG per 20' vs twins<br>95%% interval %s<br>%d red cards", role_lab, window, signed(estimate), ci(lo, hi), n)]
p2 <- ggplot(per, aes(estimate, window, colour = colour)) +
  geom_vline(xintercept = 0, colour = "#bdbdbd") +
  geom_linerange(aes(xmin = lo, xmax = hi), linewidth = 1.3) +
  geom_point_interactive(aes(tooltip = tip, data_id = paste(role, window)), size = 3.8) +
  geom_text(aes(label = signed(estimate)), vjust = -1.1, size = 3.5, fontface = "bold") +
  facet_wrap(~ role_lab) + scale_colour_identity() + scale_y_discrete(limits = rev) + scale_x_continuous(labels = signed) +
  labs(title = "No recovery: the second 20 minutes are as lopsided as the first",
       subtitle = sprintf("Change in npxG per 20 minutes vs matched 11-v-11 twins, games that stayed 11-v-10 for 40+ minutes (%d cases)", length(long)),
       x = "npxG per 20 minutes vs twins (with 95% interval)", y = NULL) +
  theme_sb() + theme(panel.grid.major.y = element_blank(), panel.grid.major.x = element_line(colour = "#eeeeee"), axis.text.y = element_text(colour = INK))
sb_chart(p2, 3)
Data: StatsBomb Open Data · 2015/16 Premier League, La Liga and Serie A StatsBomb
Show the code: chart 2, the 40-minute cohort 
own_20 <- per[role == "focal" & window == "0 to 20 minutes after", estimate]; own_40 <- per[role == "focal" & window == "20 to 40 minutes after", estimate]
opp_20 <- per[role == "opponent" & window == "0 to 20 minutes after", estimate]; opp_40 <- per[role == "opponent" & window == "20 to 40 minutes after", estimate]

Teams don’t adapt to playing with ten. In the 44 games that stayed 11-v-10 for at least 40 minutes, the ten-man side was 0.14 npxG per 20 minutes behind its twins in the first 20 minutes and 0.16 behind in the next 20. The opponent’s advantage grew, from +0.07 to +0.14.

So what The team penalty has no end point. Every extra minute at ten is another minute of the same handicap, and the opponent’s reward accumulates until the final whistle.

The price of a red card is set by the clock, not by the foul

Show the code: chart 3, points lost by minute of the red card 
by_time[, tip := sprintf("<b>Red card at %s</b><br>Ten-man side: %s points per game<br>Matched twins: %s<br>Cost: %s points, 95%% interval [%s, %s]<br>%d red cards",
                         bucket, num(ten), num(twins), num(cost), num(lo), num(hi), n)]
p3 <- ggplot(by_time, aes(bucket, cost)) +
  geom_hline(yintercept = 0, colour = "#bdbdbd") +
  geom_col_interactive(aes(tooltip = tip, data_id = bucket), fill = RED, width = .62) +
  geom_errorbar(aes(ymin = lo, ymax = hi), width = .12, colour = INK, linewidth = .5) +
  geom_text(aes(y = hi, label = num(cost)), vjust = -.7, fontface = "bold", size = 4, colour = INK) +
  scale_y_continuous(expand = expansion(mult = c(.02, .14))) +
  labs(title = sprintf("The same red card is %d times more expensive early than late", round(ratio)),
       subtitle = sprintf("Points lost per game by the ten-man side vs matched 11-v-11 games, by minute of the red card (%d red cards, 95%% intervals)", nrow(per_card)),
       x = "Minute of the red card", y = "Points lost per game") +
  theme_sb() + theme(axis.text.x = element_text(colour = INK, face = "bold", size = 11))
sb_chart(p3, 3.9)
Data: StatsBomb Open Data · 2015/16 Premier League, La Liga and Serie A StatsBomb

A team reduced to ten before half-time took 0.30 points per game, against 1.21 for matched games that stayed 11-v-11: a cost of 0.91 points. The same card after the 75th minute cost 0.06. Every ten minutes left on the clock adds 0.16 points to the bill.

So what The identical tackle in the 30th and the 80th minute carries a 15-fold difference in punishment. A sanction priced by the clock is arbitrary, and the arbitrariness lands on the team.

How the evidence was built

  • Data. StatsBomb event data for every match of the 2015/16 Premier League, La Liga and Serie A: 1,140 matches, 292 on-field red cards and every shot with its expected-goals value, plus pre-match bookmaker odds from Football-Data.co.uk.
  • Match states. From the raw events I rebuilt the score, the players on the pitch and each team’s chances, second by second, for every match.
  • Matched twins. Each red card is compared with up to five games from the same league that were still 11-v-11 at the same minute of the same half, with the same score difference, the same team at home or away, the same pre-match favourite (win probability within 0.15) and the most similar attacking output by both teams over the previous 20 minutes.
  • Effect. The effect of a red card is the change in the ten-man game minus the change in its twins over the same window, estimated by weighted least squares with standard errors clustered by match.
  • Cohorts. Chance creation: 99 first red cards with 20 clean minutes before and after. Persistence: the 44 of those that stayed 11-v-10 for 40 minutes. Points: all 212 first red cards from the 20th minute on, measured to the final whistle.

The results point the same way in every league, for straight reds and second yellows, with penalty and goalkeeper reds included, and under every alternative specification tested (appendix).

Where do we go from here? A 20-minute power play

The fix is to separate the two punishments. The player is sent off for the rest of the match and banned as he is today. The team serves a fixed 20-minute power play, a man short, then returns to eleven with a substitute.

Show the code: chart 4, the rule today vs the proposal 
seg <- data.table(
  rule = factor(rep(c("Today", "Proposed: 20-minute power play"), each = 3), c("Proposed: 20-minute power play", "Today")),
  from = c(0, 30, 30, 0, 30, 50), to = c(30, 95, 95, 30, 50, 95),
  state = c("11 v 11", "11 v 10", "11 v 10", "11 v 11", "11 v 10", "11 v 11 again"))
seg <- unique(seg)
seg[, fill := c("11 v 11" = "#e6e6e6", "11 v 10" = RED, "11 v 11 again" = "#bfbfbf")[state]]
seg[, tip := sprintf("<b>%s</b><br>Minutes %d to %d: %s", rule, from, to, state)]
p4 <- ggplot(seg) +
  geom_rect_interactive(aes(xmin = from, xmax = to, ymin = as.numeric(rule) - .32, ymax = as.numeric(rule) + .32, fill = fill, tooltip = tip, data_id = paste(rule, from)), colour = "white", linewidth = 1) +
  geom_text(aes(x = (from + to) / 2, y = as.numeric(rule), label = state, colour = ifelse(state == "11 v 10", "white", INK)), fontface = "bold", size = 3.8) +
  geom_vline(xintercept = 30, colour = INK, linetype = "22") +
  annotate("text", x = 30, y = 2.62, label = "Red card in the 30th minute", hjust = 0, nudge_x = .8, size = 3.4, fontface = "bold", colour = INK) +
  annotate("text", x = 72.5, y = .52, label = "Back to 11 · the offender stays off and is banned", hjust = .5, size = 3.2, colour = MUTED) +
  scale_fill_identity() + scale_colour_identity() +
  scale_y_continuous(breaks = 1:2, labels = levels(seg$rule), limits = c(.4, 2.75)) +
  scale_x_continuous(breaks = seq(0, 90, 15), labels = function(x) paste0(x, "'")) +
  labs(title = "A real punishment for the team, with an end point",
       subtitle = "How a 30th-minute red card plays out under today's rule and under a 20-minute power play",
       x = "Match minute", y = NULL) +
  theme_sb() + theme(panel.grid = element_blank(), axis.text.y = element_text(colour = INK, face = "bold", size = 11))
sb_chart(p4, 2.8, note = "Illustration of the proposed rule")
Illustration of the proposed rule StatsBomb

The power play still punishes the team, and meaningfully so. During those 20 minutes the offending side creates 0.13 fewer npxG and the opponent 0.10 more than in matched games. In points, a red card that leaves a team a man down for 20 minutes costs about 0.21 points (95% interval 0.10 to 0.33). The difference is that the punishment is limited, not perpetual, and identical for every foul, whether it happens in the 10th minute or the 80th.

This is how other major team sports already handle their most serious fouls: the offender is removed, the opponent is compensated, and the team’s penalty has an end point.

Sport Most serious foul The player The team The opponent gets
Basketball (NBA) Flagrant 2 foul Ejected, can be suspended Keeps 5 players Two free throws and possession
American football (NFL) Flagrant hit, e.g. on the quarterback Can be ejected and suspended Keeps 11 players A 15-yard penalty and an automatic first down
Ice hockey (NHL) Match penalty Ejected, suspension reviewed One player short for 5 minutes, then back to full strength A 5-minute power play
Rugby union Red card under the 20-minute trial Off for the rest of the match One short for 20 minutes, then a replacement A 20-minute numerical advantage
Football Red card Off for the match, banned for future matches One short until the final whistle An advantage of unlimited length

Ice hockey’s timed power play is the closest model, and rugby union’s 20-minute red card applies the same logic. In basketball and American football the team is never reduced at all; the opponent is compensated with free throws or field position. Football is the only one of these sports where a single foul can decide the remaining hour of a match.

The recommendation Keep the red card for the player. Cap it for the team. A 20-minute power play preserves a real punishment, removes the clock as the judge of how big it is, and brings football in line with the sports that already got this right.

Back to top

Appendix: robustness and code

Show the code: the five-minute gap and every sensitivity check 
donut_sets <- Filter(function(s) s$time >= 1500, lapply(sets, function(s) {
  s$donors <- Filter(function(d) d$time >= 1500, s$donors); if (length(s$donors) >= 3) s else list(time = 0) }))
broad <- match_design(f, broad = TRUE); three <- match_design(f, k = 3); narrow <- match_design(f, caliper = .10)
subset_sets <- function(cond) Filter(cond, sets)
checks <- list(
  "Main analysis" = list(sets, c(0, 20), c(-20, 0)),
  "5-minute gap before the card" = list(donut_sets, c(0, 20), c(-25, -5)),
  "Skip the first 2 minutes after" = list(sets, c(2, 20), c(-20, 0)),
  "England only" = list(subset_sets(function(s) s$game$league == "England"), c(0, 20), c(-20, 0)),
  "Spain only" = list(subset_sets(function(s) s$game$league == "Spain"), c(0, 20), c(-20, 0)),
  "Italy only" = list(subset_sets(function(s) s$game$league == "Italy"), c(0, 20), c(-20, 0)),
  "Second yellows only" = list(subset_sets(function(s) s$card$type == "Second Yellow"), c(0, 20), c(-20, 0)),
  "Straight reds only" = list(subset_sets(function(s) s$card$type == "Red Card"), c(0, 20), c(-20, 0)),
  "Include penalty and keeper reds" = list(broad, c(0, 20), c(-20, 0)),
  "3 twins instead of 5" = list(three, c(0, 20), c(-20, 0)),
  "Tighter strength match" = list(narrow, c(0, 20), c(-20, 0)))
rob <- rbindlist(lapply(names(checks), function(k) rbindlist(lapply(c("focal", "opponent", "total"), function(r) {
  x <- checks[[k]]; cbind(check = k, role = r, est(x[[1]], "npxg", r, after = x[[2]], before = x[[3]]))
}))))
rob[, check := factor(check, rev(names(checks)))]
rob[, role_lab := factor(c(focal = "Team down to ten", opponent = "Opponent", total = "Both teams combined")[role], c("Team down to ten", "Opponent", "Both teams combined"))]
rob[, colour := ifelse(check == "Main analysis", c(focal = RED, opponent = BLUE, total = INK)[role], GREY)]
rob[, tip := sprintf("<b>%s</b><br>%s: %s npxG per 20'<br>95%% interval %s<br>%d red cards", check, role_lab, signed(estimate), ci(lo, hi), n)]
donut_placebo <- est(donut_sets, "npxg", "opponent", before = c(-25, -15), after = c(-15, -5))
p5 <- ggplot(rob, aes(estimate, check, colour = colour)) +
  geom_vline(xintercept = 0, colour = "#bdbdbd") +
  geom_linerange(aes(xmin = lo, xmax = hi), linewidth = .9) +
  geom_point_interactive(aes(tooltip = tip, data_id = paste(check, role)), size = 2.8) +
  facet_wrap(~ role_lab, ncol = 3) + scale_colour_identity() + scale_x_continuous(labels = signed) +
  labs(title = "Every version of the analysis tells the same story",
       subtitle = "Change in npxG per 20 minutes after the red vs matched twins, with 95% intervals",
       x = "npxG per 20 minutes vs twins", y = NULL) +
  theme_sb() + theme(panel.grid.major.y = element_line(colour = "#f2f2f2"), axis.text.y = element_text(colour = INK, size = 10))
sb_chart(p5, 5.4)
Data: StatsBomb Open Data · 2015/16 Premier League, La Liga and Serie A StatsBomb

The ten-man side’s drop appears in every league, for straight reds and second yellows, with penalty and goalkeeper reds included, with three twins instead of five, with a tighter match on team strength, skipping the first two minutes after the card, and leaving a five-minute gap before it. Across every specification, the combined threat of both teams stays close to zero (−0.03 npxG per 20 minutes in the main analysis): a red card doesn’t change how much football is played, only who gets to play it.

The analysis was first written in Python and rebuilt here in R from the raw event files, reproducing every original estimate to four decimal places.

Data. Event data: StatsBomb Open Data (2015/16 Premier League, La Liga, Serie A). Pre-match odds: Football-Data.co.uk. fetch.R downloads the raw files and prep.R rebuilds the match states.

Show the code: setup and chart style 
library(data.table)
library(ggplot2)
library(ggiraph)

RED <- "#d7301f"; BLUE <- "#2b6cb0"; GREY <- "#8a8f98"; INK <- "#1d1d1f"; MUTED <- "#5f6368"

theme_sb <- function() {
  theme_minimal(base_family = "Helvetica", base_size = 12) +
    theme(plot.title = element_text(face = "bold", size = 16, colour = INK, margin = margin(b = 4)),
          plot.subtitle = element_text(colour = MUTED, size = 11.5, margin = margin(b = 12)),
          plot.title.position = "plot",
          panel.grid.minor = element_blank(), panel.grid.major.x = element_blank(),
          panel.grid.major.y = element_line(colour = "#e8e8e8", linewidth = .35),
          axis.title = element_text(colour = MUTED, size = 10), axis.text = element_text(colour = MUTED),
          strip.text = element_text(face = "bold", size = 12, hjust = 0, colour = INK),
          legend.position = "none", plot.background = element_rect(fill = "white", colour = NA))
}

# Every chart: interactive SVG + the StatsBomb credit line their data terms require
sb_chart <- function(p, height = 4.6, note = "Data: StatsBomb Open Data · 2015/16 Premier League, La Liga and Serie A") {
  htmltools::tagList(
    girafe(ggobj = p, width_svg = 9, height_svg = height,
           options = list(opts_tooltip(css = "background:#1d1d1f;color:#fff;padding:6px 9px;border-radius:4px;font:12px Helvetica,Arial,sans-serif;", opacity = .96),
                          opts_hover(css = "stroke-width:3;"), opts_toolbar(saveaspng = FALSE), opts_sizing(rescale = TRUE))),
    htmltools::div(class = "sb-source", htmltools::span(note), htmltools::img(src = "statsbomb-logo.png", alt = "StatsBomb")))
}
pct <- function(x, d = 0) paste0(formatC(100 * x, format = "f", digits = d), "%")
num <- function(x, d = 2) formatC(x, format = "f", digits = d)
signed <- function(x, d = 2) { r <- round(x, d); paste0(ifelse(r > 0, "+", ifelse(r < 0, "−", "")), formatC(abs(r), format = "f", digits = d)) }
ci <- function(lo, hi, d = 2) paste0("[", signed(lo, d), ", ", signed(hi, d), "]")
fmt_p <- function(x) if (x < .001) "<0.001" else sprintf("%.3f", x)
Show the code: the matching and estimation engine (functions.R) 
# Red cards — matched event study in R.
# Re-implements red_card_matched_study/analyse.py (same eligibility, matching and
# clustered WLS inference). Shared by replicate.R and the White Belt article.

library(data.table)

load_features <- function(path = "data/features.rds") {
  f <- readRDS(path)
  # Fast lookup: per match x side x metric, sorted times and a cumulative sum
  parts <- split(f$metrics, by = c("match_id", "side", "metric"), keep.by = FALSE)   # names "<match>.<side>.<metric>"
  f$idx <- list2env(lapply(parts, function(d) list(t = d$time, cs = c(0, cumsum(d$value)))), hash = TRUE)
  f$goals <- split(f$metrics[metric == "goals", .(time, side)], f$metrics[metric == "goals", match_id])
  f
}

# Sum of a metric for one side in [left, right) seconds of elapsed match time
measure <- function(f, mid, side, metric, left, right) {
  z <- f$idx[[paste(mid, side, metric, sep = ".")]]
  if (is.null(z)) return(0)
  z$cs[findInterval(right, z$t, left.open = TRUE) + 1] - z$cs[findInterval(left, z$t, left.open = TRUE) + 1]
}

scores_at <- function(f, mid, t) {
  g <- f$goals[[as.character(mid)]]
  if (is.null(g)) return(c(0, 0))
  c(sum(g$time < t & g$side == 0), sum(g$time < t & g$side == 1))
}

win_prob <- function(game, side) if (side == 0) game$p_home else game$p_away

FEATURES  <- c("win_probability", "goals_at_index", "pre_npxg_focal", "pre_npxg_opponent",
               "pre_shots_focal", "pre_shots_opponent", "pre_passes_focal", "pre_passes_opponent")
MIN_SCALE <- c(.10, 1, .20, .20, 2, 2, 30, 30)

feature <- function(f, game, side, t, scores) {
  m <- function(s, k) measure(f, game$match_id, s, k, t - 1200, t)
  c(win_prob(game, side), sum(scores),
    m(side, "npxg"), m(1 - side, "npxg"), m(side, "np_shots"), m(1 - side, "np_shots"),
    m(side, "passes"), m(1 - side, "passes"))
}

first_red <- function(f, mid) { r <- f$reds[match_id == mid]; if (nrow(r)) r[order(time)] else NULL }

eligible <- function(f, game, horizon = 20, broad = FALSE) {
  r <- first_red(f, game$match_id)
  if (is.null(r)) return(list(why = "no_red"))
  c1 <- r[1]; t <- c1$time
  if (t < 1200) return(list(why = "under_20min_pre"))
  later <- if (nrow(r) > 1) r$time[-1] else numeric()
  if (min(c(game$end, later)) < t + horizon * 60) return(list(why = "insufficient_stable_followup"))
  po <- f$perm_off[match_id == game$match_id, time]
  if (any(po < t + horizon * 60)) return(list(why = "permanent_off"))
  if (!broad && c1$penalty) return(list(why = "penalty_linked"))
  if (!broad && c1$goalkeeper) return(list(why = "goalkeeper"))
  list(card = c1, why = NA)
}

# Build matched sets: same league, half, within-half clock, home/away orientation and score
# difference; caliper on pre-match win probability; up to k nearest donors by standardized RMS.
match_design <- function(f, horizon = 20, broad = FALSE, k = 5, caliper = .15) {
  games <- f$games; sets <- list(); reasons <- character()
  for (gi in seq_len(nrow(games))) {
    g <- games[gi]; el <- eligible(f, g, horizon, broad)
    if (!is.na(el$why)) { if (el$why != "no_red") reasons <- c(reasons, el$why); next }
    cd <- el$card; side <- cd$side; t <- cd$time
    score <- c(cd$home_before, cd$away_before); diff <- score[side + 1] - score[2 - side]
    xt <- feature(f, g, side, t, score)
    donors <- games[league == g$league & match_id != g$match_id]
    pool <- list()
    for (di in seq_len(nrow(donors))) {
      d <- donors[di]
      half_len <- if (cd$period == 1) d$half_end else d$end - d$half_end
      if (cd$half_time >= half_len) next
      anchor <- cd$half_time + if (cd$period == 2) d$half_end else 0
      if (anchor < 1200 || anchor + horizon * 60 > d$end) next
      dr <- first_red(f, d$match_id)
      if (!is.null(dr) && dr$time[1] < anchor + horizon * 60) next
      if (any(f$perm_off[match_id == d$match_id, time] < anchor + horizon * 60)) next
      ds <- scores_at(f, d$match_id, anchor)
      if (ds[side + 1] - ds[2 - side] != diff) next
      pool[[length(pool) + 1]] <- list(match_id = d$match_id, game = d, time = anchor, x = feature(f, d, side, anchor, ds))
    }
    if (!length(pool)) { reasons <- c(reasons, "no_exact_stratum"); next }
    X <- do.call(rbind, lapply(pool, `[[`, "x"))
    sdv <- apply(X, 2, function(v) sqrt(mean((v - mean(v))^2)))           # population SD, as numpy
    scale <- pmax(sdv, MIN_SCALE)
    dist <- sqrt(rowMeans(sweep(sweep(X, 2, xt), 2, scale, "/")^2))
    ok <- which(abs(X[, 1] - xt[1]) <= caliper & dist <= 1.5)
    ok <- ok[order(dist[ok], vapply(pool[ok], `[[`, 0, "match_id"))]
    if (length(ok) < 3) { reasons <- c(reasons, "fewer_than_3_donors"); next }
    chosen <- lapply(head(ok, k), function(j) c(pool[[j]], distance = dist[j]))
    sets[[length(sets) + 1]] <- list(game = g, card = cd, side = side, time = t, xt = xt, donors = chosen,
                                     pool_mean = colMeans(X), pool_second = colMeans(X^2))
  }
  attr(sets, "reasons") <- table(reasons)
  sets
}

# Matched difference-in-differences: treated change minus mean donor change, per 20 minutes.
# Equivalent to WLS with matched-set intercepts; sandwich SEs clustered by source match.
estimate <- function(f, sets, metric, after = c(0, 20), before = c(-20, 0), role = "focal") {
  n <- length(sets)
  rate <- function(mid, side, t, w) {
    sides <- if (role == "total") 0:1 else side
    sum(vapply(sides, function(s) measure(f, mid, s, metric, t + w[1] * 60, t + w[2] * 60), 0)) / diff(w) * 20
  }
  yt <- tb <- ta <- cb <- ca <- numeric(n); yc <- vector("list", n); flat <- list()
  for (i in seq_len(n)) {
    s <- sets[[i]]; side <- if (role == "opponent") 1 - s$side else s$side
    pre <- rate(s$game$match_id, side, s$time, before); post <- rate(s$game$match_id, side, s$time, after)
    tb[i] <- pre; ta[i] <- post; yt[i] <- post - pre
    dv <- t(vapply(s$donors, function(d) c(rate(d$match_id, side, d$time, before), rate(d$match_id, side, d$time, after)), c(0, 0)))
    cb[i] <- mean(dv[, 1]); ca[i] <- mean(dv[, 2]); yc[[i]] <- dv[, 2] - dv[, 1]
    flat[[i]] <- data.table(set = i, cluster = c(s$game$match_id, vapply(s$donors, `[[`, 0, "match_id")),
                            w = c(1, rep(1 / nrow(dv), nrow(dv))), z = c(.5, rep(-.5, nrow(dv))), y = c(post - pre, yc[[i]]))
  }
  cm <- vapply(yc, mean, 0); beta <- mean(yt - cm); alpha <- (yt + cm) / 2
  fl <- rbindlist(flat); fl[, u := w * z * (y - alpha[set] - beta * z)]
  g <- fl[, .(u = sum(u)), by = cluster]
  N <- nrow(fl); p <- n + 1; ng <- nrow(g)
  correction <- ng / (ng - 1) * (N - 1) / (N - p)
  se <- sqrt(sum(g$u^2) / (.5 * n)^2 * correction); crit <- qt(.975, n - 1)
  data.table(n = n, estimate = beta, se = se, lo = beta - crit * se, hi = beta + crit * se,
             p = 2 * pt(abs(beta / se), n - 1, lower.tail = FALSE),
             treated_before = mean(tb), treated_after = mean(ta), control_before = mean(cb), control_after = mean(ca),
             benchmark_after = mean(tb) + mean(ca) - mean(cb))
}
Show the code: build the matched comparisons and every number quoted in the text 
f <- load_features("data/features.rds")
n_games <- nrow(f$games); n_reds <- nrow(f$reds)

# 1. Mechanism: 20 clean minutes before and after the first red (no penalty/keeper reds)
sets <- match_design(f)
est  <- function(s, metric = "npxg", role = "focal", ...) estimate(f, s, metric, role = role, ...)
own  <- est(sets, role = "focal"); opp <- est(sets, role = "opponent"); tot <- est(sets, role = "total")
pre_placebo <- est(sets, "npxg", "opponent", before = c(-20, -10), after = c(-10, 0))

# 2. Persistence: games that stay 11-v-10 for 40 minutes
long <- match_design(f, horizon = 40)

# 3. Cost and timing: every first red from minute 20, matched at the card, outcome = final points
all_sets <- match_design(f, horizon = 1, broad = TRUE)
points_of <- function(game, side) {
  gf <- if (side == 0) game$home_score else game$away_score; ga <- if (side == 0) game$away_score else game$home_score
  if (gf > ga) 3 else if (gf == ga) 1 else 0
}
points_gap <- function(S) {          # matched difference in final points, clustered by source match
  pl <- rbindlist(lapply(seq_along(S), function(i) { s <- S[[i]]
    rbind(data.table(set = i, cluster = s$game$match_id, w = 1, z = .5, y = points_of(s$game, s$side)),
          data.table(set = i, cluster = vapply(s$donors, `[[`, 0, "match_id"), w = 1 / length(s$donors), z = -.5,
                     y = vapply(s$donors, function(d) points_of(d$game, s$side), 0))) }))
  pt <- pl[, .(tr = y[z > 0], cm = sum(w[z < 0] * y[z < 0])), by = set]
  b <- mean(pt$tr - pt$cm); a <- (pt$tr + pt$cm) / 2
  pl[, u := w * z * (y - a[set] - b * z)]; g <- pl[, .(u = sum(u)), by = cluster]; n <- nrow(pt); N <- nrow(pl)
  se <- sqrt(sum(g$u^2) / (.5 * n)^2 * nrow(g) / (nrow(g) - 1) * (N - 1) / (N - n - 1)); cr <- qt(.975, n - 1)
  data.table(n = n, ten = mean(pt$tr), twins = mean(pt$cm), cost = -b, lo = -(b + cr * se), hi = -(b - cr * se))
}
card_min <- vapply(all_sets, function(s) s$time / 60, 0)
buckets  <- cut(card_min, c(20, 45, 60, 75, Inf), right = FALSE, labels = c("20–45 min", "45–60 min", "60–75 min", "75+ min"))
cost_all <- points_gap(all_sets)
by_time  <- rbindlist(lapply(levels(buckets), function(b) cbind(bucket = b, points_gap(all_sets[buckets == b]))))
by_time[, bucket := factor(bucket, levels(buckets))]

# Cost as a function of time left at the card -> what a 20-minute power play would cost
per_card <- rbindlist(lapply(all_sets, function(s) data.table(
  left = (s$game$end - s$time) / 60,
  gap = mean(vapply(s$donors, function(d) points_of(d$game, s$side), 0)) - points_of(s$game, s$side))))
fit <- lm(gap ~ left, per_card)
per10 <- 10 * coef(fit)[["left"]]
pp20  <- predict(fit, data.frame(left = 20), interval = "confidence")
ratio <- by_time[bucket == "20–45 min", cost] / by_time[bucket == "75+ min", cost]   # early vs late price

# 4. Share of the match's chances, 20 minutes before and after the card
sh <- rbindlist(lapply(sets, function(s) {
  w <- function(mid, side, t, a, b) measure(f, mid, side, "npxg", t + a * 60, t + b * 60)
  tr <- c(w(s$game$match_id, s$side, s$time, -20, 0), w(s$game$match_id, 1 - s$side, s$time, -20, 0),
          w(s$game$match_id, s$side, s$time, 0, 20), w(s$game$match_id, 1 - s$side, s$time, 0, 20))
  dn <- rowMeans(vapply(s$donors, function(d) c(w(d$match_id, s$side, d$time, -20, 0), w(d$match_id, 1 - s$side, d$time, -20, 0),
                                                 w(d$match_id, s$side, d$time, 0, 20), w(d$match_id, 1 - s$side, d$time, 0, 20)), numeric(4)))
  data.table(t1 = tr[1], t2 = tr[2], t3 = tr[3], t4 = tr[4], c1 = dn[1], c2 = dn[2], c3 = dn[3], c4 = dn[4])
}))
share_before <- sum(sh$t1) / sum(sh$t1 + sh$t2); share_after <- sum(sh$t3) / sum(sh$t3 + sh$t4)
twin_before  <- sum(sh$c1) / sum(sh$c1 + sh$c2); twin_after  <- sum(sh$c3) / sum(sh$c3 + sh$c4)
Show the code: fetch.R (download the raw data) 
# Download the raw inputs used by prep.R (run once, from this folder).
# StatsBomb Open Data (hudl/open-data) and Football-Data.co.uk 2015/16 odds.
base <- "https://raw.githubusercontent.com/statsbomb/open-data/master/data/"
leagues <- c(England = 2, Spain = 11, Italy = 12)
odds <- c(England = "E0", Spain = "SP1", Italy = "I1")
dir.create("raw/events", recursive = TRUE, showWarnings = FALSE); dir.create("raw/sources", showWarnings = FALSE)
for (l in names(leagues)) {
  mf <- sprintf("raw/sources/matches_%s.json", l)
  if (!file.exists(mf)) download.file(sprintf("%smatches/%d/27.json", base, leagues[[l]]), mf, quiet = TRUE)
  of <- sprintf("raw/sources/odds_%s.csv", l)
  if (!file.exists(of)) download.file(sprintf("https://www.football-data.co.uk/mmz4281/1516/%s.csv", odds[[l]]), of, quiet = TRUE)
  for (id in jsonlite::fromJSON(mf)$match_id) {
    ef <- sprintf("raw/events/%d.json.gz", id)
    if (file.exists(ef)) next
    tmp <- tempfile(); download.file(sprintf("%sevents/%d.json", base, id), tmp, quiet = TRUE)
    con <- gzfile(ef, "wb"); writeBin(readBin(tmp, "raw", file.size(tmp)), con); close(con)
  }
}
cat(length(list.files("raw/events")), "event files ready\n")
Show the code: prep.R (rebuild match states and metrics from raw events) 
# Red cards — rebuild match states and event metrics from raw StatsBomb events.
# An R re-implementation of red_card_matched_study/build_features.py (same rules),
# reading raw/events/<match_id>.json.gz and raw/sources/. Writes data/features.rds.
#
# Run from this folder:  Rscript prep.R

suppressPackageStartupMessages({ library(jsonlite); library(data.table); library(parallel) })

ALIASES <- c(
  "AFC Bournemouth" = "Bournemouth", "Leicester City" = "Leicester", "Manchester City" = "Man City",
  "Manchester United" = "Man United", "Newcastle United" = "Newcastle", "Norwich City" = "Norwich",
  "Stoke City" = "Stoke", "Swansea City" = "Swansea", "Tottenham Hotspur" = "Tottenham",
  "West Bromwich Albion" = "West Brom", "West Ham United" = "West Ham",
  "AC Milan" = "Milan", "AS Roma" = "Roma", "Hellas Verona" = "Verona", "Inter Milan" = "Inter",
  "Athletic Club" = "Ath Bilbao", "Atlético Madrid" = "Ath Madrid", "Celta Vigo" = "Celta",
  "Espanyol" = "Espanol", "Levante UD" = "Levante", "Málaga" = "Malaga", "RC Deportivo La Coruña" = "La Coruna",
  "Rayo Vallecano" = "Vallecano", "Real Betis" = "Betis", "Real Sociedad" = "Sociedad", "Sporting Gijón" = "Sp Gijon")
alias <- function(x) ifelse(x %in% names(ALIASES), ALIASES[x], x)

secs <- function(ts) { p <- strsplit(ts, ":", fixed = TRUE); vapply(p, function(z) as.numeric(z[1]) * 3600 + as.numeric(z[2]) * 60 + as.numeric(z[3]), 0) }
col  <- function(e, name, default = NA) if (name %in% names(e)) e[[name]] else rep(default, nrow(e))
xy   <- function(lst, i) vapply(lst, function(v) if (length(v) >= i) as.numeric(v[i]) else NA_real_, 0)
in_box <- function(x, y) !is.na(x) & x >= 102 & y >= 18 & y <= 62

# ---- matches + odds ---------------------------------------------------------------
read_league <- function(league) {
  m <- fromJSON(sprintf("raw/sources/matches_%s.json", league), flatten = TRUE)
  o <- fread(sprintf("raw/sources/odds_%s.csv", league), encoding = "UTF-8")
  o <- o[HomeTeam != "" & Date != ""]
  o[, date := as.Date(Date, format = ifelse(nchar(sub(".*/", "", Date)) == 2, "%d/%m/%y", "%d/%m/%Y"))]
  stopifnot(!anyDuplicated(o[, .(date, HomeTeam, AwayTeam)]))
  m <- data.table(match_id = m$match_id, league = league, date = as.Date(m$match_date),
                  home = m$home_team.home_team_name, away = m$away_team.away_team_name,
                  home_id = m$home_team.home_team_id, away_id = m$away_team.away_team_id,
                  home_score = m$home_score, away_score = m$away_score)
  m[, `:=`(oh = alias(home), oa = alias(away))]
  j <- o[m, on = .(date, HomeTeam = oh, AwayTeam = oa)]
  stopifnot(!anyNA(j$FTHG), all(j$FTHG == j$home_score & j$FTAG == j$away_score))  # every join checked against the score
  use_avg <- !is.na(j$BbAvH) & j$BbAvH > 1 & j$BbAvD > 1 & j$BbAvA > 1
  ph <- ifelse(use_avg, j$BbAvH, j$B365H); pd <- ifelse(use_avg, j$BbAvD, j$B365D); pa <- ifelse(use_avg, j$BbAvA, j$B365A)
  inv <- cbind(1 / ph, 1 / pd, 1 / pa); inv <- inv / rowSums(inv)        # remove the overround
  j[, .(match_id, league, date, home, away, home_id, away_id, home_score, away_score,
        p_home = inv[, 1], p_draw = inv[, 2], p_away = inv[, 3])]
}
matches <- rbindlist(lapply(c("England", "Spain", "Italy"), read_league))

# ---- one match --------------------------------------------------------------------
parse_match <- function(mid) {
  meta <- matches[match_id == mid]
  path <- sprintf("raw/events/%d.json.gz", mid)
  e <- fromJSON(rawToChar(memDecompress(readBin(path, "raw", file.size(path)), "gzip")), flatten = TRUE)
  e <- e[order(e$index), ]
  e <- e[e$period %in% 1:2, ]
  type <- e$type.name; ts <- secs(e$timestamp)
  half_end <- c(max(ts[e$period == 1 & type == "Half End"]), max(ts[e$period == 2 & type == "Half End"]))
  t <- ts + ifelse(e$period == 2, half_end[1], 0)
  side <- ifelse(e$team.id == meta$home_id, 0L, 1L)

  # Walk events in order to track who is on the pitch and the score
  active <- list(); sc <- c(0L, 0L); sent <- c(0L, 0L)
  card <- col(e, "foul_committed.card.name"); bb <- col(e, "bad_behaviour.card.name")
  card[is.na(card)] <- bb[is.na(card)]
  pen <- col(e, "foul_committed.penalty", FALSE); pen[is.na(pen)] <- FALSE
  pos <- col(e, "position.id"); pid <- col(e, "player.id")
  repl <- col(e, "substitution.replacement.id")
  shot_out <- col(e, "shot.outcome.name"); perm <- col(e, "player_off.permanent", FALSE); perm[is.na(perm)] <- FALSE
  lineup <- col(e, "tactics.lineup", list(NULL))
  end <- sum(half_end)
  reds <- list(); goals <- list(); perm_off <- numeric()
  for (i in seq_len(nrow(e))) {
    tm <- as.character(e$team.id[i])
    if (type[i] == "Starting XI") active[[tm]] <- lineup[[i]]$player.id
    if (!is.na(card[i]) && card[i] %in% c("Red Card", "Second Yellow")) {
      onfield <- !is.na(pid[i]) && pid[i] %in% active[[tm]] && t[i] < end
      if (onfield) {
        reds[[length(reds) + 1]] <- data.table(time = t[i], half_time = ts[i], period = e$period[i], minute = e$minute[i],
          side = side[i], player = col(e, "player.name")[i], type = card[i], penalty = pen[i],
          goalkeeper = isTRUE(pos[i] == 1), home_before = sc[1], away_before = sc[2])
        active[[tm]] <- setdiff(active[[tm]], pid[i]); sent[side[i] + 1] <- sent[side[i] + 1] + 1L
      }
    }
    if (type[i] == "Substitution") active[[tm]] <- c(setdiff(active[[tm]], pid[i]), repl[i])
    if (type[i] == "Player Off" && isTRUE(perm[i])) perm_off <- c(perm_off, t[i])
    if (type[i] == "Shot" && isTRUE(shot_out[i] == "Goal")) { sc[side[i] + 1] <- sc[side[i] + 1] + 1L; goals[[length(goals) + 1]] <- data.table(time = t[i], side = side[i]) }
    if (type[i] == "Own Goal Against") { s <- 1L - side[i]; sc[s + 1] <- sc[s + 1] + 1L; goals[[length(goals) + 1]] <- data.table(time = t[i], side = s) }
  }
  stopifnot(identical(sc, c(meta$home_score, meta$away_score)))      # reconstructed score must match the source

  # Metric events: one row per counted event (time, side, metric, value)
  is_shot <- type == "Shot"; xg <- as.numeric(col(e, "shot.statsbomb_xg", 0)); is_pen <- col(e, "shot.type.name") %in% "Penalty"
  pass_ok <- type == "Pass" & is.na(col(e, "pass.outcome.name"))
  loc <- col(e, "location", list(NULL)); pend <- col(e, "pass.end_location", list(NULL)); cend <- col(e, "carry.end_location", list(NULL))
  sx <- xy(loc, 1); sy <- xy(loc, 2); px <- xy(pend, 1); py <- xy(pend, 2); cx <- xy(cend, 1); cy <- xy(cend, 2)
  box_pass  <- pass_ok & in_box(px, py) & !in_box(sx, sy)
  box_carry <- type == "Carry" & in_box(cx, cy) & !in_box(sx, sy)
  m <- rbind(
    data.table(time = t[is_shot], side = side[is_shot], metric = "xg", value = xg[is_shot]),
    data.table(time = t[is_shot & !is_pen], side = side[is_shot & !is_pen], metric = "npxg", value = xg[is_shot & !is_pen]),
    data.table(time = t[is_shot & !is_pen], side = side[is_shot & !is_pen], metric = "np_shots", value = 1),
    data.table(time = t[pass_ok], side = side[pass_ok], metric = "passes", value = 1),
    data.table(time = t[pass_ok & !is.na(px) & px >= 80], side = side[pass_ok & !is.na(px) & px >= 80], metric = "final_third", value = 1),
    data.table(time = t[box_pass | box_carry], side = side[box_pass | box_carry], metric = "box_entries", value = 1))
  if (length(goals)) m <- rbind(m, rbindlist(goals)[, .(time, side, metric = "goals", value = 1)])
  m[, match_id := mid]
  list(match = data.table(match_id = mid, half_end = half_end[1], end = end, n_events = nrow(e)),
       reds = if (length(reds)) rbindlist(reds)[, match_id := mid] else NULL,
       perm_off = if (length(perm_off)) data.table(match_id = mid, time = perm_off) else NULL,
       metrics = m)
}

t0 <- Sys.time()
parsed <- mclapply(matches$match_id, function(mid) tryCatch(parse_match(mid), error = function(err) stop(mid, ": ", conditionMessage(err))),
                   mc.cores = max(1, detectCores() - 1))
bad <- vapply(parsed, inherits, TRUE, "try-error"); if (any(bad)) stop(parsed[bad][[1]])

clock    <- rbindlist(lapply(parsed, `[[`, "match"))
reds     <- rbindlist(lapply(parsed, `[[`, "reds"))
perm_off <- rbindlist(lapply(parsed, `[[`, "perm_off"))
metrics  <- rbindlist(lapply(parsed, `[[`, "metrics"))
games    <- clock[matches, on = "match_id"]
setkey(metrics, match_id, side, metric, time)

saveRDS(list(games = games, reds = reds, perm_off = perm_off, metrics = metrics), "data/features.rds", compress = "xz")
cat(sprintf("%d matches, %s events, %d on-field reds in %d games, %d shots | %.0fs\n",
            nrow(games), format(sum(games$n_events), big.mark = ","), nrow(reds), uniqueN(reds$match_id),
            metrics[metric == "xg", .N], as.numeric(difftime(Sys.time(), t0, units = "secs"))))