dplyrのacross()を使う (旧summarise_each)
2026-08-09
2013年4月のMLB全打席結果を使って, 複数列にまとめて同じ集計をかける 書き方を確認します.
もともとはdplyr::summarise_eachとdplyr::mutate_eachの練習でした.
どちらもdplyr 0.7.0で非推奨になり, 今は削除されています.
同じことはacross()で書けます.
library(data.table)
library(dplyr)
library(ggplot2)
library(knitr)
dat <- fread("../../data/derived/events-2013-04.csv")フラグ列の扱い
昔のfreadは"T"/"F"をlogicalとして読んでいたので,
打席フラグAB_FLは
そのままsum()で数えられました.
今はcharacterとして読むので変換が要ります.
source("../../R/retrosheet.R") # as_flag()
dat[, .(AB_FL, BAT_EVENT_FL)] |> head(3) |> kable()| AB_FL | BAT_EVENT_FL |
|---|---|
| T | T |
| T | T |
| F | T |
投球数の数え方
PITCH_SEQ_TXには1打席の投球が1文字ずつ入っています.
ただし投球でない文字も混ざります.
seq_chars <- table(unlist(strsplit(paste(dat$PITCH_SEQ_TX, collapse = ""), "")))
sort(seq_chars, decreasing = TRUE) |>
as.data.frame() |>
setNames(c("文字", "回数")) |>
head(22) |>
kable()| 文字 | 回数 |
|---|---|
| B | 42818 |
| C | 21125 |
| X | 21057 |
| F | 19294 |
| S | 10907 |
| . | 5190 |
| 1 | 3249 |
| * | 2383 |
| > | 2221 |
| T | 852 |
| I | 564 |
| L | 435 |
| H | 250 |
| + | 123 |
| 2 | 93 |
| M | 86 |
| N | 61 |
| P | 60 |
| O | 13 |
| 3 | 11 |
| V | 3 |
1 2 3 は塁への牽制,
+ は捕手からの牽制, > は走者のスタート,
* は次の投球がワンバウンドだった印, .
は打者に関係ないプレー, N は投球なしです.
nchar()をそのまま使うと, これらも1球と数えてしまいます.
NON_PITCH <- "[123>+*.N]"
count_pitches <- function(x) nchar(gsub(NON_PITCH, "", x))4月ぶんの合計で比べると, nchar()が130,795球,
牽制などを除くと117,464球で, 11.3%の過大計上でした.
across() で一度に集計する
H_FLは0=安打なし, 1=単打, 2=二塁打, 3=三塁打,
4=本塁打なので, 合計すると塁打数になります.
打者ごとに, 打席数・打数・安打数・塁打数・投球数を数えます.
数え方が全部sumなのでacross()でまとめられます.
per_batter <-
dat |>
transmute(BAT_ID,
PA = as_flag(BAT_EVENT_FL),
AB = as_flag(AB_FL),
H = H_FL > 0,
TB = H_FL,
pitches = count_pitches(PITCH_SEQ_TX)) |>
summarise(across(c(PA, AB, H, TB, pitches), sum), .by = BAT_ID) |>
filter(AB > 50)251人が残りました (4月に51打数以上).
率に直します. 投球数は打数ではなく打席で割ります. 四球で終わった打席も球は投げられているので, 打数で割ると 四球の多い打者が過大に出ます.
rates <-
per_batter |>
mutate(打率 = H / AB,
長打率 = TB / AB,
打席あたり投球数 = pitches / PA) |>
select(retroID = BAT_ID, 打率, 長打率, 打席あたり投球数, PA, AB)
head(rates) |> kable(digits = 3)| retroID | 打率 | 長打率 | 打席あたり投球数 | PA | AB |
|---|---|---|---|---|---|
| crisc001 | 0.283 | 0.556 | 4.197 | 117 | 99 |
| younc004 | 0.172 | 0.391 | 4.079 | 101 | 87 |
| lowrj001 | 0.333 | 0.529 | 3.913 | 115 | 102 |
| cespy001 | 0.228 | 0.509 | 4.227 | 66 | 57 |
| donaj001 | 0.314 | 0.490 | 4.267 | 116 | 102 |
| mossb001 | 0.295 | 0.477 | 4.068 | 103 | 88 |
打数で割ると平均4.42球, 打席で割ると3.95球です. MLBの1打席あたりの投球数は3.9球前後なので, 後者が妥当な値です.
ランキング
fullname <- fread("../../data/derived/player-names.csv")
named <- rates |> inner_join(fullname, by = "retroID")
show_top <- function(col, n = 10) {
named |>
arrange(desc(.data[[col]])) |>
transmute(選手 = name, !!col := .data[[col]], 打席 = PA) |>
head(n) |>
kable(digits = 3)
}打率
show_top("打率")| 選手 | 打率 | 打席 |
|---|---|---|
| Carlos Santana | 0.389 | 84 |
| James Loney | 0.373 | 74 |
| Torii Hunter | 0.370 | 107 |
| Chris Johnson | 0.369 | 87 |
| Jean Segura | 0.367 | 98 |
| Miguel Cabrera | 0.363 | 117 |
| Carlos Gomez | 0.360 | 94 |
| Wilin Rosario | 0.350 | 83 |
| Chris Davis | 0.348 | 113 |
| Nate McLouth | 0.346 | 94 |
長打率
show_top("長打率")| 選手 | 長打率 | 打席 |
|---|---|---|
| Justin Upton | 0.734 | 112 |
| Chris Davis | 0.728 | 113 |
| Carlos Santana | 0.722 | 84 |
| Bryce Harper | 0.720 | 107 |
| Travis Hafner | 0.667 | 80 |
| Mark Reynolds | 0.651 | 95 |
| Wilin Rosario | 0.650 | 83 |
| Dexter Fowler | 0.621 | 112 |
| Carlos Gomez | 0.616 | 94 |
| Troy Tulowitzki | 0.603 | 94 |
打席あたり投球数
show_top("打席あたり投球数")| 選手 | 打席あたり投球数 | 打席 |
|---|---|---|
| Will Venable | 4.727 | 77 |
| A. J. Ellis | 4.686 | 86 |
| Mark Ellis | 4.612 | 80 |
| Lucas Duda | 4.543 | 94 |
| Joe Mauer | 4.538 | 104 |
| Mike Napoli | 4.518 | 112 |
| Chris Carter | 4.495 | 105 |
| Travis Snider | 4.485 | 68 |
| Stephen Drew | 4.483 | 60 |
| Kyle Seager | 4.479 | 117 |
球を投げさせる打者は打つのか
long <-
rates |>
tidyr::pivot_longer(c(打率, 長打率), names_to = "指標", values_to = "値")
ggplot(long, aes(x = 打席あたり投球数, y = 値)) +
geom_point(alpha = 0.6) +
stat_smooth(method = "lm", formula = y ~ x) +
facet_wrap(~ 指標, scales = "free_y") +
ggtitle("打席あたり投球数との関係")
cors <-
tibble::tibble(
指標 = c("打率", "長打率"),
r = c(cor(rates$打席あたり投球数, rates$打率),
cor(rates$打席あたり投球数, rates$長打率))
) |>
mutate(`95%信頼区間の下` = NA_real_, `95%信頼区間の上` = NA_real_)
ci <- function(x, y) cor.test(x, y)$conf.int
cors[1, 3:4] <- as.list(ci(rates$打席あたり投球数, rates$打率))
cors[2, 3:4] <- as.list(ci(rates$打席あたり投球数, rates$長打率))
kable(cors, digits = 3)| 指標 | r | 95%信頼区間の下 | 95%信頼区間の上 |
|---|---|---|---|
| 打率 | -0.003 | -0.127 | 0.121 |
| 長打率 | 0.152 | 0.028 | 0.270 |
打率との相関は-0.003 (95%信頼区間 -0.13 〜 0.12), 長打率との相関は0.152 (0.03 〜 0.27)です.
打率との関係は信頼区間が0をまたいでおり, あるとも無いとも言えません. 長打率のほうは信頼区間が0を含まず, 弱いながら正の関係があります. 長打を狙う打者ほど追い込まれても粘る, といった説明が考えられますが, この分析では区別できません.
いずれにせよ1か月251人ぶんで, 幅も0.24 あります. 順位や大小をここから断定するのは無理です.
rates |>
ggplot(aes(x = 打率, y = 長打率)) +
geom_point(alpha = 0.6) +
stat_smooth(method = "lm", formula = y ~ x) +
ggtitle("打率と長打率")
打率と長打率は当然ながら強く相関します (r = 0.73). 長打率は安打を塁打で重み付けしたものなので, 定義上そうなります.
注意
- 2013年4月の1か月ぶんです. 打率の上位は運の割合が大きく, シーズンを通した順位とは別物です.
- 犠打・犠飛・四死球の扱いは打数の定義に従っています.
- 投球数は牽制などを除いていますが, Retrosheet の記録漏れまでは直せません.