勝率テーブルの集計

build-states.R が年ごとに作った集計を1本にまとめ, 甲子園bot が引く win-probability.csv を作ります.

library(data.table)
library(dplyr)
library(ggplot2)
library(splines)
library(knitr)

files <- list.files("../../data/derived/win-prob-states", pattern = "^states-[0-9]{4}\\.csv$",
                    full.names = TRUE)

raw <-
  rbindlist(lapply(files, fread)) |>
  as_tibble() |>
  summarise(HOME_WINS = sum(HOME_WINS),
            HOME_LOSES = sum(HOME_LOSES),
            GAMES = sum(GAMES),
            .by = c(INN_CT, BAT_HOME_ID, OUTS_CT, RUNNERS, HOME_AWAY))

75年ぶん, 15,236通りの状態, 延べ10,808,263試合です.

そのまま使うと壊れる

状態の数に対して試合数が足りません.

raw <- raw |> mutate(p_raw = HOME_WINS / GAMES)

raw |>
  summarise(`状態の数` = n(),
            `10試合未満` = sum(GAMES < 10),
            `1試合だけ` = sum(GAMES == 1),
            `勝率が0か1` = sum(p_raw == 0 | p_raw == 1)) |>
  kable()

状態の数	10試合未満	1試合だけ	勝率が0か1
15236	5234	1939	7888

52%の状態で勝率が0%か100%になっています. 1試合しか無い状態が1939もあるので当然です.

bot がこういう状態を引くと「勝率0%」と答えてしまいます. 大差の場面なら0%でよいのですが, 1試合しか無いだけの場面まで 0%と言い切るのは困ります.

raw |>
  ggplot(aes(x = GAMES)) +
  geom_histogram(bins = 50) +
  scale_x_log10() +
  xlab("その状態の試合数 (対数軸)") +
  ggtitle("ほとんどの状態は標本が少ない")

平滑化する

考え方は単純です. 試合数が多い状態はそのままの値を信じ, 少ない状態はモデルの予測に寄せます.

まず, 状態の特徴から勝率を予測するモデルを当てます. 点差とイニングが主役で, そこに表裏・アウト・走者を足します. 点差とイニングは自然スプラインで滑らかにし, 交互作用も入れます (同じ1点差でも1回と9回では意味が違うため).

model_data <-
  raw |>
  mutate(DIFF = pmax(pmin(HOME_AWAY, 10), -10),   # 10点差以上は同じ扱い
         INN = pmin(INN_CT, 10))                  # 延長はまとめる

fit <- suppressWarnings(glm(
  cbind(HOME_WINS, HOME_LOSES) ~ ns(DIFF, 5) * ns(INN, 4) +
    factor(BAT_HOME_ID) + factor(OUTS_CT) + factor(RUNNERS),
  family = binomial, data = model_data))

model_data <- model_data |>
  mutate(p_model = pmin(pmax(predict(fit, newdata = model_data, type = "response"),
                             0.001), 0.999))

次に, モデルの予測を「事前の50試合ぶんの情報」として足します.

\[ p = \frac{\text{勝ち数} + k \cdot p_{\text{model}}}{\text{試合数} + k}, \quad k = 50 \]

試合数が50より十分多ければ実測がほぼそのまま残り, 少なければモデルに寄ります.

K <- 50

smoothed <-
  model_data |>
  mutate(HOME_WIN_PROB = (HOME_WINS + K * p_model) / (GAMES + K))

効き方を確かめる

peek <- function(inn, half, outs, runners, diff, label) {
  smoothed |>
    filter(INN_CT == inn, BAT_HOME_ID == half, OUTS_CT == outs,
           RUNNERS == runners, HOME_AWAY == diff) |>
    transmute(場面 = label, 試合数 = GAMES,
              実測 = p_raw, 平滑化後 = HOME_WIN_PROB)
}

bind_rows(
  peek(1, 0, 0, 0,   0, "試合開始"),
  peek(9, 1, 0, 0,   0, "9回裏0死 同点"),
  peek(9, 1, 2, 0,   0, "9回裏2死 同点"),
  peek(9, 1, 2, 111, 1, "9回裏2死満塁 1点ビハインド"),
  peek(9, 1, 0, 0,   3, "9回裏0死 3点リード")
) |> kable(digits = 3)

場面	試合数	実測	平滑化後
試合開始	136430	0.540	0.540
9回裏0死同点	13840	0.657	0.657
9回裏2死同点	7087	0.551	0.551

試合数の多い場面では実測がそのまま残っています. 「9回裏0死同点」と「9回裏2死同点」の差 (アウト2つぶん) も潰れていません.

smoothed |>
  filter(GAMES <= 200) |>
  ggplot(aes(x = p_raw, y = HOME_WIN_PROB, colour = GAMES)) +
  geom_abline(slope = 1, intercept = 0, linetype = "dashed") +
  geom_point(alpha = 0.4, size = 1) +
  scale_colour_viridis_c(transform = "log10") +
  xlab("実測の勝率") + ylab("平滑化後") +
  ggtitle("標本が少ないほど内側に寄る (試合数200以下を表示)")

