勝負強さが知りたいです. 点をとってくれる打者を評価したいです.
指標としてまず思いつくのは得点圏打率ですが, これには打点が反映されていません. かといって生の打点は打順に依存します. 勝負強くない打者でも, チャンスの場面で たくさん打席が回ってくれば勝手に打点が上がっていきます.
場面の有利さを差し引いた指標が要ります.
library(data.table)
library(dplyr)
library(ggplot2)
library(xtable)
source("../../R/retrosheet.R")
year = 2013
dat = fread(paste0("../../data/all", year, ".csv"))
names = fread("../../data/reference/retrosheet-columns.csv", header = FALSE) %>% unlist
setnames(dat, names)
fullname = fread("../../data/derived/player-names.csv")
最初は「走者状況とアウトカウント別に, その打席で入る打点の平均」を出していました. ところがこれを満塁について見ると, おかしなことになります.
rbi_per_pa <-
dat %>%
mutate(base_state = base_state(dat)) %>%
filter(base_state == 7) %>% # 満塁
group_by(OUTS_CT) %>%
dplyr::summarise(打席 = n(), 打点平均 = mean(RBI_CT), .groups = "drop")
rbi_per_pa %>% as.data.frame %>% xtable(digits = 3) %>% print(type = "html")
| OUTS_CT | 打席 | 打点平均 | |
|---|---|---|---|
| 1 | 0 | 630 | 0.708 |
| 2 | 1 | 1621 | 0.766 |
| 3 | 2 | 2008 | 0.532 |
0アウト満塁が0.708点, 1アウト満塁が0.766点で, アウトが1つ増えたほうが打点が多いという結果になります.
これは感覚と合いません. そして実際, 指標のほうが間違っています.
打点は「その打席で還った走者」しか数えません. 0アウトなら, その打席で 打点が付かなくてもイニングはまだ続き, 後続が返してくれます. 1アウトでは その機会が減るぶん, 「今この打席で返す」圧力が高くなり, 犠牲フライのように打点だけは付くプレーの比率が上がります.
つまり打点平均は, イニングの残りを見ていないのが問題です.
見るべきは「その場面から, イニングが終わるまでに平均何点入るか」です. 走者状況8通り × アウトカウント3通りの24状態について集計します.
re <- run_expectancy(dat)
re_tbl <- re %>%
mutate(走者 = base_state_label(base_state)) %>%
dcast(走者 ~ OUTS_CT, value.var = "RE")
setnames(re_tbl, c("走者", "0アウト", "1アウト", "2アウト"))
# 走者の少ない順に並べる
ord <- c("走者なし", "一塁", "二塁", "三塁", "一二塁", "一三塁", "二三塁", "満塁")
re_tbl <- re_tbl[match(ord, re_tbl$走者)]
re_tbl %>% as.data.frame %>% xtable(digits = 3) %>% print(type = "html")
| 走者 | 0アウト | 1アウト | 2アウト | |
|---|---|---|---|---|
| 1 | 走者なし | 0.456 | 0.240 | 0.092 |
| 2 | 一塁 | 0.810 | 0.491 | 0.211 |
| 3 | 二塁 | 1.088 | 0.617 | 0.301 |
| 4 | 三塁 | 1.310 | 0.914 | 0.344 |
| 5 | 一二塁 | 1.377 | 0.836 | 0.400 |
| 6 | 一三塁 | 1.803 | 1.109 | 0.480 |
| 7 | 二三塁 | 1.997 | 1.364 | 0.543 |
| 8 | 満塁 | 2.182 | 1.565 | 0.710 |
今度は素直な表になりました. 満塁は0アウトで2.18点, 1アウトで1.56点, 2アウトで0.71点と, アウトが増えるほど下がります. どの走者状況でも同じです.
走者なし0アウト (イニングの先頭) は0.456点で, 公表されている近年のメジャーの値ともほぼ一致します.
re %>%
mutate(走者 = factor(base_state_label(base_state), levels = ord),
アウト = factor(OUTS_CT)) %>%
ggplot(aes(x = 走者, y = RE, fill = アウト)) +
geom_col(position = "dodge") +
ylab("イニング終了までの期待得点") +
ggtitle(paste0(year, "年 得点期待値")) +
theme(axis.text.x = element_text(angle = 30, hjust = 1))

