← 記事一覧へ

打者を分類したい

「長距離砲」「アベレージヒッター」「巧打の1番打者」といった言い方をします. これは本当に分かれているのか, 分かれているとして何種類なのかを, データから決めます.

打率や本塁打の多い少ないではなく, 打席の結果の内訳で分けます. 良い打者と悪い打者ではなく, タイプの違いを取り出したいためです.

library(Lahman)
library(dplyr)
library(ggplot2)

SINCE <- 1970
QUAL  <- 300

season <- Batting %>%
  filter(yearID >= SINCE) %>%
  group_by(playerID, yearID) %>%
  dplyr::summarise(across(c(AB, H, X2B, X3B, HR, BB, SO, SB, HBP, SF, SH),
                          ~ sum(.x, na.rm = TRUE)), .groups = "drop") %>%
  mutate(PA = AB + BB + HBP + SF + SH) %>%
  filter(PA >= QUAL)

feat <- season %>%
  mutate(単打  = (H - X2B - X3B - HR) / PA,
         長打  = (X2B + X3B) / PA,
         本塁打 = HR / PA,
         四球  = BB / PA,
         三振  = SO / PA,
         盗塁  = SB / PA)

COLS <- c("単打", "長打", "本塁打", "四球", "三振", "盗塁")

時代を先に取り除く

そのまま標準化すると, 一番大きな違いは「時代」になります. 三振は年々増え, 盗塁は減っています. タイプの違いより時代の違いが大きいのです.

そこでその年の中で標準化します. 以降の値は「同じ年の打者の中で何σ離れているか」です.

z <- feat %>%
  group_by(yearID) %>%
  mutate(across(all_of(COLS), ~ as.numeric(scale(.x)))) %>%
  ungroup() %>%
  filter(if_all(all_of(COLS), ~ !is.na(.x)))

X <- as.matrix(z[, COLS])
pca <- prcomp(X)
data.frame(主成分 = paste0("PC", 1:length(pca$sdev)),
           寄与率 = sprintf("%.1f%%", 100 * pca$sdev^2 / sum(pca$sdev^2)),
           累積 = sprintf("%.1f%%", 100 * cumsum(pca$sdev^2) / sum(pca$sdev^2))) %>%
  knitr::kable(caption = "主成分の寄与率")
主成分の寄与率
主成分 寄与率 累積
PC1 38.9% 38.9%
PC2 17.3% 56.2%
PC3 16.1% 72.4%
PC4 13.8% 86.2%
PC5 8.2% 94.4%
PC6 5.6% 100.0% 
round(pca$rotation[, 1:2], 2) %>% as.data.frame() %>%
  knitr::kable(caption = "第1・第2主成分の負荷量")
第1・第2主成分の負荷量
PC1 PC2
単打 0.56 0.06
長打 0.07 -0.91
本塁打 -0.51 -0.21
四球 -0.37 0.30
三振 -0.47 0.05
盗塁 0.25 0.20

第1主成分は「本塁打」と「単打」が逆を向く軸, 第2主成分は「長打」と「四球」の軸です. 2つで全体の56%を説明します.

いくつに分けるか

k-means のクラスタ数は自分で決めます. 群内平方和が折れ曲がるところを探します.

set.seed(1)
wss <- sapply(1:8, function(k) kmeans(X, centers = k, nstart = 10, iter.max = 50)$tot.withinss)
data.frame(k = 1:8, wss = wss) %>%
  ggplot(aes(x = k, y = wss)) + geom_line() + geom_point() +
  xlab("クラスタ数") + ylab("群内平方和") +
  ggtitle("クラスタ数の候補")

K <- 4
set.seed(1)
km <- kmeans(X, centers = K, nstart = 50, iter.max = 100)
z$cluster <- factor(km$cluster)

はっきりした折れ曲がりはありません. 打者は本当は連続的に分布していて, 自然な区切りが無いということです. ここでは4つに切りますが, 4という数はデータが決めたものではありません.

各タイプの特徴

中心 (centroid) を見ます. 値は「同じ年の平均から何σ離れているか」です.

ctr %>%
  dplyr::select(タイプ, 人数, all_of(COLS)) %>%
  mutate(across(all_of(COLS), ~ round(.x, 2))) %>%
  knitr::kable(caption = "クラスタ中心 (単位はσ, 打者シーズン数)")
