走者がいると本塁打は出にくくなるのでしょうか.
library(data.table)
library(dplyr)
library(ggplot2)
library(knitr)
SEASONS <- 2004:2013
column_names <- unname(unlist(fread("../../data/reference/retrosheet-columns.csv", header = FALSE)))
need <- c("BAT_ID", "BAT_EVENT_FL", "AB_FL", "EVENT_CD",
"BASE1_RUN_ID", "BASE2_RUN_ID", "BASE3_RUN_ID", "OUTS_CT",
"INN_CT", "BAT_HOME_ID", "HOME_SCORE_CT", "AWAY_SCORE_CT")
files <- file.path("../../data", sprintf("all%d.csv", SEASONS))
missing <- files[!file.exists(files)]
if (length(missing) > 0) {
stop("データがありません: ", paste(basename(missing), collapse = ", "),
"\n data/README.md を参照してください.")
}
pa <- rbindlist(Map(function(path, season) {
d <- fread(path, header = FALSE, select = match(need, column_names))
setnames(d, need)
d[, year := season][]
}, files, SEASONS))
pa[, `:=`(一塁 = BASE1_RUN_ID != "",
二塁 = BASE2_RUN_ID != "",
三塁 = BASE3_RUN_ID != "")]
pa[, `:=`(走者数 = 一塁 + 二塁 + 三塁,
HR = EVENT_CD == 23L)]
ab <- pa[AB_FL == "T"]
2004年から2013年の 1,663,754打数, 49,491本塁打です.
ci <- function(hr, ab) {
m <- Map(\(h, n) binom.test(h, n)$conf.int, hr, ab)
list(lo = vapply(m, \(x) x[1], numeric(1)),
hi = vapply(m, \(x) x[2], numeric(1)))
}
by_n <-
ab |>
summarise(打数 = n(), 本塁打 = sum(HR), .by = 走者数) |>
arrange(走者数) |>
mutate(本塁打率 = 本塁打 / 打数,
下限 = ci(本塁打, 打数)$lo,
上限 = ci(本塁打, 打数)$hi)
by_n |> kable(digits = 4, format.args = list(big.mark = ","))
| 走者数 | 打数 | 本塁打 | 本塁打率 | 下限 | 上限 |
|---|---|---|---|---|---|
| 0 | 948,338 | 28,542 | 0.0301 | 0.0298 | 0.0304 |
| 1 | 481,239 | 14,204 | 0.0295 | 0.0290 | 0.0300 |
| 2 | 194,205 | 5,539 | 0.0285 | 0.0278 | 0.0293 |
| 3 | 39,972 | 1,206 | 0.0302 | 0.0285 | 0.0319 |
by_n |>
ggplot(aes(x = factor(走者数), y = 本塁打率)) +
geom_errorbar(aes(ymin = 下限, ymax = 上限), width = 0.15) +
geom_point(size = 3) +
xlab("走者の人数") + ylab("打数あたり本塁打率") +
ggtitle("走者の人数別 本塁打率 (95%信頼区間つき)")

