wOBAcon上位の選手ごとの計算結果を示し, 一部極端な傾向を持つ選手などの結果を可視化する. データはStatcast 15-18のレギュラーシーズンでバントは基本的には除いている.

これのsupplement的な位置づけ.

前処理

# dataは18-10-02取得
require(cowplot)
require(knitr)
require(reshape2)
require(tidyverse)
require(gridExtra)
require(kableExtra)
typeX <- df2 %>%
  filter(type == "X")%>%
  filter(! grepl("bunt", des))%>% # bunt除く 全部は除けてないかも
  mutate(bb_FL = ifelse(type == "X", 1, 0),
         PU_FL = ifelse(bb_type == "popup", 1, 0),
         FB_FL = ifelse(bb_type == "fly_ball", 1, 0),
         GB_FL = ifelse(bb_type == "ground_ball", 1, 0),
         LD_FL = ifelse(bb_type == "line_drive", 1, 0),
         HR_FL = ifelse(events == "home_run", 1, 0),
         xWOBA_value = ifelse(type == "X", estimated_woba_using_speedangle, woba_value))

bat.X <- typeX %>%
  group_by(player_name, game_year)%>%
  dplyr::summarise(speed_mean = mean(launch_speed, na.rm = TRUE),
                   speed_sd = sd(launch_speed, na.rm = TRUE),
                   angle_mean = mean(launch_angle, na.rm = TRUE),
                   angle_sd = sd(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,
                   BABIP = sum(babip_value) / (wOBA_denom - sum(HR_FL, na.rm = TRUE)),
                   iso = sum(iso_value, na.rm = TRUE) / wOBA_denom, # ISOcon
                   HR_BBE =sum(HR_FL, na.rm = TRUE) / wOBA_denom, 
                   GB_BBE = sum(GB_FL, na.rm = TRUE)/ wOBA_denom,
                   FB_BBE = sum(FB_FL, na.rm = TRUE)/ wOBA_denom,
                   LD_BBE = sum(LD_FL, na.rm = TRUE)/ wOBA_denom,
                   PU_BBE = sum(PU_FL, na.rm = TRUE)/ wOBA_denom,
                   barrel_CT = sum(barrel),
                   barrel_rate = barrel_CT / wOBA_denom)

bb_value_by_players <- typeX%>%
  group_by(player_name, game_year, bb_type)%>%
  dplyr::summarise(N = sum(woba_denom, na.rm = TRUE),
                   wOBAcon = sum(woba_value, na.rm = TRUE)/N)

bb_value_by_players <- bb_value_by_players %>% 
  select(- N)%>%
  spread(key = bb_type, value = wOBAcon)

bat.X <- bat.X %>%
  left_join(bb_value_by_players)

wOBAcon leaders

年度別に計算したwOBAcon上位50人 (150打球以上) を示す.

bat.X %>%
  filter(wOBA_denom >= 150)%>%
  arrange(desc(wOBA))%>%
  select(player_name, game_year, wOBA, xwOBA, speed_mean, speed_sd, angle_mean, angle_sd)%>%
  mutate_if(is.numeric, funs(round), 3)%>%
  rename(wOBAcon = wOBA, xwOBAcon = xwOBA)%>%
  head(50)%>%
  kable()%>%
  kable_styling(bootstrap_options = "striped", full_width = F)
player_name game_year wOBAcon xwOBAcon speed_mean speed_sd angle_mean angle_sd
Aaron Judge 2017 0.621 0.626 94.868 16.384 15.766 24.501
J.D. Martinez 2017 0.592 0.571 90.985 15.573 15.247 24.609
Miguel Sano 2015 0.591 0.565 94.006 12.893 16.438 25.505
Joey Gallo 2017 0.569 0.567 93.305 15.619 22.934 26.055
Miguel Sano 2017 0.563 0.523 92.287 15.720 13.215 27.061
J.D. Martinez 2018 0.556 0.551 92.964 13.365 10.643 22.682
Giancarlo Stanton 2015 0.556 0.553 95.939 14.857 15.492 27.356
Bryce Harper 2015 0.548 0.466 91.265 14.640 14.682 24.834
Aaron Judge 2018 0.547 0.551 94.747 14.921 12.274 23.993
Chris Davis 2015 0.547 0.563 92.124 12.775 17.490 22.451
Mike Zunino 2017 0.546 0.490 90.325 15.890 20.478 27.102
Randal Grichuk 2015 0.539 0.467 92.293 13.180 15.943 26.296
Trevor Story 2016 0.537 0.500 90.961 13.852 17.374 25.750
Mike Trout 2018 0.536 0.520 91.193 15.586 18.547 23.886
Tyler Naquin 2016 0.534 0.445 91.000 13.443 10.431 23.901
Max Muncy 2018 0.533 0.534 90.367 14.152 18.027 23.552
Giancarlo Stanton 2017 0.530 0.491 91.909 16.936 11.065 30.496
Shohei Ohtani 2018 0.525 0.520 92.917 14.303 12.378 24.306
Christian Yelich 2018 0.523 0.504 92.599 13.615 4.948 24.048
Mike Trout 2015 0.523 0.511 92.845 14.040 14.060 21.916
Freddie Freeman 2016 0.522 0.515 91.405 12.692 17.372 22.125
Paul Goldschmidt 2015 0.518 0.476 92.097 12.315 12.968 23.790
Nelson Cruz 2015 0.517 0.482 92.372 14.529 9.541 25.536
Mike Trout 2017 0.517 0.472 88.787 16.294 18.040 25.924
Justin Upton 2017 0.516 0.466 88.676 15.042 15.694 25.705
Paul Goldschmidt 2018 0.516 0.502 90.643 13.596 15.661 26.274
Trevor Story 2018 0.515 0.471 91.003 13.662 16.011 26.329
Chris Colabello 2015 0.514 0.437 90.095 13.743 9.616 25.999
Charlie Blackmon 2017 0.514 0.433 87.269 14.855 13.184 25.506
Mookie Betts 2018 0.513 0.506 92.293 12.188 18.448 25.243
Kris Bryant 2015 0.512 0.451 89.618 14.228 19.420 24.487
Javier Baez 2018 0.512 0.461 90.417 14.300 9.622 27.082
Michael Conforto 2017 0.510 0.480 89.145 15.506 13.596 29.283
Bryce Harper 2017 0.510 0.458 91.073 14.381 14.076 24.951
Mike Trout 2016 0.507 0.484 90.827 13.716 12.934 23.007
Domingo Santana 2017 0.506 0.474 89.290 13.488 10.516 21.682
Cody Bellinger 2017 0.506 0.473 90.780 13.973 17.433 27.296
Ian Happ 2017 0.506 0.461 88.512 15.401 13.120 24.720
Daniel Palka 2018 0.505 0.469 92.323 16.616 11.512 27.752
Ronald Acuna Jr. 2018 0.505 0.484 90.907 14.686 13.071 27.074
Khris Davis 2017 0.503 0.536 92.241 14.204 14.178 26.983
J.D. Martinez 2016 0.502 0.503 91.451 13.547 13.365 22.494
Michael A. Taylor 2017 0.502 0.421 87.490 16.038 12.225 26.069
Jake Cave 2018 0.502 0.516 89.216 13.200 10.453 21.335
Ryan Schimpf 2016 0.501 0.445 90.236 12.597 30.082 26.891
Miguel Sano 2016 0.501 0.472 92.279 12.945 16.568 27.375
Paul DeJong 2017 0.500 0.444 86.417 16.088 18.306 25.847
Jorge Alfaro 2018 0.500 0.460 91.627 14.700 8.209 25.032
Paul Goldschmidt 2017 0.500 0.482 91.433 13.583 11.582 24.949
Eric Thames 2017 0.499 0.441 88.219 15.405 12.913 28.685

一部打者の結果を可視化

コンタクト系指標の一部をプロットするための関数を設定する. 基本的にはAlbertのコードを転用している.

plot.contact.stats <- function(data = bat.x, player, 
                               qualify = 200,  # 本人以外の図に含める結果の最低打球数
                               exclude = 2014){ # 除く年度を指定. 打球数が少ない場合削ったほうが見やすい.
  data %>% filter(player_name == player) %>%
    group_by(game_year)%>%
    filter(! game_year %in% exclude) -> pdata
  
  data %>% filter(game_year %in% pdata$game_year) %>%
    group_by(game_year, player_name) %>%
    filter(wOBA_denom >= qualify)  -> S1
  
  top.text <- paste(player, "contact stats")
  
  TH <- theme(
    plot.title = element_text(
      colour = "black",
      size = 12,
      hjust = 0.5,
      vjust = 0.8,
      angle = 0
    ))
  
  p1 <- ggplot(S1, aes(x = game_year, 
                       y = wOBA)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, wOBA, 
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("wOBAcon") + TH + xlab("") + ylab("wOBAcon")+
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
  
  p2 <- ggplot(S1, aes(game_year, xwOBA)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, xwOBA,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("xwOBAcon") + TH + xlab("") + ylab("xwOBAcon")+
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
      
  
  p3 <- ggplot(S1, aes(game_year, barrel_rate)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, barrel_rate,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("Barrel rate") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
  
  p4 <- ggplot(S1, aes(game_year, speed_mean)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, speed_mean,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("速度平均") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
  
  p5 <- ggplot(S1, aes(game_year, speed_sd)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, speed_sd,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("速度SD") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
  p6 <- ggplot(S1, aes(game_year, angle_mean)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, angle_mean,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("角度平均") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     
                                     hjust = 1))
  p7 <- ggplot(S1, aes(game_year, angle_sd)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, angle_sd,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("角度SD") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
    p8 <- ggplot(S1, aes(game_year, fly_ball)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, fly_ball,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("FB wOBAcon") + TH + xlab("") + ylab("FB wOBAcon")+
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
    
  p9 <- ggplot(S1, aes(game_year, line_drive)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, line_drive,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("LD wOBAcon") + TH + xlab("") + ylab("LD wOBAcon")+
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
  
    p10 <- ggplot(S1, aes(game_year, ground_ball)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, ground_ball,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("GB wOBAcon") + TH + xlab("") + ylab("GB wOBAcon")+
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
    
      
  p11 <- ggplot(S1, aes(game_year, BABIP)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, BABIP,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("BABIP") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
    
    p12 <- ggplot(S1, aes(game_year, FB_BBE)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, FB_BBE,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("FB/BBE") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
    
    p13 <- ggplot(S1, aes(game_year, LD_BBE)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, LD_BBE,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("LD/BBE") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
    
    p14 <- ggplot(S1, aes(game_year, PU_BBE)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, PU_BBE,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("PU/BBE") + TH + xlab("") +
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
    p15 <- ggplot(S1, aes(game_year, wOBA_denom)) +
    geom_boxplot() +
    geom_point(data = pdata,
               aes(game_year, wOBA_denom,
                   group=player_name),
               color="red", size=2) +
    theme_classic(base_family = "HiraKakuPro-W3")+
    theme(axis.text.x = element_text(size=8),
          axis.text.y = element_text(size=8),
          axis.title = element_text(size = 10)) +
    ggtitle("BBE") + TH + xlab("") + ylab("BBE")+
    theme(axis.text.x = element_text(angle = 60, 
                                     hjust = 1))
    


  grid.arrange(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15,
               ncol=5,
               top= top.text)
}

オオタニサンを例に示す.

plot.contact.stats(data = bat.X, player = "Shohei Ohtani")

この図ではMLB各年度において200打球数以上の選手の結果を箱ひげ図で示し, 黒のドットでその外れ値となっている選手が示されている. 本人の成績は赤のドットで示されている. 大谷の場合, リーグのレギュラークラスの打者と比較して, 速度の平均が非常に優秀であったこと, 速度と角度のSDも優秀であったことがわかる.

角度に関してみると, 一般的には, 平均が平均的でSDが低めであれば, LDの増加や, PUの低下が予想され, BABIPが高めになるタイプの打者である可能性が高い. 影響は少なくとも符号のレベルでは, モデルから予想される効果と一致している. ただし, 打球タイプ%の予測モデルはそれなりに説明できていない部分も残っており (特にLD%), 必ずしも一致するとは限らない. また, ここで観測されている中位値からの解離がモデルから予測される一般的効果の大きさと一致しているかどうかは, この図からはわからない. 大谷に関しては, 起用法の関係上あらゆるデータがサンプル数不足に陥りがちである. ここでもご多分に漏れず打球数は少なめであることが確認できる. 本人のパラメータの点推定としてはあまり信用できない.

といった感じで各選手について図で示す. 説明は面倒なので省く. 打球数が少ない年度は極端な結果に繋がりやすく, 図が見づらくなるため除いている.

バランスタイプ.

plot.contact.stats(data = bat.X, player = "Mike Trout")

plot.contact.stats(data = bat.X, player = "J.D. Martinez")

速度ヤバイタイプ.

plot.contact.stats(data = bat.X, player = "Giancarlo Stanton")

plot.contact.stats(data = bat.X, player = "Aaron Judge")

角度SDの人.

plot.contact.stats(data = bat.X, player = "Joey Votto")

角度, 速度ともに大きいタイプ.

plot.contact.stats(data = bat.X, player = "Joey Gallo", exclude = 2015:2016)

角度SDが大きいタイプ.

plot.contact.stats(data = bat.X, player = "Kevin Kiermaier")

plot.contact.stats(data = bat.X, player = "Austin Hedges", exclude = 2015:2016)

逆方向で良い成績を残すタイプ.

plot.contact.stats(data = bat.X, player = "David Freese")

plot.contact.stats(data = bat.X, player = "Joe Mauer")

Reference

Statcast data are property of MLB advanced media.

Albert, Tribute to 2018 HOF Inductees, 2018.