クラスタ中心 (単位はσ, 打者シーズン数)
タイプ 人数 単打 長打 本塁打 四球 三振 盗塁
1: 長打多・四球少 4003 -0.19 0.91 0.17 -0.25 0.05 -0.20
2: 単打多・本塁打少 4356 0.70 -0.40 -0.67 -0.41 -0.66 -0.30
3: 盗塁多・本塁打少 1671 0.77 -0.04 -0.78 -0.16 -0.34 2.05
4: 単打少・本塁打多 3805 -0.94 -0.48 0.93 0.80 0.84 -0.35 
z$タイプ <- factor(paste0(z$cluster, ": ", labels[km$cluster]))
pc <- as.data.frame(pca$x[, 1:2])
pc$タイプ <- z$タイプ
set.seed(2)
pc_s <- pc[sample(nrow(pc), min(3000, nrow(pc))), ]

ggplot(pc_s, aes(x = PC1, y = PC2, colour = タイプ)) +
  geom_point(alpha = 0.4, size = 0.8) +
  ggtitle("打者シーズンの分布 (第1・第2主成分)")

境目に選手がぎっしり詰まっています. 分類というより, 連続した雲に線を引いたものです.

時代でタイプの構成は変わったか

年ごとに, どのタイプが何割を占めるかを見ます.

share <- z %>%
  group_by(yearID, タイプ) %>%
  dplyr::summarise(n = n(), .groups = "drop_last") %>%
  mutate(比率 = n / sum(n)) %>%
  ungroup()

ggplot(share, aes(x = yearID, y = 比率, fill = タイプ)) +
  geom_area() +
  xlab("年") + ylab("構成比") +
  ggtitle("打者タイプの構成比")

chg %>%
  mutate(across(c(比率_旧, 比率_新, 差, ぶれ), ~ sprintf("%+.3f", .x))) %>%
  knitr::kable(caption = paste0("最初の5年と最後の5年の構成比 (", SINCE, "-", SINCE + 4,
                                " と ", max(share$yearID) - 4, "-", max(share$yearID),
                                "). 「ぶれ」は年ごとの構成比の標準偏差"))
最初の5年と最後の5年の構成比 (1970-1974 と 2021-2025). 「ぶれ」は年ごとの構成比の標準偏差
タイプ 比率_旧 比率_新 差 ぶれ
2: 単打多・本塁打少 +0.345 +0.313 -0.032 +0.021
1: 長打多・四球少 +0.258 +0.281 +0.023 +0.024
3: 盗塁多・本塁打少 +0.113 +0.121 +0.008 +0.013
4: 単打少・本塁打多 +0.283 +0.284 +0.001 +0.018

一番動いたのは「2: 単打多・本塁打少」で, 0.345から0.313へ -0.032です. ところがこの型の構成比は年ごとに 標準偏差0.021でぶれています. 55年かけた変化が, 1年ごとのぶれの 1.5倍にしかなりません.

構成比はほとんど変わっていない, というのがここでの結論です. ただしこれは「打者が変わっていない」という意味ではありません. 見ているのは同じ年の中での相対的な位置なので, 三振も本塁打も全体として増えていても, 打者の間の並び方が同じなら構成比は動きません. 実際の水準がどう動いたかは, 標準化する前の値で見る必要があります.

feat %>%
  group_by(yearID) %>%
  dplyr::summarise(三振 = mean(三振), 本塁打 = mean(本塁打),
                   盗塁 = mean(盗塁), .groups = "drop") %>%
  tidyr::pivot_longer(-yearID, names_to = "指標", values_to = "打席あたり") %>%
  ggplot(aes(x = yearID, y = 打席あたり, colour = 指標)) +
  geom_line() +
  xlab("年") + ggtitle("標準化する前の水準 (規定打席以上の打者の平均)")

水準は動いています. 打席あたりの三振は0.124から 0.218へ76%増えました. 全員が一緒に増えたので, タイプの構成比は変わらなかったわけです.

注意

  • クラスタ数4に統計的な根拠はありません. 群内平方和は滑らかに減るだけで, 自然な区切りは見つかりませんでした. 「打者は4種類いる」ではなく 「4つに切るとこう見える」と読んでください.
  • k-means は初期値で結果が変わります. nstart = 50 と乱数シードを固定しています.
  • タイプ名は中心から最も離れた2項目を機械的に並べたものです. 一般に使われる呼び名とは一致しません.
  • 「ぶれ」は年ごとの構成比の標準偏差です. 傾向的な変化ぶんも含むので, 純粋な偶然のばらつきより大きめに出ます. 「変化は小さい」という結論に対しては 厳しい側の見積もりなので, 結論の向きは変わりません.
  • 対象は300打席以上の打者シーズンです. 控え選手や, 故障で出場が減った シーズンは入っていません.
  • 打席の結果の内訳だけで分けています. 守備位置・打順・球場は使っていません.