走者なしが0.0301, 走者ありが0.0293で, 差は0.0008 (95%信頼区間 0.0003 〜 0.0013)です.
打数が1,663,754もあるので信頼区間は0を含みませんが, 大きさとしては相対2.8%, 1228打数に1本の違いでしかありません. 「走者がいると本塁打が出にくい」と言えるほどの差ではないです.
しかも走者3人 (満塁) は走者なしと同じくらいあります. 人数では説明できません.
by_state <-
ab |>
mutate(状態 = case_when(
!一塁 & !二塁 & !三塁 ~ "走者なし",
一塁 & !二塁 & !三塁 ~ "一塁",
!一塁 & 二塁 & !三塁 ~ "二塁",
!一塁 & !二塁 & 三塁 ~ "三塁",
一塁 & 二塁 & !三塁 ~ "一二塁",
一塁 & !二塁 & 三塁 ~ "一三塁",
!一塁 & 二塁 & 三塁 ~ "二三塁",
TRUE ~ "満塁")) |>
summarise(打数 = n(), 本塁打 = sum(HR), .by = c(状態, 一塁)) |>
mutate(本塁打率 = 本塁打 / 打数,
下限 = ci(本塁打, 打数)$lo,
上限 = ci(本塁打, 打数)$hi,
一塁の状況 = ifelse(一塁, "一塁が埋まっている", "一塁が空いている")) |>
arrange(desc(本塁打率))
by_state |> select(状態, 打数, 本塁打, 本塁打率, 下限, 上限) |>
kable(digits = 4, format.args = list(big.mark = ","))
| 状態 | 打数 | 本塁打 | 本塁打率 | 下限 | 上限 |
|---|---|---|---|---|---|
| 一塁 | 301,658 | 9,480 | 0.0314 | 0.0308 | 0.0321 |
| 満塁 | 39,972 | 1,206 | 0.0302 | 0.0285 | 0.0319 |
| 走者なし | 948,338 | 28,542 | 0.0301 | 0.0298 | 0.0304 |
| 一三塁 | 47,116 | 1,379 | 0.0293 | 0.0278 | 0.0308 |
| 一二塁 | 116,787 | 3,373 | 0.0289 | 0.0279 | 0.0299 |
| 三塁 | 42,760 | 1,156 | 0.0270 | 0.0255 | 0.0286 |
| 二塁 | 136,821 | 3,568 | 0.0261 | 0.0252 | 0.0269 |
| 二三塁 | 30,302 | 787 | 0.0260 | 0.0242 | 0.0278 |
by_state |>
mutate(状態 = factor(状態, levels = 状態)) |>
ggplot(aes(x = 状態, y = 本塁打率, colour = 一塁の状況)) +
geom_errorbar(aes(ymin = 下限, ymax = 上限), width = 0.15) +
geom_point(size = 3) +
theme(legend.position = "bottom", legend.title = element_blank()) +
ylab("打数あたり本塁打率") +
ggtitle("本塁打率は「一塁が空いているか」で分かれる")

