今回は年齢と成績の関係について見ていきます。
初回でも紹介したセイバーメトリクス入門には野手は26～27歳、投手は21歳が成績のピークとありました。
ただ成績のピークを出す計算方法が正直よくわからないので、手持ちのデータでいくつか簡単に出せたものを紹介します。
ますは野手から。
野手の個人成績のデータを読み込みます。
library(openxlsx)
datH<-read.xlsx("C:/Users/ユーザー名/Downloads/hitter_data.xlsx",sheet="Sheet1")
head(datH)
> head(datH)
選手名 生年月日 投打 投 打 守備 出身地 身長 血液型 体重
1 栗原健太(くりはらけんた) 29959 右投右打 右 右 内野手 山形 183 O 95
2 東出輝裕(ひがしであきひろ) 29454 右投左打 右 左 内野手 福井 171 A 73
3 嶋重宣(しましげのぶ) 27927 左投左打 左 左 外野手 埼玉 181 A 95
4 石原慶幸(いしはらよしゆき) 29105 右投右打 右 右 捕手 岐阜 177 A 82
5 緒方孝市(おがたこういち) 25197 右投右打 右 右 外野手 佐賀 181 A 80
6 フィリップス(あんでぃふぃりっぷす) 28221 右投右打 右 右 内野手 アメリカ 183 不明 93
年俸 年度 リーグ 球団 試合数 打席数 打数 得点 安打 二塁打 三塁打 本塁打 塁打 打点 盗塁
1 13000 2009 セリーグ 広島東洋 140 582 521 68 134 21 0 23 224 79 1
2 10000 2009 セリーグ 広島東洋 142 625 558 71 164 16 8 0 196 26 14
3 5500 2009 セリーグ 広島東洋 89 198 175 12 40 9 0 2 55 17 3
4 5000 2009 セリーグ 広島東洋 124 422 364 31 75 15 1 10 122 37 2
5 4500 2009 セリーグ 広島東洋 53 60 49 2 9 1 1 0 12 7 2
6 4000 2009 セリーグ 広島東洋 74 301 264 35 70 15 1 15 132 50 0
盗塁刺 犠打 犠飛 四球 死球 三振 併殺打 打率 出塁率 長打率 OPS
1 6 0 2 48 7 82 11 0.257 0.327 0.430 0.757
2 7 19 3 44 1 39 5 0.294 0.345 0.351 0.696
3 1 0 5 15 3 34 7 0.229 0.293 0.314 0.607
4 3 11 4 39 4 90 11 0.206 0.287 0.335 0.622
5 0 0 1 9 1 2 0 0.184 0.317 0.245 0.562
6 0 0 5 27 5 48 7 0.265 0.339 0.500 0.839
生年月日が数値になっているのでデータを扱いやすい形に整形します。
library(tidyverse)
datH<-datH %>%
mutate(生年月日=as.Date(生年月日, origin = "1899-12-30")) %>%
mutate(生年=year(生年月日)) %>%
mutate(生月=month(生年月日))
スタッツを追加します。
datH2<-datH %>%
mutate(年齢=年度-生年)%>%
mutate(単打=安打-二塁打-三塁打-本塁打) %>%
mutate(wOBA=(0.9*単打+1.3*二塁打+1.6*三塁打+2.0*本塁打+0.7*(四球+死球))/(打数+四球+死球+犠飛)) %>%
年齢のデータですが、シーズン終了に近い10月～12月生まれの選手を－1歳で補正します。
datH2<-datH2 %>%
mutate(年齢2=if_else(生月>=10, true = 年齢-1,false = 年齢))
まずはシンプルにwOBAを見てみます。
年齢とwOBA
ggplot(data=datH2,aes(x=年齢2,y=wOBA))+
geom_point()+labs(x="年齢",y="wOBA")+
scale_x_continuous(breaks = seq(min(datH2$年齢2),max(datH2$年齢2),by = 1),minor_breaks = NULL)+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
見にくいので0.5までで拡大表示します。
年齢とwOBA（0.5までの拡大）
ggplot(data=datH2,aes(x=年齢2,y=wOBA))+
geom_point()+labs(x="年齢",y="wOBA")+
scale_x_continuous(breaks = seq(min(datH2$年齢2),max(datH2$年齢2),by = 1),minor_breaks = NULL)+
coord_cartesian(ylim = c(0, 0.5))+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
成績のピークが35歳くらいになっていて実態とはかけ離れた結果になってます。
長く活躍できている選手のデータに引っ張られている感じですね。
ここで補正方法を考えます。
まず、ボールや何らかの原因で年度毎に全体的に成績の上下があるので、年ごとの平均の成績との差を出していきます。
年度ごとのwOBAの平均との差を算出
#年度ごとに平均を算出
datH2_1 <-datH2 %>%
select(年度,wOBA)%>%
na.omit %>%
group_by (年度) %>%
summarise(平均wOBA=mean(wOBA))
#元のデータと結合する
datH2_2 <- left_join(datH2, datH2_1, by = "年度")
#平均との差を算出
datH2_3<-datH2_2 %>%
mutate(wOBAの差=wOBA-平均wOBA)
次に選手ごとにキャリアの最高値と最低値を算出し、最高値を1、最低値が0になるように計算し直します。このとき1年しか成績のない選手は除きます。
キャリアの最高値と最低値を算出
datH2_4 <-datH2_3 %>%
group_by (選手名) %>%
summarise(最低wOBA=min(平均wOBAとの差),最高wOBA=max(平均wOBAとの差),出場年=n())
#元のデータと結合
datH2_5 <- left_join(datH2_3, datH2_4, by = "選手名")
#最高値を1、最低値が0になるように計算
datH2_6<-datH2_5 %>%
mutate(補正wOBA=平均wOBAとの差-最低wOBA,wOBAのレンジ=最高wOBA-最低wOBA) %>%
mutate(相対wOBA=補正wOBA/wOBAのレンジ) %>%
filter(出場年>=2)
グラフに描画
ggplot(data=datH2_6,aes(x=年齢2,y=相対wOBA))+
geom_point()+labs(x="年齢",y="相対wOBA")+
scale_x_continuous(breaks = seq(min(datH2_6$年齢2),max(datH2_6$年齢2),by = 1),minor_breaks = NULL)+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
27歳あたりがピークになってますね。かなり分析結果と近い値になってます。
上手く補正できたのではないでしょうか。
打てなければ出してもらえないので単純に打席数で見てみればよいのではと思ってやってみたらきれいな釣り鐘型になりました。
年齢と合計打席数
ggplot(data=datH6,aes(x=年齢2,y=合計打席数))+
geom_point()+labs(x="年齢",y="合計打席数")+
scale_x_continuous(breaks = seq(min(datH6$年齢2),max(datH6$年齢2),by = 1),minor_breaks = NULL)+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
これもかなり分析結果と近い値になってます。
こうなるともうセイバーメトリクスではないですが笑
各年齢の人数も見てみます。
年齢と選手数
ggplot(data=datH6,aes(x=年齢2,y=人数))+
geom_point()+labs(x="年齢",y="人数")+
scale_x_continuous(breaks = seq(min(datH6$年齢2),max(datH6$年齢2),by = 1),minor_breaks = NULL)+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
26～27歳がピークですかね。
いずれにせよ20代後半の選手の出場機会が多くなっているように見えます。
投手の方も見ていきます。
datP<-read.xlsx("C:/Users/ユーザー名/Downloads/pitcher_data.xlsx",sheet="Sheet1")
head(datP)
> head(datP)
選手名 生年月日 投打 投 打 守備 出身地 身長 血液 体重 年俸
1 ウォーランド(れすうぉーらんど) 28071 左投左打 左 左 投手 アメリカ 191 不明 93 7000
2 グリン(らいあんぐりん) 27334 右投右打 右 右 投手 アメリカ 190 不明 89 8400
3 マストニー(とむますとにー) 29621 右投右打 右 右 投手 インドネシア 198 不明 100 8000
4 阿斗里(おおたあとり) 32732 右投右打 右 右 投手 沖縄 190 A 95 580
5 横山道哉(よこやまゆきや) 28277 右投右打 右 右 投手 神奈川 190 A 98 2500
6 加藤康介(かとうこうすけ) 28673 左投左打 左 左 投手 静岡 181 O 83 960
年度 リーグ 球団 試合 勝利 敗北 セーブ ホールド HP 完投 完封勝 無四球 打者 投球回 被安打
1 2009 セリーグ 横浜 21 5 10 0 NA NA 1 0 0 505 110.666 128
2 2009 セリーグ 横浜 23 3 15 0 NA NA 0 0 0 521 118.000 135
3 2009 セリーグ 横浜 15 1 5 0 NA NA 0 0 0 296 61.666 79
4 2009 セリーグ 横浜 1 0 0 0 NA NA 0 0 0 11 2.000 2
5 2009 セリーグ 横浜 14 0 0 0 NA NA 0 0 0 66 15.000 19
6 2009 セリーグ 横浜 31 1 0 0 NA NA 0 0 0 127 29.333 21
被本塁打 与四球 与死球 奪三振 暴投 ボーク 失点 自責点 防御率 WHIP
1 10 50 4 85 4 1 63 59 4.80 1.61
2 17 35 4 69 5 3 73 67 5.11 1.44
3 8 25 11 43 6 0 45 39 5.69 1.69
4 0 2 0 1 1 0 1 1 4.50 2.00
5 2 4 0 12 0 0 9 8 4.80 1.53
6 5 18 2 37 1 0 13 12 3.68 1.33
打者と同じようにデータを加工していきます。
#生年月日のデータを加工する
datP<-datP %>%
mutate(生年月日=as.Date(生年月日, origin = "1899-12-30")) %>%
mutate(生年=year(生年月日)) %>%
mutate(生月=month(生年月日))
#スタッツを追加する
datP2<-datP %>%
mutate(年齢=年度-生年)%>%
#年齢を補正する
datP2<-datP2 %>%
mutate(年齢2=if_else(生月>=10, true = 年齢-1,false = 年齢))
もうなんとなくわかってきましたが一応見ていきます。
年齢と防御率
ggplot(data=datP2,aes(x=年齢2,y=防御率))+
geom_point()+labs(x="年齢",y="防御率")+
scale_x_continuous(breaks = seq(min(datP2$年齢2),max(datP2$年齢2),by = 1),minor_breaks = NULL)+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
年齢と防御率（10までで拡大）
ggplot(data=datP2,aes(x=年齢2,y=防御率))+
geom_point()+labs(x="年齢",y="防御率")+
scale_x_continuous(breaks = seq(min(datP2$年齢2),max(datP2$年齢2),by = 1),minor_breaks = NULL)+
coord_cartesian(ylim = c(0, 10))+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
24歳くらいからほぼ5くらいで一定ですね。野手と同じく長く活躍できている選手のデータに引っ張られている感じがします。やはり指標をそのまま使うのは厳しいですね。
野手のwOBAと同じように補正していきます。
防御率を0～1で補正
datP2_1 <-datP2 %>%
select(年度,防御率)%>%
na.omit %>%
group_by (年度) %>%
summarise(平均防御率=mean(防御率))
datP2_2 <- left_join(datP2, datP2_1, by = "年度")
datP2_3<-datP2_2 %>%
mutate(平均防御率との差=防御率-平均防御率)
datP2_4 <-datP2_3 %>%
group_by (選手名) %>%
summarise(最低防御率=min(平均防御率との差),最高防御率=max(平均防御率との差),出場年=n())
datP2_5 <- left_join(datP2_3, datP2_4, by = "選手名")
datP2_6<-datP2_5 %>%
mutate(補正防御率=平均防御率との差-最低防御率,防御率のレンジ=最高防御率-最低防御率) %>%
mutate(相対防御率=補正防御率/防御率のレンジ) %>%
filter(出場年>=2)
#グラフに描画
ggplot(data=datP2_6,aes(x=年齢2,y=相対防御率))+
geom_point()+labs(x="年齢",y="相対防御率")+
scale_x_continuous(breaks = seq(min(datP2_6$年齢2),max(datP2_6$年齢2),by = 1),minor_breaks = NULL)+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
24～25歳がピークという結果になりました。
野手と比べるとちょっと早めかなという感じですが、防御率が21歳がピークというセイバーメトリクス入門の分析結果とは3歳分くらい違いがありますね。
投球回を見てみます。
年齢と合計投球回
datP6 <-datP2 %>%
group_by (年齢2) %>%
summarise(合計投球回=sum(投球回),人数=n())
ggplot(data=datP6,aes(x=年齢2,y=合計投球回))+
geom_point()+labs(x="年齢",y="合計投球回")+
scale_x_continuous(breaks = seq(min(datP6$年齢2),max(datP6$年齢2),by = 1),minor_breaks = NULL)+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
27歳がピークですね。
人数も見てみます。
年齢と選手数
ggplot(data=datP6,aes(x=年齢2,y=人数))+
geom_point()+labs(x="年齢",y="人数")+
scale_x_continuous(breaks = seq(min(datP6$年齢2),max(datP6$年齢2),by = 1),minor_breaks = NULL)+
geom_smooth(method = "lm", formula = y ~ splines::bs(x, 6))+
theme_bw()
26歳ちょっとがピークでしょうか。
カープの投手の回で見たのは一流の選手が多いのでそこまで極端な感じはしませんでしたが、投手の場合、高卒でいきなり1軍で投げるような選手は甲子園で活躍した選手達でほぼほぼ完成しているような選手が多い気しますし、大卒即戦力とか言われて入ってくる選手も多いので、野手と比べると若いうちから活躍している選手が多い気がします。
とはいえ、実際には26歳前後の選手が多く出場しているわけなので、やっぱり21歳がピークというのは気になります。
ちょっと気になっていたのが早生まれの選手が少ないという情報です。
せっかくデータがあるので調べてみました。
野手を重複を省いて生まれた月で集計
datH7<- datH2%>%
distinct(選手名, .keep_all=T) %>%
group_by (生月) %>%
summarise(人数=n())
ggplot(data=datH7,aes(x=as.factor(生月),y=人数))+
geom_bar(stat = "identity")+labs(x="生まれ月",y="人数")+
theme_bw()
圧倒的に4月～8月ぐらいの生まれが多いですね。
20歳くらいにもなれば生まれたタイミングなんてほとんど差なさそうな気がしますが、やっぱり早生まれは不利なのかもしれません。しかしここまでとは。
投手も見てみます。
投手を重複を省いて生まれた月で集計
datP7<- datP2%>%
distinct(選手名, .keep_all=T) %>%
group_by (生月) %>%
summarise(人数=n())
ggplot(data=datP7,aes(x=as.factor(生月),y=人数))+
geom_bar(stat = "identity")+labs(x="生まれ月",y="人数")+
theme_bw()
野手ほどの差はないですがそれでも2～3月は少ないですね。