wOBAcon移動平均値を利用した打球角度評価の検討3
Author: @sleep_in_nmbrs
2018-09-02
Last update: 18-10-14.
背景と目的
1でwOBAconの移動平均値を利用した理想角度からのずれが, その選手のwOBAconの改善や悪化とあまり関連が無さそうなことを確認した.
このような結果になった可能性として, サンプルが足りないため真の理想角度の推定が甘くなり, その結果, 移動平均値を利用した手法の予測力をマスクしている可能性が考えられる.
ここではこの理想角度について, 回帰の大きさを測定する.
まず年度間相関の強さを検討する. サンプルが足りていないのであれば, 大きく平均に回帰しているはずである.
さらにここで記述された方法で, 50%が回帰で失われる目安となる打球数を推定する.
年度間相関の計算
各年度で200BBE (打球数) 以上の打者について, 総打球の1/3のwOBAconの移動平均値を計算し, 最大化する角度, そして最大化する範囲におけるwOBAconを計算する.
まず各年度における打撃成績を計算する. ここでの目的は主に打球数を数えることである.
# data (df2) はstatcast data 15-18のレギュラーシーズン. 18-10-02取得
# 使用したパッケージ: tidyverse, knitr, kableExtra, cowplot
# 打撃成績を計算
# 不要な部分も面倒なので残してある
df2 <- df2 %>% mutate(player_id = paste(player_name, game_year, sep = "-"),
# 必要なflagをつくる
HR_FL = ifelse(events == "home_run", 1, 0),
PU_FL = ifelse(bb_type == "popup", 1, 0),
# xwOBA計算のための変数を作る
xwoba_value = ifelse(type == "X",
estimated_woba_using_speedangle,
woba_value))%>%
filter(! grepl("bunt", des))# bunt除く失策と野選は除けてない
bat <- df2 %>%
filter(type == "X")%>%
filter(events != "sac_bunt")%>%
group_by(player_name, game_year)%>%
dplyr::summarise(speed_mean = mean(launch_speed, na.rm = TRUE),
angle_mean = mean(launch_angle, na.rm = TRUE),
wOBA_value = sum(woba_value, na.rm = TRUE),
xwOBA_value = sum(xwoba_value, na.rm = TRUE),
wOBA_denom = sum(woba_denom, na.rm = TRUE),
wOBA = wOBA_value / wOBA_denom,
xwOBA = xwOBA_value / wOBA_denom,
iso = sum(iso_value, na.rm = TRUE) / wOBA_denom,
HR_bb =sum(HR_FL, na.rm = TRUE) / wOBA_denom,
PU_bb = sum(PU_FL, na.rm = TRUE) / wOBA_denom
)%>%
mutate(player_id = paste(player_name, game_year, sep = "-"))%>%
filter(wOBA_denom >= 200)理想角度を計算するが, 1, 2と違って年度ごとにわけている.
# dfを渡して移動平均値を取得する関数を設定
# あとで個人別に計算する
compute.player.stats <- function(df = df){
data <- df %>%
arrange(launch_angle)
width <- round(length(data$woba_value) / 3)
mov <- stats::filter(data$woba_value, c(rep(1, width)))
mov <- as.numeric(mov/ width)
result <- data.frame(data,
mov_avg = mov)
max_woba <- result %>%
arrange(desc(mov_avg))%>%
select(player_name, game_year, launch_angle, mov_avg)
return(max_woba)
}
# 要らないデータを捨てる
df.qualified <- df2 %>%
filter(type == "X")%>%
filter(is.na(launch_angle) == FALSE, is.na(launch_speed) == FALSE,
player_id %in% bat$player_id) # 200 BBE/year以上
# # 全員に適用
# all.angle <- df.qualified%>%
# group_by(player_id)%>% # player_id (name + year) でグルーピング
# do(compute.player.stats(df = .)) # 各選手に上で設定した関数を適用し, dfで返す
#
# best.angle <- all.angle%>%
# group_by(player_id)%>%
# slice(., 1) # 同様に各選手のもっとも範囲が高いwOBAを持つ移動平均範の中心を取得
#
# save(list=c("all.angle", "best.angle"),
# file="wobacon_mov_avg_result_by_year_1_15-18.Rdata")
load("wobacon_mov_avg_result_by_year_1_15-18.Rdata")
# 得られた打撃成績に計算した, 各年度における理想角度をjoin.
bbe <- bat %>% select(player_name, game_year, angle_mean,speed_mean,
wOBA_denom, wOBA, xwOBA, PU_bb)
names(bbe) <- c("player_name","game_year", "mean_angle", "mean_velo",
"BBE", "wOBAcon", "xwOBAcon","PUpct")
bbe <- left_join(best.angle, bbe) %>%
mutate(angle_diff = mean_angle - launch_angle, # 実際 - 理想
wOBA_diff = wOBAcon - mov_avg )%>% # 実際 - 理想
arrange(desc(wOBA_diff))年度間相関を計算するためにテーブルを組み直して, データの一部を示す.
# 年度間で比較可能なように組み直す
years <- c(2015, 2016, 2017)
df.xy <- NULL
for(i in years){
df.x <- bbe %>% filter(game_year == i)
df.y <- bbe %>% filter(game_year == (i + 1 ))
df.xy.ij <- inner_join(df.x, df.y, by = c("player_name"))
df.xy <- rbind(df.xy, df.xy.ij)
}
df.xy <- mutate(df.xy,
target_angle_diff = launch_angle.y - launch_angle.x,
mean_angle_diff = mean_angle.y - mean_angle.x,
angle_gap_diff = angle_diff.y - angle_diff.x,
moving_diff = mov_avg.y - mov_avg.x,
wOBAcon_diff = wOBAcon.y - wOBAcon.x,
PUpct_diff = PUpct.y - PUpct.x)
# 一部を示す
df.xy %>%
select(player_name, game_year.x, launch_angle.x, game_year.y, launch_angle.y)%>%
head(10)%>%
rename("理想角度x年" = launch_angle.x,
"game_year.x+1" = game_year.y,
"理想角度x+1年" = launch_angle.y)%>%
mutate_if(is.numeric, funs(round), 1)%>%
kable()%>%
kable_styling(bootstrap_options = "striped", full_width = F)| player_id.x | player_name | game_year.x | 理想角度x年 | game_year.x+1 | 理想角度x+1年 |
|---|---|---|---|---|---|
| Ichiro Suzuki-2015 | Ichiro Suzuki | 2015 | 9.7 | 2016 | 12.5 |
| Billy Hamilton-2015 | Billy Hamilton | 2015 | 16.3 | 2016 | 9.1 |
| Jordy Mercer-2015 | Jordy Mercer | 2015 | 13.2 | 2016 | 15.1 |
| Michael Bourn-2015 | Michael Bourn | 2015 | 15.8 | 2016 | 17.6 |
| Ben Revere-2015 | Ben Revere | 2015 | 12.5 | 2016 | 15.8 |
| Alexei Ramirez-2015 | Alexei Ramirez | 2015 | 14.3 | 2016 | 16.9 |
| Elvis Andrus-2015 | Elvis Andrus | 2015 | 8.1 | 2016 | 15.3 |
| Jose Altuve-2015 | Jose Altuve | 2015 | 14.6 | 2016 | 20.4 |
| Brandon Belt-2015 | Brandon Belt | 2015 | 17.6 | 2016 | 20.7 |
| Xander Bogaerts-2015 | Xander Bogaerts | 2015 | 15.1 | 2016 | 17.4 |
描画
散布図を描画し, 全体の傾向と回帰の強さを把握する.
ggplot(df.xy,
aes(x =launch_angle.x,
y = launch_angle.y,
colour = mean_angle_diff)) +
scale_color_gradient(low = "green2", high = "magenta3")+
geom_point(size = 0.8) +
geom_smooth(method ="lm") +
theme_bw(base_family = "HiraKakuPro-W3") +
theme(axis.text.x = element_text(size=12),
axis.text.y = element_text(size=12)) +
geom_vline(xintercept = mean(df.xy$launch_angle.x), linetype = 2)+
geom_hline(yintercept = mean(df.xy$launch_angle.y), linetype = 2)+
background_grid(major = "xy", minor = "y",
size.major = 0.5, colour.major = "gray",
size.minor = 0.3, colour.minor = "gray")+
labs(title = "各打者の理想角度.",
subtitle = "色で実際の平均角度の変化を示す. 破線は平均値.
MLB15-18で打球200以上 (N = 632).",
x = "理想角度_x", y = "理想角度_x+1",
colour = "平均角度の変化")
相関自体は有意だと思われるが, 線形回帰の傾きはやや小さい. 平均値はx年度とx+1年度で18°程度で概ね一致している. しかし, 回帰直線を見ると, x年度の理想角度が10°だった選手はx+1年度の平均は15°となっており, 半分程度が失われている. これは推定が甘いデータの平均への回帰を見ているのだろう.
これはBBE200程度のデータ数で極端な理想角度を記録した選手がいても, その選手の次の年の理想角度はその値と平均値の中間程度と推定したほうがあたりやすいということである.
また, 角度を上昇させた選手で, 理想角度が上昇している. どういうことかはよくわからないが.
ついでなので理想角度範囲内のwOBAconの値の方も軽く見ておく.
ggplot(df.xy,
aes(x = mov_avg.x,
y = mov_avg.y,
colour = mean_angle_diff)) +
scale_color_gradient(low = "green2", high = "magenta3")+
geom_point(size = 0.8) +
geom_smooth(method ="lm") +
theme_bw(base_family = "HiraKakuPro-W3") +
theme(axis.text.x = element_text(size=12),
axis.text.y = element_text(size=12)) +
geom_vline(xintercept = mean(df.xy$mov_avg.x), linetype = 2)+
geom_hline(yintercept = mean(df.xy$mov_avg.y), linetype = 2)+
labs(title = "各打者の理想範囲wOBA.",
subtitle = "色で実際の平均角度の変化を示す. 破線は平均値.
MLB15-18で打球200以上 (N = 632).",
x = "理想範囲wOBA_x", y = "理想範囲wOBA_x+1",colour = "平均角度変化")
角度自体よりは相関が高そうである. x年度の値が1でもx+1年度の値は0.9強程度で, xとx+1年度は平均0.8弱でだいたい一致しているようだが, 傾きとしては半分弱が失われている. とはいえ打撃指標としてはまあまあ相関は高い部類ではないか.
単回帰
理想角度について決定係数etc.を計算しておく.
linfit.launch_angle <- lm(launch_angle.x ~ launch_angle.y, data = df.xy)
summary(linfit.launch_angle)##
## Call:
## lm(formula = launch_angle.x ~ launch_angle.y, data = df.xy)
##
## Residuals:
## Min 1Q Median 3Q Max
## -10.7250 -1.9344 0.2344 2.2284 8.6691
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 9.01424 0.68484 13.16 <2e-16 ***
## launch_angle.y 0.48945 0.03684 13.29 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 3.191 on 630 degrees of freedom
## Multiple R-squared: 0.2188, Adjusted R-squared: 0.2176
## F-statistic: 176.5 on 1 and 630 DF, p-value: < 2.2e-16散布図を見ればわかる通り有意であり, また決定係数R^2 = 0.22程度.
R^2 = 0.22ならRは0.5弱である. 一応計算.
with(df.xy, cor.test(launch_angle.x, launch_angle.y))##
## Pearson's product-moment correlation
##
## data: launch_angle.x and launch_angle.y
## t = 13.285, df = 630, p-value < 2.2e-16
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
## 0.4045845 0.5265910
## sample estimates:
## cor
## 0.4678135理想角度の相関の強さは, 他の指標と比較するとどの程度か? Bill Pettiは01-07においてPA300以上の打者について様々な指標の相関を報告している (PA300ならだいたいBBE200程度で一致している). BAが0.4程度, wOBA or OBPが0.6程度なのでその中間ぐらい. 相関自体はそこまで大きいわけでは無いが, かといって一般的な打撃指標のレベルと比べて大きく低いわけではない.
ついでに範囲内wOBAconのほう.
linfit.mov_avg <- lm(mov_avg.x ~ mov_avg.y, data = df.xy)
summary(linfit.mov_avg)##
## Call:
## lm(formula = mov_avg.x ~ mov_avg.y, data = df.xy)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.252344 -0.054465 -0.002189 0.047052 0.290188
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.26944 0.02455 10.97 <2e-16 ***
## mov_avg.y 0.64667 0.03216 20.11 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.08528 on 630 degrees of freedom
## Multiple R-squared: 0.3909, Adjusted R-squared: 0.3899
## F-statistic: 404.3 on 1 and 630 DF, p-value: < 2.2e-16R^2 = 0.39で理想角度よりも決定係数が大きい.
実データからのもう少し精密な推定
上の年度間相関では, 各選手の打席数が異なる, 年度間で打者の能力や環境に違いがあるといった理由があり, 回帰の大きさの推定値としてはやや問題がある.
Tangoは, 実データから回帰の大きさを計算する方法を記述している. これを参考にして, 理想角度の回帰の大きさを推定した.
方法は大まかには:
- 一定の打席数N (例えば200PAなど. wOBAconの場合は打球数BBEを使う) 以上の選手を取り出す
- これらの一定の打席数以上をもつ選手について, ランダムに一定の打席数Nだけを取り出す
- 取り出した打席数のランダムに半分ずつにわけ, それぞれでの成績を計算
- それらの間の相関を調べる
ここで得られた相関係数をRとすると,
\[A=\frac{(1-R)}R* N*\frac{1}{2}\]
を満たすAが平均との差を1/2失う打席数となり, 実際に計算されたある選手の数値をvalue, 打席数をPA, 回帰すべき平均をaverageとすると, 単純な成績よりも妥当性の高い点推定値Estimated valueは
\[Estimated\ value = value - (value - average) * \frac{A}{PA + A}\] となる. 見ての通り, 右辺の右が回帰で失われる部分で, PAがAに比べて十分に大きくなればこの部分が0に近づくため, Estimated valueはvalueとほぼ一致する.
打球数200から50刻みに1200まで, それぞれについてRやAの値を計算した. ランダムサンプリングをしたため, 結果がサンプリングエラーでばらつく. そのため, 同一の打球数について6回ずつ計算しばらつきを確認した. 計算方法については後で示すが, ここではその結果を呼び出して示す. Nはそれぞれの閾値のBBE以上を持つ打者の数である. 相関係数Rに加えて, 線形回帰直線の傾きSlopeと切片Interceptも示した. 一応全て示すが, スキップ推奨.
load("ideal_angle_regress_15-18.Rdata")
regress%>%
mutate_all(funs(round), 3)%>%
rename(BBE = Denom,
"平均理想角度_x" = Avg_x,
"平均理想角度_y" = Avg_y)%>%
kable()%>%
kable_styling(bootstrap_options = "striped", full_width = F)| BBE | N | 平均理想角度_x | 平均理想角度_y | R | Slope | Intercept | A |
|---|---|---|---|---|---|---|---|
| 200 | 546 | 16.981 | 17.246 | 0.279 | 0.259 | 12.846 | 258.126 |
| 200 | 546 | 17.228 | 17.213 | 0.236 | 0.232 | 13.214 | 322.925 |
| 200 | 546 | 16.792 | 16.935 | 0.336 | 0.319 | 11.577 | 197.739 |
| 200 | 546 | 16.851 | 17.144 | 0.294 | 0.282 | 12.395 | 240.173 |
| 200 | 546 | 17.283 | 17.074 | 0.326 | 0.314 | 11.644 | 206.458 |
| 200 | 546 | 17.038 | 17.110 | 0.315 | 0.324 | 11.584 | 217.302 |
| 250 | 505 | 16.796 | 16.927 | 0.345 | 0.339 | 11.227 | 237.808 |
| 250 | 505 | 17.104 | 17.017 | 0.350 | 0.333 | 11.321 | 232.533 |
| 250 | 505 | 17.142 | 16.848 | 0.306 | 0.312 | 11.499 | 283.978 |
| 250 | 505 | 16.726 | 17.006 | 0.330 | 0.308 | 11.850 | 254.031 |
| 250 | 505 | 17.162 | 16.973 | 0.372 | 0.385 | 10.370 | 211.222 |
| 250 | 505 | 16.828 | 16.912 | 0.362 | 0.367 | 10.741 | 220.005 |
| 300 | 465 | 17.405 | 17.167 | 0.441 | 0.443 | 9.455 | 190.480 |
| 300 | 465 | 17.135 | 17.065 | 0.384 | 0.390 | 10.382 | 240.646 |
| 300 | 465 | 17.628 | 17.160 | 0.364 | 0.368 | 10.671 | 261.693 |
| 300 | 465 | 17.100 | 16.983 | 0.429 | 0.406 | 10.039 | 199.263 |
| 300 | 465 | 17.195 | 17.164 | 0.406 | 0.401 | 10.266 | 219.078 |
| 300 | 465 | 17.255 | 17.220 | 0.365 | 0.387 | 10.549 | 261.009 |
| 350 | 434 | 17.344 | 17.401 | 0.370 | 0.334 | 11.614 | 297.695 |
| 350 | 434 | 17.337 | 17.492 | 0.392 | 0.377 | 10.958 | 271.617 |
| 350 | 434 | 17.324 | 17.217 | 0.398 | 0.366 | 10.881 | 264.294 |
| 350 | 434 | 17.457 | 17.316 | 0.405 | 0.413 | 10.112 | 257.461 |
| 350 | 434 | 17.457 | 17.366 | 0.344 | 0.357 | 11.138 | 333.744 |
| 350 | 434 | 17.308 | 17.319 | 0.412 | 0.394 | 10.498 | 249.302 |
| 400 | 411 | 17.441 | 17.830 | 0.481 | 0.486 | 9.353 | 215.579 |
| 400 | 411 | 17.639 | 17.835 | 0.384 | 0.393 | 10.908 | 320.825 |
| 400 | 411 | 17.690 | 17.697 | 0.393 | 0.415 | 10.361 | 308.733 |
| 400 | 411 | 17.700 | 17.540 | 0.391 | 0.407 | 10.332 | 311.027 |
| 400 | 411 | 17.167 | 17.556 | 0.354 | 0.345 | 11.627 | 364.689 |
| 400 | 411 | 17.624 | 17.604 | 0.400 | 0.399 | 10.577 | 300.056 |
| 450 | 382 | 17.509 | 17.907 | 0.454 | 0.473 | 9.630 | 270.486 |
| 450 | 382 | 17.972 | 17.851 | 0.449 | 0.441 | 9.919 | 276.512 |
| 450 | 382 | 17.468 | 17.726 | 0.454 | 0.450 | 9.858 | 270.526 |
| 450 | 382 | 17.645 | 17.541 | 0.396 | 0.423 | 10.085 | 343.845 |
| 450 | 382 | 17.796 | 17.719 | 0.412 | 0.412 | 10.383 | 321.243 |
| 450 | 382 | 17.486 | 17.933 | 0.421 | 0.397 | 10.987 | 309.086 |
| 500 | 356 | 17.987 | 17.807 | 0.453 | 0.454 | 9.649 | 301.713 |
| 500 | 356 | 18.027 | 17.927 | 0.458 | 0.474 | 9.381 | 296.147 |
| 500 | 356 | 17.753 | 17.941 | 0.482 | 0.460 | 9.782 | 268.576 |
| 500 | 356 | 17.771 | 17.892 | 0.430 | 0.454 | 9.832 | 331.774 |
| 500 | 356 | 17.671 | 18.079 | 0.424 | 0.419 | 10.674 | 339.577 |
| 500 | 356 | 17.862 | 17.689 | 0.434 | 0.421 | 10.166 | 326.348 |
| 550 | 334 | 17.799 | 17.702 | 0.525 | 0.547 | 7.963 | 248.772 |
| 550 | 334 | 17.692 | 17.775 | 0.455 | 0.466 | 9.530 | 329.240 |
| 550 | 334 | 17.625 | 17.770 | 0.502 | 0.462 | 9.624 | 273.322 |
| 550 | 334 | 18.036 | 17.821 | 0.523 | 0.575 | 7.456 | 250.692 |
| 550 | 334 | 17.617 | 17.549 | 0.478 | 0.475 | 9.179 | 299.750 |
| 550 | 334 | 17.692 | 17.824 | 0.465 | 0.494 | 9.091 | 316.707 |
| 600 | 316 | 17.840 | 17.782 | 0.476 | 0.471 | 9.387 | 330.661 |
| 600 | 316 | 17.705 | 17.707 | 0.503 | 0.492 | 8.993 | 296.334 |
| 600 | 316 | 17.656 | 17.917 | 0.498 | 0.516 | 8.809 | 302.858 |
| 600 | 316 | 17.895 | 17.878 | 0.515 | 0.446 | 9.890 | 282.888 |
| 600 | 316 | 18.084 | 17.597 | 0.427 | 0.438 | 9.675 | 402.729 |
| 600 | 316 | 17.875 | 17.930 | 0.409 | 0.405 | 10.689 | 432.897 |
| 650 | 296 | 17.812 | 17.659 | 0.571 | 0.629 | 6.452 | 244.198 |
| 650 | 296 | 17.909 | 17.712 | 0.471 | 0.469 | 9.317 | 365.571 |
| 650 | 296 | 17.766 | 17.958 | 0.499 | 0.517 | 8.766 | 325.948 |
| 650 | 296 | 17.997 | 17.715 | 0.536 | 0.538 | 8.027 | 281.157 |
| 650 | 296 | 17.788 | 17.777 | 0.529 | 0.442 | 9.906 | 289.284 |
| 650 | 296 | 17.590 | 17.791 | 0.465 | 0.455 | 9.784 | 374.517 |
| 700 | 280 | 18.211 | 18.138 | 0.477 | 0.458 | 9.789 | 384.404 |
| 700 | 280 | 17.605 | 18.174 | 0.505 | 0.468 | 9.928 | 342.988 |
| 700 | 280 | 17.972 | 18.205 | 0.494 | 0.450 | 10.112 | 358.484 |
| 700 | 280 | 18.098 | 18.011 | 0.480 | 0.462 | 9.653 | 379.706 |
| 700 | 280 | 17.854 | 18.050 | 0.465 | 0.421 | 10.539 | 403.161 |
| 700 | 280 | 18.014 | 17.879 | 0.562 | 0.570 | 7.615 | 272.770 |
| 750 | 264 | 18.021 | 17.732 | 0.435 | 0.463 | 9.391 | 488.044 |
| 750 | 264 | 18.257 | 18.221 | 0.473 | 0.460 | 9.830 | 417.907 |
| 750 | 264 | 18.040 | 18.098 | 0.538 | 0.560 | 7.988 | 321.906 |
| 750 | 264 | 18.080 | 17.866 | 0.511 | 0.503 | 8.779 | 358.539 |
| 750 | 264 | 18.091 | 18.178 | 0.499 | 0.540 | 8.407 | 375.943 |
| 750 | 264 | 18.183 | 17.940 | 0.470 | 0.475 | 9.298 | 423.214 |
| 800 | 256 | 18.173 | 18.008 | 0.445 | 0.434 | 10.123 | 499.814 |
| 800 | 256 | 17.902 | 18.052 | 0.531 | 0.558 | 8.059 | 352.875 |
| 800 | 256 | 18.061 | 17.850 | 0.506 | 0.508 | 8.672 | 391.082 |
| 800 | 256 | 18.052 | 18.028 | 0.533 | 0.516 | 8.723 | 351.040 |
| 800 | 256 | 18.096 | 17.674 | 0.505 | 0.555 | 7.622 | 392.027 |
| 800 | 256 | 18.083 | 18.047 | 0.522 | 0.530 | 8.463 | 366.996 |
| 850 | 236 | 18.086 | 18.153 | 0.491 | 0.514 | 8.857 | 440.601 |
| 850 | 236 | 18.122 | 18.192 | 0.508 | 0.492 | 9.278 | 410.911 |
| 850 | 236 | 17.887 | 18.134 | 0.475 | 0.448 | 10.125 | 470.133 |
| 850 | 236 | 17.835 | 17.970 | 0.472 | 0.484 | 9.334 | 475.098 |
| 850 | 236 | 18.113 | 18.126 | 0.535 | 0.575 | 7.714 | 369.952 |
| 850 | 236 | 18.009 | 18.064 | 0.553 | 0.551 | 8.147 | 343.761 |
| 900 | 222 | 18.083 | 18.240 | 0.546 | 0.531 | 8.642 | 374.412 |
| 900 | 222 | 17.990 | 17.894 | 0.567 | 0.547 | 8.050 | 343.300 |
| 900 | 222 | 17.977 | 17.985 | 0.607 | 0.632 | 6.632 | 291.839 |
| 900 | 222 | 18.002 | 18.008 | 0.588 | 0.578 | 7.601 | 315.100 |
| 900 | 222 | 18.158 | 18.128 | 0.579 | 0.587 | 7.465 | 327.509 |
| 900 | 222 | 17.839 | 18.249 | 0.532 | 0.518 | 9.008 | 395.599 |
| 950 | 208 | 18.103 | 18.172 | 0.538 | 0.575 | 7.758 | 407.266 |
| 950 | 208 | 18.081 | 18.294 | 0.505 | 0.502 | 9.225 | 465.318 |
| 950 | 208 | 18.062 | 17.879 | 0.502 | 0.492 | 8.984 | 471.954 |
| 950 | 208 | 17.887 | 18.089 | 0.531 | 0.523 | 8.743 | 420.132 |
| 950 | 208 | 18.080 | 18.079 | 0.507 | 0.544 | 8.247 | 461.452 |
| 950 | 208 | 18.159 | 18.263 | 0.557 | 0.586 | 7.624 | 377.881 |
| 1000 | 200 | 18.166 | 18.027 | 0.521 | 0.544 | 8.148 | 459.786 |
| 1000 | 200 | 18.278 | 18.180 | 0.523 | 0.563 | 7.893 | 456.760 |
| 1000 | 200 | 18.184 | 18.057 | 0.570 | 0.567 | 7.752 | 376.717 |
| 1000 | 200 | 18.015 | 18.105 | 0.612 | 0.712 | 5.273 | 317.440 |
| 1000 | 200 | 18.319 | 17.938 | 0.498 | 0.520 | 8.418 | 503.930 |
| 1000 | 200 | 18.231 | 18.173 | 0.540 | 0.535 | 8.421 | 426.567 |
| 1050 | 193 | 18.142 | 18.248 | 0.631 | 0.674 | 6.028 | 307.599 |
| 1050 | 193 | 17.881 | 18.155 | 0.596 | 0.543 | 8.441 | 356.342 |
| 1050 | 193 | 18.106 | 18.074 | 0.565 | 0.506 | 8.910 | 404.660 |
| 1050 | 193 | 17.915 | 18.306 | 0.548 | 0.516 | 9.069 | 433.209 |
| 1050 | 193 | 18.162 | 18.198 | 0.586 | 0.572 | 7.816 | 370.263 |
| 1050 | 193 | 18.121 | 18.167 | 0.518 | 0.524 | 8.666 | 488.296 |
| 1100 | 184 | 18.332 | 18.217 | 0.536 | 0.518 | 8.722 | 476.920 |
| 1100 | 184 | 17.954 | 18.085 | 0.509 | 0.503 | 9.060 | 531.394 |
| 1100 | 184 | 18.200 | 18.298 | 0.592 | 0.595 | 7.466 | 378.810 |
| 1100 | 184 | 18.473 | 18.253 | 0.562 | 0.520 | 8.641 | 428.861 |
| 1100 | 184 | 18.194 | 18.232 | 0.563 | 0.576 | 7.746 | 427.416 |
| 1100 | 184 | 18.016 | 18.415 | 0.532 | 0.524 | 8.970 | 483.089 |
| 1150 | 162 | 17.989 | 18.320 | 0.706 | 0.651 | 6.603 | 239.773 |
| 1150 | 162 | 18.166 | 18.220 | 0.621 | 0.628 | 6.816 | 350.918 |
| 1150 | 162 | 18.351 | 18.176 | 0.550 | 0.581 | 7.517 | 470.302 |
| 1150 | 162 | 18.117 | 18.251 | 0.618 | 0.580 | 7.744 | 355.905 |
| 1150 | 162 | 17.995 | 18.192 | 0.556 | 0.514 | 8.944 | 458.921 |
| 1150 | 162 | 17.900 | 18.157 | 0.551 | 0.530 | 8.676 | 469.407 |
| 1200 | 152 | 18.303 | 18.000 | 0.637 | 0.637 | 6.345 | 342.315 |
| 1200 | 152 | 18.317 | 18.230 | 0.631 | 0.621 | 6.860 | 350.635 |
| 1200 | 152 | 18.137 | 18.229 | 0.513 | 0.481 | 9.497 | 569.520 |
| 1200 | 152 | 18.233 | 18.079 | 0.561 | 0.481 | 9.307 | 470.423 |
| 1200 | 152 | 18.152 | 18.300 | 0.592 | 0.600 | 7.417 | 412.660 |
| 1200 | 152 | 18.082 | 17.968 | 0.563 | 0.657 | 6.092 | 466.373 |
情報量が多すぎるため, Aの値をプロットして示す.
同一のBBE閾値での結果についてもそれなりにばらつきは大きいため, 複数回計算するのは必要だろう. BBE閾値がAと相関がありそう. それぞれの閾値について打者プールが異なるために, 各打者間で真の理想角度自体の差が異なるなどの理由がありうるかもしれない (例えばプール内での差が大きければ少ないBBEで検出可能).
それぞれの打球数に関して, Aの値の平均 (A_avg) や誤差範囲を示す.
regress%>%
group_by(Denom)%>%
dplyr::summarise(N = n(),
A_avg = mean(A),
SD = sd(A),
CI_95_upper = A_avg + SD /sqrt(N) * qt(0.975, df = N-1),
CI_95_lower = A_avg - SD /sqrt(N) * qt(0.975, df = N-1)
)%>%
rename(BBE = Denom)%>%
mutate_all(funs(round))%>%
kable()%>%
kable_styling(bootstrap_options = "striped", full_width = F)| BBE | N | A_avg | SD | CI_95_upper | CI_95_lower |
|---|---|---|---|---|---|
| 200 | 6 | 240 | 46 | 289 | 192 |
| 250 | 6 | 240 | 26 | 267 | 212 |
| 300 | 6 | 229 | 31 | 261 | 197 |
| 350 | 6 | 279 | 32 | 312 | 246 |
| 400 | 6 | 303 | 49 | 355 | 252 |
| 450 | 6 | 299 | 31 | 331 | 266 |
| 500 | 6 | 311 | 27 | 339 | 283 |
| 550 | 6 | 286 | 34 | 322 | 251 |
| 600 | 6 | 341 | 62 | 406 | 276 |
| 650 | 6 | 313 | 51 | 367 | 260 |
| 700 | 6 | 357 | 46 | 405 | 308 |
| 750 | 6 | 398 | 58 | 459 | 336 |
| 800 | 6 | 392 | 56 | 451 | 334 |
| 850 | 6 | 418 | 54 | 475 | 362 |
| 900 | 6 | 341 | 38 | 382 | 301 |
| 950 | 6 | 434 | 38 | 474 | 394 |
| 1000 | 6 | 424 | 67 | 494 | 353 |
| 1050 | 6 | 393 | 63 | 460 | 327 |
| 1100 | 6 | 454 | 54 | 511 | 398 |
| 1150 | 6 | 391 | 92 | 488 | 294 |
| 1200 | 6 | 435 | 85 | 525 | 346 |
多くの打球数では300-400程度となった.
これは要するにPA600-800以上の選手を集め, それを半分ずつに分けたときにRが0.5ぐらいだろう, というようなイメージである. Rの平均値や誤差範囲を見てみる.
regress%>%
group_by(Denom)%>%
dplyr::summarise(N = n(),
R_avg = mean(R),
SD = sd(R),
CI_95_upper = R_avg + SD /sqrt(N) * qt(0.975, df = N-1),
CI_95_lower = R_avg - SD /sqrt(N) * qt(0.975, df = N-1)
)%>%
rename(BBE = Denom)%>%
mutate_all(funs(round), 3)%>%
kable()%>%
kable_styling(bootstrap_options = "striped", full_width = F)| BBE | N | R_avg | SD | CI_95_upper | CI_95_lower |
|---|---|---|---|---|---|
| 200 | 6 | 0.298 | 0.037 | 0.336 | 0.259 |
| 250 | 6 | 0.344 | 0.024 | 0.369 | 0.319 |
| 300 | 6 | 0.398 | 0.033 | 0.432 | 0.364 |
| 350 | 6 | 0.387 | 0.025 | 0.414 | 0.360 |
| 400 | 6 | 0.401 | 0.043 | 0.445 | 0.356 |
| 450 | 6 | 0.431 | 0.025 | 0.457 | 0.405 |
| 500 | 6 | 0.447 | 0.022 | 0.470 | 0.424 |
| 550 | 6 | 0.491 | 0.030 | 0.523 | 0.460 |
| 600 | 6 | 0.471 | 0.043 | 0.517 | 0.426 |
| 650 | 6 | 0.512 | 0.041 | 0.555 | 0.469 |
| 700 | 6 | 0.497 | 0.035 | 0.534 | 0.460 |
| 750 | 6 | 0.488 | 0.036 | 0.526 | 0.450 |
| 800 | 6 | 0.507 | 0.033 | 0.541 | 0.472 |
| 850 | 6 | 0.506 | 0.033 | 0.540 | 0.471 |
| 900 | 6 | 0.570 | 0.027 | 0.599 | 0.541 |
| 950 | 6 | 0.523 | 0.022 | 0.547 | 0.500 |
| 1000 | 6 | 0.544 | 0.041 | 0.587 | 0.501 |
| 1050 | 6 | 0.574 | 0.039 | 0.615 | 0.533 |
| 1100 | 6 | 0.549 | 0.029 | 0.580 | 0.518 |
| 1150 | 6 | 0.600 | 0.061 | 0.665 | 0.536 |
| 1200 | 6 | 0.583 | 0.047 | 0.632 | 0.533 |
BBEが650-800程度でRが0.5くらいとなっている.
とりあえずAの値を300として, 仮に理想角度が25°となった打者を考え, その打者の回帰を考慮した推定理想角度を打球数に対する関数としてグラフで示す.
A <- 300
average <- 17
angle.regress <- data.frame(BBE = seq(10, 2000, 10),
Ideal_angle = 25)%>%
mutate(Regress_amount = A / (BBE + A) * (Ideal_angle - average),
Estimated_ideal_angle = Ideal_angle - Regress_amount)
ggplot(angle.regress,
aes(x = BBE,
y = Estimated_ideal_angle)) +
geom_line(aes(group = 1))+
theme_bw(base_family = "HiraKakuPro-W3") +
background_grid(major = "xy", minor = "xy",
size.major = 0.5, colour.major = "gray",
size.minor = 0.3, colour.minor = "gray")+
geom_vline(xintercept = 300, linetype = 2, colour = "red")+
geom_hline(yintercept = 25)+
ylim(17, 25)+
theme(axis.text.x = element_text(size=10),
axis.text.y = element_text(size=10)) +
labs(title = "理想角度25°の打者における回帰を考慮した理想角度.",
subtitle = "回帰すべき平均は17とした. 打球数300で半分を回帰で失う.",
x = "打球数BBE", y = "回帰を考慮した理想角度"
)
MLB一年における打球数はせいぜい400-500というところだが, これぐらいの数ではまだ回帰の影響がかなり大きい. より妥当性を上げるには例えば1000打球以上などにすることも効果があるかもしれない. しかし, 実用上を考えると, MLBフルシーズンの打球数でもそれほど信用できないというのはなかなか厄介である. 仮にこの指標が十分なサンプルサイズをもつ集団で多少効果があったとしても, それだけの打席数にたったならそれはもはや立派なレギュラーであり, 好きに打ってもらうのが良さそうなものである.
まとめ
理想角度の値は打撃指標としては比較的よくある程度の年度間相関の大きさを示している. とはいえ, それなりに回帰の影響は大きい. また, 分母が打球なので, 打席数に比べてサンプル数が1/3程度小さくなるため, 打席数を分母に取るような指標よりは推定は甘くなりがちなのではないか.
この推定の甘さによって, 計算された理想角度の影響が観測しづらくなっている可能性はありそうだが, 回帰の大きさは通常の指標とかけ離れるほど大きいわけではなく, その程度の影響で隠されてしまうのであれば, 仮に予測力があったとしてもその効果は小さいと言うことだろう.
実データからの推定の計算
以下の計算では重複を許さないでサンプリングしたが, 許したほうが良かったかもしれない.
# 与えられたdfからN行分サンプリングして
# データをランダムに2分割してそれぞれの成績を計算する関数
# これをあとで個人別に適用する
compute.stat.via.sampling <- function(df = df,
N = 200){
# 受け取ったdfからN行をサンプリング
player.df <- df %>%
sample_n(N)
player <- df$player_name[1]
# それをさらに２つに分ける
rows.x <- sample(N, N * 0.5)
player.df.x <- player.df[rows.x, ]
player.df.y <- player.df[-rows.x, ]
# dfを渡してそのデータ内の理想角度を計算して返す関数
# 別の指標での回帰の大きさの推定に使うときにはココを書き換える
compute.player.stats <- function(df = df){
data <- df %>%
arrange(launch_angle)
width <- round(length(data$woba_value) / 3)
mov <- stats::filter(data$woba_value, c(rep(1, width)))
mov <- as.numeric(mov/ width)
result <- data.frame(data,
mov_avg = mov)
max_woba <- result %>%
arrange(desc(mov_avg))%>%
select(player_name, launch_angle, mov_avg)%>%
slice(1)
return(max_woba)
}
# 分割したdfそれぞれについて打撃成績を計算
result.x <- player.df.x %>%
compute.player.stats()
result.y <- player.df.y %>%
compute.player.stats()
# 対象選手の結果をまとめる
result <- data.frame(Stats_x = as.numeric(result.x[,2]),
Stats_y = as.numeric(result.y[,2]))
return(result)
}
# 使用例
# バントはすでに除かれている
df2 %>%
filter(type =="X")%>%
filter(player_name == "David Ortiz")%>%
compute.stat.via.sampling()## Stats_x Stats_y
## 1 19.105 17.794# あとでgroup_byからdoで渡す# 下で線形回帰の結果を取り出す
# 1. statcast data,
# 2. N (denominator),
# 3. 繰り返し計算回数
# を与えて, 線形回帰の結果を取り出す関数を設定
compute.cor.regression <- function(df = df,
N = 200,
rep = 2){
# 打球系では無い場合このあたりをPAなりABなりにする
# 規定Nを満たした打者を探す
qualified <- df %>%
filter(type == "X")%>%
group_by(player_name)%>%
dplyr::summarise(wOBA_denom = sum(woba_denom, na.rm = TRUE))%>%
filter(wOBA_denom >= N)
# pitch-by-pitch dataを規定クリア打者の打球に絞る
df.qualified <- df%>%
filter(type == "X",
player_name %in% qualified$player_name)
# 上で作ったdf (df.qualified) を渡して,
# compute.stat.via.samplingを選手別に適用し,
# その全選手の結果から相関係数などを取り出す関数
compute.cor.statistic <- function(df = df,
N = N){
stats.xy <- df %>%
group_by(player_name) %>% # player_nameでグルーピング
do(compute.stat.via.sampling(df = ., N = N)) # 分割したdfそれぞれに関数を適用してdfで返す
linfit <- lm(Stats_y ~ Stats_x, data = stats.xy)
res <- data.frame(Denom = N,
N =nrow(stats.xy),
Avg_x = mean(stats.xy$Stats_x),
Avg_y = mean(stats.xy$Stats_y),
R = cor(stats.xy$Stats_x, stats.xy$Stats_y),
Slope = round(linfit[[1]][2], digits = 3),
Intercept = round(linfit[[1]][1], digits = 3))%>%
mutate(A = (1- R) / R * Denom /2)
return(res)
}
# rep回数分計算してdfで保存
out <- 1:rep %>%
map(~compute.cor.statistic(df = df.qualified , N = N))%>%
bind_rows()
return(out)
}
# doがprogress barを出すけど繰り返しで出るのでうっとうしい
# 下をFALSEに設定すると出なくなる
options(dplyr.show_progress = FALSE)
# 下をコメントアウトして計算
# # seq()の数列をNとして一つずつ渡して関数を計算し, それらの結果をdfとして保存
# regress <- seq(200, 1200, 50) %>%
# map(~compute.cor.regression(df = df2, N = ., rep = 6))%>%
# bind_rows()
save(regress, file="ideal_angle_regress_15-18.Rdata")