順番に並べると, きれいに2つの群に分かれます. 上位は一塁に走者がいる状態, 下位は一塁が空いていて二塁か三塁に走者がいる状態です. 走者なしはその中間にあります.
一塁だけに走者がいる状態は, 走者なしより本塁打率が高いです. 「走者がいると出にくい」では説明できません.
説明は単純です. 一塁が空いていて得点圏に走者がいると, 投手は無理に勝負しなくてよくなります. 歩かせても走者が増えるだけで, 失点には直結しません. 勝負を避ければストライクゾーンに来る球が減り, 本塁打も減ります.
ab[, 敬遠できる場面 := (二塁 | 三塁) & !一塁]
pa[, 敬遠できる場面 := (二塁 | 三塁) & !一塁]
comp <-
ab |>
summarise(打数 = n(), 本塁打 = sum(HR), .by = 敬遠できる場面) |>
mutate(本塁打率 = 本塁打 / 打数,
場面 = ifelse(敬遠できる場面, "一塁が空いた得点圏", "それ以外")) |>
arrange(desc(敬遠できる場面))
comp |> select(場面, 打数, 本塁打, 本塁打率) |>
kable(digits = 4, format.args = list(big.mark = ","))
| 場面 | 打数 | 本塁打 | 本塁打率 |
|---|---|---|---|
| 一塁が空いた得点圏 | 209,883 | 5,511 | 0.0263 |
| それ以外 | 1,453,871 | 43,980 | 0.0303 |
差は-0.0040 (95%信頼区間 -0.0047 〜 -0.0033), 相対で-13%です. 走者の人数で見たときの2.8%とは桁が違います.
そう考えたなら, 四球が増えているはずです.
pa[BAT_EVENT_FL == "T"] |>
summarise(打席 = n(),
敬遠率 = mean(EVENT_CD == 15L),
四球率 = mean(EVENT_CD %in% c(14L, 15L)),
.by = 敬遠できる場面) |>
mutate(場面 = ifelse(敬遠できる場面, "一塁が空いた得点圏", "それ以外")) |>
arrange(desc(敬遠できる場面)) |>
select(場面, 打席, 敬遠率, 四球率) |>
kable(digits = 4, format.args = list(big.mark = ","))
| 場面 | 打席 | 敬遠率 | 四球率 |
|---|---|---|---|
| 一塁が空いた得点圏 | 259,685 | 0.0458 | 0.1479 |
| それ以外 | 1,606,400 | 0.0003 | 0.0735 |
敬遠は168倍, 四球全体でも2.0倍です. 勝負を避けているのは間違いありません.
打者ごとに得意不得意があります. 一塁が空いた得点圏に立つ打者は, クリーンアップに偏っているかもしれません. だとすると, 上の差は打者の顔ぶれの違いを見ているだけかもしれません.
同じ打者の中で比べます.
per_batter <-
ab |>
summarise(打数_該当 = sum(敬遠できる場面),
本塁打_該当 = sum(HR & 敬遠できる場面),
打数_他 = sum(!敬遠できる場面),
本塁打_他 = sum(HR & !敬遠できる場面),
.by = BAT_ID) |>
filter(打数_該当 >= 200, 打数_他 >= 200) |>
mutate(差 = 本塁打_該当 / 打数_該当 - 本塁打_他 / 打数_他)
tt <- t.test(per_batter$差)
tibble::tibble(
打者数 = nrow(per_batter),
平均の差 = mean(per_batter$差),
下限 = tt$conf.int[1],
上限 = tt$conf.int[2],
`差が負の打者の割合` = mean(per_batter$差 < 0)
) |> kable(digits = 4)
| 打者数 | 平均の差 | 下限 | 上限 | 差が負の打者の割合 |
|---|---|---|---|---|
| 370 | -0.004 | -0.005 | -0.003 | 0.6595 |
per_batter |>
ggplot(aes(x = 差)) +
geom_histogram(bins = 40) +
geom_vline(xintercept = 0, linetype = "dashed") +
geom_vline(xintercept = mean(per_batter$差), colour = "firebrick") +
xlab("一塁が空いた得点圏 − それ以外 (本塁打率の差)") +
ggtitle("打者ごとの差 (赤線が平均)")