smoothed |>
  summarise(`勝率が0か1` = sum(HOME_WIN_PROB == 0 | HOME_WIN_PROB == 1),
            最小 = signif(min(HOME_WIN_PROB), 3),
            最大 = signif(max(HOME_WIN_PROB), 3)) |>
  kable()

勝率が0か1	最小	最大
0	2.36e-05	1

0%や100%と言い切る状態は無くなりました. 極端に近い値は残りますが, それは大差の場面で, 標本も十分にあります.

smoothed |>
  filter(HOME_WIN_PROB < 0.01 | HOME_WIN_PROB > 0.99) |>
  summarise(`状態数` = n(),
            `試合数の中央値` = median(GAMES),
            `点差の絶対値の最小` = min(abs(HOME_AWAY))) |>
  kable()

状態数	試合数の中央値	点差の絶対値の最小
6725	9	2

イニングと点差

75年ぶんあるので, build-states.R では見えなかった形が出ます.

smoothed |>
  filter(BAT_HOME_ID == 1, OUTS_CT == 0, RUNNERS == 0,
         INN_CT %in% c(1, 3, 5, 7, 9), abs(HOME_AWAY) <= 5) |>
  mutate(回 = factor(paste0(INN_CT, "回裏"),
                     levels = paste0(c(1, 3, 5, 7, 9), "回裏"))) |>
  ggplot(aes(x = HOME_AWAY, y = HOME_WIN_PROB, colour = 回)) +
  geom_hline(yintercept = 0.5, linetype = "dashed") +
  geom_line() + geom_point(size = 1.2) +
  scale_x_continuous(breaks = -5:5) +
  xlab("点差 (ホーム - アウェイ)") + ylab("ホームの勝率") +
  ggtitle("同じ点差でも, 終盤ほど重い")

smoothed |>
  filter(BAT_HOME_ID == 1, OUTS_CT == 0, RUNNERS == 0,
         INN_CT %in% c(1, 3, 5, 7, 9), abs(HOME_AWAY) <= 5) |>
  summarise(`最小の試合数` = min(GAMES),
            `1点差あたりの勝率の変化` =
              coef(lm(HOME_WIN_PROB ~ HOME_AWAY))[2],
            .by = INN_CT) |>
  arrange(INN_CT) |>
  kable(digits = 3)

INN_CT	最小の試合数	1点差あたりの勝率の変化
1	40	0.086
3	1766	0.092
5	3533	0.103
7	4938	0.117
9	2	0.143

1回裏の1点は勝率を8.6ポイント動かしますが, 9回裏では14.3ポイントです. 1.7倍です. 挽回する回数が残っていないぶん, 終盤の1点は重くなります.

保存

bot は点差を10で打ち切って引くので, ここでも揃えます.

out <-
  smoothed |>
  summarise(HOME_WIN_PROB = weighted.mean(HOME_WIN_PROB, GAMES),
            HOME_WINS = sum(HOME_WINS), HOME_LOSES = sum(HOME_LOSES),
            GAMES = sum(GAMES),
            .by = c(INN_CT, BAT_HOME_ID, OUTS_CT, RUNNERS, DIFF)) |>
  relocate(HOME_WIN_PROB, .after = GAMES) |>
  rename(HOME_AWAY = DIFF) |>
  arrange(INN_CT, BAT_HOME_ID, OUTS_CT, RUNNERS, HOME_AWAY)

write.table(out, "../../data/derived/win-probability.csv", quote = FALSE, row.names = FALSE)

11,070通りの状態を書き出しました.

勝率を引く

win_prob <- function(inn = 1, half = 0, outs = 0, runners = 0, diff = 0) {
  d <- pmax(pmin(diff, 10), -10)
  hit <- out |>
    filter(INN_CT == inn, BAT_HOME_ID == half, OUTS_CT == outs,
           RUNNERS == runners, HOME_AWAY == d)
  if (nrow(hit) == 0) return(NA_real_)
  hit$HOME_WIN_PROB
}

win_prob(inn = 9, half = 1, outs = 2, runners = 111, diff = -1)

## [1] 0.246646

tibble::tibble(
  アウト = 0:2,
  勝率 = vapply(0:2, \(o) win_prob(9, 1, o, 111, -1), numeric(1))
) |> kable(digits = 3)

アウト	勝率
0	0.612
1	0.520
2	0.247

9回裏1点ビハインド満塁で, アウトカウントが増えるほど下がります.

注意

平滑化の強さ (k = 50) は決め打ちです. 大きくすると滑らかになりますが実測から離れます. 交差検証で選ぶのが本筋です.
1939年から2013年までをまとめています. 得点環境は時代で変わるので, 近年だけで作り直すと値が変わります.
引き分けは除いています (build-states.R を参照).
GAMES は打席数ではなくその状態を通った試合数です. アウトも走者も得点も動かないプレー (ファウルフライの落球など) があると 1試合が同じ状態を2回通るので, 行をそのまま数えると水増しになります. ずれは全体の0.05%程度で勝率はほぼ動きませんが, 列の意味は揃えてあります.