Switch branches/tags
Nothing to show
Find file History
Fetching latest commit…
Cannot retrieve the latest commit at this time.
Permalink
..
Failed to load latest commit information.
figure
GL2015.TXT
README.md
all2015.csv.tar.gz
excite.Rmd
excite.html
home_win_prob_chn2015070270.png
names.csv
rbi_wpa.png
win_prob.csv

README.md

エキサイティング度合いを勝利確率変動で見よう

library(dplyr)
library(readr)
library(ggplot2)
library(Lahman)
library(data.table)

fullname_batid =
  Master %>% 
  mutate(FULLNAME = paste(nameFirst, nameLast)) %>% 
  mutate(BAT_ID = retroID) %>% 
  select(BAT_ID, FULLNAME)
## データを作る
pbpData = fread("all2015.csv", header=FALSE)
namedata = fread("names.csv", header = FALSE) %>% unlist
names(pbpData) = namedata

## 勝率テーブル
winProbData = read_csv("win_prob.csv")
## 内容
winProbData %>% head %>%
  xtable::xtable() %>% print("html")
INN_CT BAT_HOME_ID OUTS_CT RUNNERS HOME_AWAY HOME_LOSES GAMES HOME_WINS
1 1 0 0 0 -8 1 1 0
2 1 0 0 0 -7 1 1 0
3 1 0 0 0 -6 10 10 0
4 1 0 0 0 -5 26 30 4
5 1 0 0 0 -4 137 164 27
6 1 0 0 0 -3 272 363 91
1行目は、

1回表、0アウトランナー無し、アウェイで8点負けている状況という試合が1つあった、ということです。

HOME-AWAYのフィールドが点差を表しています。

## 10点差以上は10にまとめる
winProbDataMod = 
  winProbData %>% 
  mutate(HOME_AWAY_MOD = ifelse(abs(HOME_AWAY) > 10, sign(HOME_AWAY) * 10, HOME_AWAY)) %>% 
  group_by(INN_CT,BAT_HOME_ID, OUTS_CT, RUNNERS, HOME_AWAY_MOD) %>% 
  summarise(HOME_LOSES = sum(HOME_LOSES),
            GAMES = sum(GAMES),
            HOME_WINS = sum(HOME_WINS)) %>% 
  ungroup()

## 内容確認
winProbDataMod %>% 
  select(HOME_AWAY_MOD) %>%
  table

. -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 409 421 479 515 559 646 692 762 833 893 1028 384 388 384 384 5 6 7 8 9 10 384 384 381 373 365 362

## 勝率に変換
winProbData = 
  winProbDataMod %>% 
  mutate(HOME_WIN_PROB = HOME_WINS / GAMES) %>%
  mutate(AWAY_WIN_PROB = HOME_LOSES / GAMES) %>% 
  select(-(HOME_LOSES:HOME_WINS))
## 内容確認
winProbData %>% 
  head(9) %>% 
  xtable::xtable() %>% print("html")
INN_CT BAT_HOME_ID OUTS_CT RUNNERS HOME_AWAY_MOD HOME_WIN_PROB AWAY_WIN_PROB
1 1 0 0 0 -8.00 0.00 1.00
2 1 0 0 0 -7.00 0.00 1.00
3 1 0 0 0 -6.00 0.00 1.00
4 1 0 0 0 -5.00 0.13 0.87
5 1 0 0 0 -4.00 0.16 0.84
6 1 0 0 0 -3.00 0.25 0.75
7 1 0 0 0 -2.00 0.30 0.70
8 1 0 0 0 -1.00 0.43 0.57
9 1 0 0 0 0.00 0.53 0.47

9行目は、試合開始時点を表しています。

ホームの勝率が53.25%となっています。

主催側のチームが有利、ということですが、3.25%程度です。

もっと差がつくかと思っていました。

Play−by−Playデータと結合

pbpData_for_merge = 
  pbpData %>% 
  mutate(RUNNERS = (BASE3_RUN_ID != "") * 100 + (BASE2_RUN_ID !="")*10 + (BASE1_RUN_ID !="")*1) %>%
  mutate(HOME_AWAY = HOME_SCORE_CT - AWAY_SCORE_CT) %>%
  mutate(HOME_AWAY_MOD = ifelse(abs(HOME_AWAY) > 10, sign(HOME_AWAY) * 10, HOME_AWAY)) 
pbpData_winProb = 
  pbpData_for_merge %>% 
  merge(winProbData, by = c("INN_CT","BAT_HOME_ID", "OUTS_CT", "RUNNERS", "HOME_AWAY_MOD"), all.x = TRUE) %>% as.data.table %>% 
  arrange(GAME_ID, EVENT_ID)

HOMEのチームが勝ったか負けたかを調べておきます。

dat = fread("GL2015.TXT", header=FALSE)
winLoseData = 
  dat %>% 
  mutate(GAME_ID = paste(V7, V1, V2, sep="")) %>%
  mutate(HOME_SCORE = V11, AWAY_SCORE = V10) %>% 
  mutate(HOME_WIN_FLG = HOME_SCORE > AWAY_SCORE) %>% 
  select(GAME_ID, HOME_SCORE, AWAY_SCORE, HOME_WIN_FLG)

pbpData_winProb_winLose = 
  pbpData_winProb %>% 
  merge(winLoseData, by = "GAME_ID")

試合ごとに勝率変動を調べてみます。

pbpData_winProb_winLose_winProbMove = 
  pbpData_winProb_winLose %>% 
  group_by(GAME_ID) %>% 
  mutate(WIN_PROB_MOVE = diff(c(HOME_WIN_PROB, HOME_WIN_FLG))) %>% 
  as.data.table

最も勝率変動の大きかった試合

勝率変動の絶対値の総和を計算して、エキサイティングな試合を評価してみます。

勝率変動の絶対値の総和が大きい、上位5試合です。

pbpData_winProb_winLose_winProbMove %>% 
  group_by(GAME_ID) %>% 
  summarise(EXCITING_SCORE = sum(abs(WIN_PROB_MOVE))) %>% 
  arrange(desc(EXCITING_SCORE)) %>%
  select(GAME_ID, EXCITING_SCORE) %>% 
  head(5) %>%
  xtable::xtable() %>% print("html")
GAME_ID EXCITING_SCORE
1 MIL201505310 8.78
2 LAN201509150 8.32
3 PIT201507110 7.60
4 DET201509080 7.41
5 CLE201508110 7.32

最も勝率変動が大きかった試合の様子を見てみましょう

5月31日のバックスとブリュワーズの試合でした。

pbpData_winProb_winLose_winProbMove %>% 
  filter(GAME_ID == "MIL201505310") %>% 
  select(EVENT_ID, HOME_WIN_PROB) %>% 
  rbind(data.frame(EVENT_ID = 153, HOME_WIN_PROB = 1)) %>% 
  ggplot() + 
  geom_line(aes(x=EVENT_ID, y = HOME_WIN_PROB))

plot of chunk unnamed-chunk-9

調べてみると、17回裏にサヨナラホームランを打った試合でした

試合が長くなって、変動の和が大きくなっただけみたいです。

これは良くないです。計算方法を変えてみます。

勝率変動の最大値で評価することにします。

pbpData_winProb_winLose_winProbMove %>% 
  group_by(GAME_ID) %>% 
  summarise(EXCITING_SCORE = max(abs(WIN_PROB_MOVE))) %>% 
  arrange(desc(EXCITING_SCORE)) %>%
  ungroup %>% 
  select(GAME_ID, EXCITING_SCORE) %>% 
  head(5) %>% 
  xtable::xtable() %>% print("html")
GAME_ID EXCITING_SCORE
1 CHN201507270 0.91
2 TEX201505310 0.83
3 TOR201506090 0.81
4 COL201506022 0.79
5 ANA201509130 0.79

7月27日の試合で、変動91%が最大でした。

試合の内容を詳しく見てみましょう。

勝率変動の様子を可視化してみます。

pbpData_winProb_winLose_winProbMove %>% 
  filter(GAME_ID == "CHN201507270") %>% 
  select(EVENT_ID, HOME_WIN_PROB) %>% as.data.frame %>% 
  rbind(data.frame(EVENT_ID = 84, HOME_WIN_PROB = 1)) %>% 
  ggplot() + 
  geom_line(aes(x=EVENT_ID, y = HOME_WIN_PROB)) + 
  ggtitle("Win Prob. Movement @CHN20150727")

plot of chunk unnamed-chunk-11

この試合の詳細情報です

1点差の2アウト1塁から逆転サヨナラホームランでした。

理想的な"エキサイティングゲーム"です。

2015年のMost Exciting Gameと認定しましょう。

最もエキサイティングな選手

選手ごとに勝率変動を集計して、最も勝利に貢献した選手を探してみましょう。

ただ、勝率を上げたとしても、実際に勝たないと意味がありません。

なので、勝った試合への貢献度を足しあわせてみましょう。負けたら貢献0とします。

pbpData_winProb_winLose_winProbMove %>% 
  group_by(BAT_ID) %>% 
  summarise(WIN_COMMITMENT = sum(WIN_PROB_MOVE * ( 2*(BAT_HOME_ID == 1)-1))) %>% ## ホームならプラス, アウェイならマイナス
  merge(fullname_batid, by = "BAT_ID") %>% 
  arrange(desc(WIN_COMMITMENT)) %>% head(10) %>%
  xtable::xtable() %>% print("html")
BAT_ID WIN_COMMITMENT FULLNAME
1 vottj001 6.29 Joey Votto
2 goldp001 5.90 Paul Goldschmidt
3 donaj001 5.83 Josh Donaldson
4 rizza001 5.81 Anthony Rizzo
5 troum001 4.84 Mike Trout
6 carpm002 4.73 Matt Carpenter
7 harpb003 4.69 Bryce Harper
8 mccua001 4.59 Andrew McCutchen
9 morem001 4.06 Mitch Moreland
10 davic003 4.06 Chris Davis

ジョーイボットーが1位。通算で上昇させた勝率は6%でした。

勝利貢献度のWARと較べてみましょう。

name = c("Harper", "Trout", "Donaldson", "Goldschmedt", "Votto")
war = c(9.9, 9.4, 8.8, 8.8, 7.6)
data.frame(NAME = name, WAR = war) %>% 
  xtable::xtable() %>% print("html")
NAME WAR
1 Harper 9.90
2 Trout 9.40
3 Donaldson 8.80
4 Goldschmedt 8.80
5 Votto 7.60