打者を揃えても差は-0.0040で, 揃えないときの-0.0040とほぼ同じです. 打者の顔ぶれの違いでは説明できません.
もう1つ疑うところがあります. 一塁が空いた得点圏は, 終盤や接戦に偏っているかもしれません. そういう場面は投手の質も違うので, そこを見ているだけかもしれない.
まず偏りを確かめます.
ab[, `:=`(点差 = fifelse(BAT_HOME_ID == 1L, HOME_SCORE_CT - AWAY_SCORE_CT,
AWAY_SCORE_CT - HOME_SCORE_CT))]
ab |>
summarise(`終盤(7回以降)の割合` = mean(INN_CT >= 7),
`接戦(2点差以内)の割合` = mean(abs(点差) <= 2),
`平均イニング` = mean(INN_CT),
.by = 敬遠できる場面) |>
mutate(場面 = ifelse(敬遠できる場面, "一塁が空いた得点圏", "それ以外")) |>
select(場面, everything(), -敬遠できる場面) |>
kable(digits = 3)
| 場面 | 終盤(7回以降)の割合 | 接戦(2点差以内)の割合 | 平均イニング |
|---|---|---|---|
| それ以外 | 0.327 | 0.670 | 5.012 |
| 一塁が空いた得点圏 | 0.312 | 0.653 | 4.918 |
大きくは偏っていませんが, 揃えて比べます. イニング・点差・アウトカウントの同じ層の中だけで差を取り, 逆分散で重みを付けて平均します.
strata <-
ab |>
mutate(INN = pmin(INN_CT, 10L),
D = pmax(pmin(点差, 5L), -5L)) |>
summarise(打数 = n(), 本塁打 = sum(HR),
.by = c(敬遠できる場面, INN, D, OUTS_CT)) |>
tidyr::pivot_wider(names_from = 敬遠できる場面,
values_from = c(打数, 本塁打)) |>
filter(!is.na(打数_TRUE), !is.na(打数_FALSE),
打数_TRUE >= 30, 打数_FALSE >= 30) |>
mutate(p1 = 本塁打_TRUE / 打数_TRUE,
p0 = 本塁打_FALSE / 打数_FALSE,
w = 1 / (p1 * (1 - p1) / 打数_TRUE + p0 * (1 - p0) / 打数_FALSE))
adj <- with(strata, sum(w * (p1 - p0)) / sum(w))
adj_se <- sqrt(1 / sum(strata$w))
base <- with(strata, sum(w * p0) / sum(w))
tibble::tibble(
推定 = c("そのまま", "イニング・点差・アウトを揃えて"),
差 = c(d2, adj),
下限 = c(d2 - 1.96 * se2, adj - 1.96 * adj_se),
上限 = c(d2 + 1.96 * se2, adj + 1.96 * adj_se),
相対 = c((p1 - p0) / p0, adj / base)
) |> kable(digits = 4)
| 推定 | 差 | 下限 | 上限 | 相対 |
|---|---|---|---|---|
| そのまま | -0.0040 | -0.0047 | -0.0033 | -0.1320 |
| イニング・点差・アウトを揃えて | -0.0053 | -0.0060 | -0.0045 | -0.1807 |
揃えると差は小さくなるどころか大きくなりました (-13% → -18%, 308層, 打数1,661,412). 場面の偏りは効果を弱める向きに働いていたので, そのままの推定は 控えめだったことになります.
ab |>
summarise(打数 = n(), 本塁打率 = mean(HR), .by = c(OUTS_CT, 敬遠できる場面)) |>
mutate(場面 = ifelse(敬遠できる場面, "一塁が空いた得点圏", "それ以外")) |>
select(アウト = OUTS_CT, 場面, 打数, 本塁打率) |>
tidyr::pivot_wider(names_from = 場面, values_from = c(打数, 本塁打率)) |>
arrange(アウト) |>
kable(digits = 4, format.args = list(big.mark = ","))
| アウト | 打数_それ以外 | 打数_一塁が空いた得点圏 | 本塁打率_それ以外 | 本塁打率_一塁が空いた得点圏 |
|---|---|---|---|---|
| 0 | 541,255 | 37,149 | 0.0320 | 0.0262 |
| 1 | 475,943 | 73,181 | 0.0297 | 0.0270 |
| 2 | 436,673 | 99,553 | 0.0287 | 0.0257 |
どのアウトカウントでも同じ向きです.
ab |>
filter(year == max(SEASONS)) |>
summarise(打数 = n(), 本塁打 = sum(HR), .by = 敬遠できる場面) |>
mutate(本塁打率 = 本塁打 / 打数,
下限 = ci(本塁打, 打数)$lo,
上限 = ci(本塁打, 打数)$hi,
場面 = ifelse(敬遠できる場面, "一塁が空いた得点圏", "それ以外")) |>
arrange(desc(敬遠できる場面)) |>
select(場面, 打数, 本塁打, 本塁打率, 下限, 上限) |>
kable(digits = 4, format.args = list(big.mark = ","))
| 場面 | 打数 | 本塁打 | 本塁打率 | 下限 | 上限 |
|---|---|---|---|---|---|
| 一塁が空いた得点圏 | 20,288 | 473 | 0.0233 | 0.0213 | 0.0255 |
| それ以外 | 145,782 | 4,188 | 0.0287 | 0.0279 | 0.0296 |
2013年だけだと信頼区間が重なります. 10シーズンぶん集めてやっと分かる大きさの話です.