場面の有利さを差し引くには, 打席の前後で期待値がどう変わったかを見ます.
\[ \mathrm{RE24} = (\text{打席後の期待値}) - (\text{打席前の期待値}) + (\text{その打席で入った得点}) \]
期待値どおりなら0, 上回れば正になります. 打順や出場機会の多さで 下駄を履かない指標です.
x <- re24(dat, re)
bat <- x %>%
as_tibble() %>%
group_by(BAT_ID) %>%
dplyr::summarise(打席 = n(), RE24 = sum(re24), .groups = "drop") %>%
filter(打席 >= 300) %>%
inner_join(fullname, by = c("BAT_ID" = "retroID"))
規定を285人 (300打席以上) として並べます.
bat %>% arrange(desc(RE24)) %>% head(15) %>%
dplyr::select(name, 打席, RE24) %>%
as.data.frame %>% xtable(digits = 1) %>% print(type = "html")
| name | 打席 | RE24 | |
|---|---|---|---|
| 1 | Miguel Cabrera | 667 | 80.7 |
| 2 | Chris Davis | 690 | 76.5 |
| 3 | Mike Trout | 736 | 69.6 |
| 4 | Paul Goldschmidt | 731 | 63.9 |
| 5 | Freddie Freeman | 644 | 57.2 |
| 6 | David Ortiz | 626 | 54.5 |
| 7 | Robinson Cano | 713 | 53.1 |
| 8 | Joey Votto | 747 | 48.7 |
| 9 | Edwin Encarnacion | 637 | 48.1 |
| 10 | Matt Holliday | 617 | 46.8 |
| 11 | Matt Carpenter | 723 | 46.4 |
| 12 | Shin-Soo Choo | 731 | 45.8 |
| 13 | Allen Craig | 576 | 45.4 |
| 14 | Josh Donaldson | 693 | 45.2 |
| 15 | Michael Cuddyer | 558 | 40.2 |
bat %>% arrange(RE24) %>% head(10) %>%
dplyr::select(name, 打席, RE24) %>%
as.data.frame %>% xtable(digits = 1) %>% print(type = "html")
| name | 打席 | RE24 | |
|---|---|---|---|
| 1 | Darwin Barney | 565 | -33.5 |
| 2 | B. J. Upton | 456 | -28.4 |
| 3 | Adeiny Hechavarria | 595 | -27.9 |
| 4 | Pete Kozma | 466 | -26.8 |
| 5 | Starlin Castro | 720 | -24.4 |
| 6 | Alcides Escobar | 674 | -24.0 |
| 7 | Brendan Ryan | 357 | -22.2 |
| 8 | Jose Molina | 323 | -20.5 |
| 9 | Clete Thomas | 330 | -19.9 |
| 10 | Placido Polanco | 429 | -18.7 |
RE24 は打者の総合的な得点貢献です. これが大きいのは要するに良い打者で, 「チャンスに強い」かどうかとは別の話です.
チャンスでの上乗せを見たいなら, 走者がいる場面とそうでない場面の 打席あたり RE24 を比べます.
split_re24 <- x %>%
as_tibble() %>%
mutate(得点圏 = base_state >= 2) %>% # 二塁または三塁に走者
group_by(BAT_ID, 得点圏) %>%
dplyr::summarise(pa = n(), re24_pa = mean(re24), .groups = "drop") %>%
tidyr::pivot_wider(names_from = 得点圏, values_from = c(pa, re24_pa)) %>%
filter(pa_FALSE >= 200, pa_TRUE >= 100) %>%
mutate(差 = re24_pa_TRUE - re24_pa_FALSE) %>%
inner_join(fullname, by = c("BAT_ID" = "retroID"))
split_re24 %>%
ggplot(aes(x = 差)) +
geom_histogram(bins = 30) +
geom_vline(xintercept = 0, linetype = "dashed") +
xlab("得点圏での打席あたりRE24 − それ以外") +
ggtitle("チャンスでの上乗せ (1打席あたり)")

split_re24 %>% arrange(desc(差)) %>% head(10) %>%
dplyr::select(name, pa_TRUE, 差) %>%
setNames(c("name", "得点圏打席", "上乗せ")) %>%
as.data.frame %>% xtable(digits = 3) %>% print(type = "html")
| name | 得点圏打席 | 上乗せ | |
|---|---|---|---|
| 1 | Allen Craig | 160 | 0.259 |
| 2 | Freddie Freeman | 171 | 0.257 |
| 3 | Miguel Cabrera | 209 | 0.179 |
| 4 | John Buck | 124 | 0.167 |
| 5 | Yadier Molina | 148 | 0.154 |
| 6 | Robinson Cano | 181 | 0.148 |
| 7 | Chris Davis | 178 | 0.148 |
| 8 | Michael Bourn | 111 | 0.147 |
| 9 | Matt Holliday | 155 | 0.144 |
| 10 | Matt Carpenter | 149 | 0.142 |
ここで出た「上乗せ」の順位は, そのまま勝負強さの順位とは読めません.
上乗せの実際のばらつきは標準偏差0.072ですが, 打席数から見積もった偶然だけのばらつきは0.062です. 両者はほぼ同じ大きさで, つまり観測された散らばりの大半は偶然で説明できます. 「チャンスに強い打者」が安定して存在するなら, 実際のばらつきは 偶然の分よりはっきり大きくなるはずです.
その他の注意点: