【学習動機】
プロ野球のペナントレースで優勝するためには, どうすればいいのかを考えた. 『メジャー』,『八月のシンデレラナイン』, 『大正野球娘。』, 『ONE OUTS』あたりを見た経験などから色々考えた結果, シーズン中のペース配分が戦略として重要だという考えに至った. どのタイミングでペースを上げ, どのタイミングでペースを落とすか. 短期決戦とは異なる戦略がペナントレースにはあるように思われる. 優勝経験の多い球団や監督はそのペースの加減をその経験から理解しているのではないだろうか. 一方で, 優勝の浅いチームや監督はそのようなことを知らない. 知らないのならば, データで客観的に捉えられないだろうかと考える. データとして捉えやすいであろうペース配分の一つとして, リリーフの運用が挙げられる. 以下で, リリーフの運用をデータで捉えるために指標を作成する.
【学習内容】
以下では, この発表スライドの分析と追加分析に使用したRのコードを記載していく.
パッケージの読み込み
library(tidyverse)
library(ggplot2)
library(ggthemes)
library(rvest)
library(stringr)指標mrtrの関数fと関数gの定義とその挙動確認
こんな感じで開発されました.
進捗です pic.twitter.com/iu2H2mt7ju
— もらとりあむお271 (@moratoriamuo271) October 28, 2019
# INDEXt = f(dt) + g(dt,dt-1,dt-2,dt-3)
# 登板間隔による指数
findex <- function(d){
if(d==0) return(0)else{
return(-log(d)+1.5)}
}
findex(1)## [1] 1.5findex(2)## [1] 0.8068528findex(3)## [1] 0.4013877findex(4)## [1] 0.1137056findex(5)## [1] -0.1094379findex(100)## [1] -3.10517apply(as.matrix(0:10),1,findex)## [1] 0.0000000 1.5000000 0.8068528 0.4013877 0.1137056 -0.1094379
## [7] -0.2917595 -0.4459101 -0.5794415 -0.6972246 -0.8025851plot(as.vector(0:10),apply(as.matrix(0:10),1,findex),xlim=c(0, 10), xaxp=c(0, 10, 10))
abline(h=0, lty=2)
# 連投による指数
gindex <- function(d,d1,d2,d3){
ncont <- ((0<d)&(d<=2))*sum(((0<d1)&(d1<=2)),((0<d2)&(d2<=2)),((0<d3)&(d3<=2)))
0.25*ncont^2
}
gindex(0,1,1,1)## [1] 0gindex(1,1,1,1)## [1] 2.25gindex(4,1,1,1)## [1] 0gindex(1,1,4,1)## [1] 1gindex(1,4,4,1)## [1] 0.25gindex(1,4,4,4)## [1] 0DeNAについてのデータ確認と指標作成.
gameresDeNA <- read_html("https://baseball-freak.com/game/baystars.html")
gameresTDeNA <- gameresDeNA %>% html_table()
gameresTDeNA1 <- gameresTDeNA[[1]]
gameresTDeNA1 <- gameresTDeNA1 %>% mutate(gamedate=日付 %>% as.Date(format="%m月%d日"),
win = case_when(勝敗=="○"~1,
勝敗=="●"~0,
勝敗=="△"~0.5,
勝敗=="-"~-0.5))
head(gameresTDeNA1)## 日付 勝敗 スコア 対戦相手 先発投手 責任投手 球場 開始
## 1 3月29日(金) ○ 8 - 1 中日 今永 ○今永 横浜 18:30
## 2 3月30日(土) ● 1 - 9 中日 京山 ●京山 横浜 14:00
## 3 3月31日(日) ○ 3 - 2 中日 井納 ○山崎 横浜 13:00
## 4 4月2日(火) ● 2 - 5 ヤクルト 上茶谷 ●パットン 神宮 18:00
## 5 4月3日(水) ● 4 - 5 ヤクルト 濱口 ●三上 神宮 18:00
## 6 4月4日(木) ○ 10 - 5 ヤクルト 大貫 ○砂田 神宮 18:00
## gamedate win
## 1 2019-03-29 1
## 2 2019-03-30 0
## 3 2019-03-31 1
## 4 2019-04-02 0
## 5 2019-04-03 0
## 6 2019-04-04 1いただいたデータに日付データを作成して, 中身確認.
dat <- readRDS("data/npbdata2019.rds")
dat <- dat %>% mutate(gamedate = gameid %>% str_sub(start = 1, end = 8) %>% as.Date(format="%Y%m%d"))
head(dat)## gameid inn park attack defense bat_t bat_b runs batter
## 1 2019032901 1回表 横浜 中日 ＤｅＮＡ 中日 ＤｅＮＡ 0 平田良介
## 2 2019032901 1回表 横浜 中日 ＤｅＮＡ 中日 ＤｅＮＡ 0 平田良介
## 3 2019032901 1回表 横浜 中日 ＤｅＮＡ 中日 ＤｅＮＡ 0 平田良介
## 4 2019032901 1回表 横浜 中日 ＤｅＮＡ 中日 ＤｅＮＡ 0 平田良介
## 5 2019032901 1回表 横浜 中日 ＤｅＮＡ 中日 ＤｅＮＡ 0 平田良介
## 6 2019032901 1回表 横浜 中日 ＤｅＮＡ 中日 ＤｅＮＡ 0 平田良介
## batter_num course top left 投球数 総投球数 球種 球速
## 1 1 2 101.216 61.20 ●1 1 ストレート 149
## 2 1 14 205.648 18.50 ＜2 2 スライダー 140
## 3 1 16 205.648 63.64 ●3 3 ストレート 150
## 4 1 22 60.224 212.48 ●4 4 ストレート 150
## 5 1 13 159.776 12.40 ＜5 5 スライダー 140
## 6 1 5 110.976 117.32 ●6 6 ストレート 150
## 結果 BSO runner_1 runner_2 runner_3 position_1 position_2 position_3
## 1 ファウル - <NA> <NA> <NA> 今永昇太 伊藤光 ロペス
## 2 空振り - <NA> <NA> <NA> 今永昇太 伊藤光 ロペス
## 3 ボール - <NA> <NA> <NA> 今永昇太 伊藤光 ロペス
## 4 ボール - <NA> <NA> <NA> 今永昇太 伊藤光 ロペス
## 5 ボール - <NA> <NA> <NA> 今永昇太 伊藤光 ロペス
## 6 ファウル - <NA> <NA> <NA> 今永昇太 伊藤光 ロペス
## position_4 position_5 position_6 position_7 position_8 position_9
## 1 ソト 宮崎敏郎 大和 筒香嘉智 梶谷隆幸 楠本泰史
## 2 ソト 宮崎敏郎 大和 筒香嘉智 梶谷隆幸 楠本泰史
## 3 ソト 宮崎敏郎 大和 筒香嘉智 梶谷隆幸 楠本泰史
## 4 ソト 宮崎敏郎 大和 筒香嘉智 梶谷隆幸 楠本泰史
## 5 ソト 宮崎敏郎 大和 筒香嘉智 梶谷隆幸 楠本泰史
## 6 ソト 宮崎敏郎 大和 筒香嘉智 梶谷隆幸 楠本泰史
## gamedate
## 1 2019-03-29
## 2 2019-03-29
## 3 2019-03-29
## 4 2019-03-29
## 5 2019-03-29
## 6 2019-03-29DeNAのデータのみ抽出. 各試合日の合計投球数のヒストグラム作成.
datDeNA <- dat %>% group_by(gamedate,gameid,defense,position_1) %>%
summarise(nball=n()) %>% filter(defense=="ＤｅＮＡ")
datDeNA %>% group_by(gamedate) %>% summarise(nballs = sum(nball)) %>% ggplot() +
geom_histogram(aes(x=nballs),colour="grey")## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
一試合あたりの平均投手数
datDeNApitchers <- datDeNA %>% summarise(npitcher=n())
mean(datDeNApitchers$npitcher)## [1] 4.48951各試合の登板投手数と平均投手数.
phDeNA <- datDeNApitchers %>% ggplot(aes(x=gamedate,y=npitcher)) +
geom_bar(stat = "identity") +
geom_hline(yintercept = mean(datDeNApitchers$npitcher),colour="red") +
geom_text(aes(as.Date("2019-03-20"),y=4.8,label=round(mean(datDeNApitchers$npitcher),digits = 2)),colour="red")
phDeNA
月ごとに1試合あたりの平均登板投手数が異なるのか確認.
datDeNApitchers %>% mutate(gamemonth=months(gamedate)) %>%
group_by(gamemonth) %>% summarise(meanP_m=mean(npitcher),
varP_m=var(npitcher),
ngames=n())## # A tibble: 7 x 4
## gamemonth meanP_m varP_m ngames
## <chr> <dbl> <dbl> <int>
## 1 3月 4.67 6.33 3
## 2 4月 4.08 1.82 24
## 3 5月 4.13 1.75 23
## 4 6月 4.65 1.69 23
## 5 7月 4.75 2.20 24
## 6 8月 4.41 1.40 27
## 7 9月 5 1.44 19主要リリーフの選択. ローテーションを守っていた今永と上茶谷が25試合だったので,30試合以上で主要リリーフとする.
pitchersDeNA_ov30 <- datDeNA %>% group_by(position_1) %>% summarise(ngame=n()) %>%
filter(ngame>=30)
pitchersDeNA_ov30 <- as.vector(pitchersDeNA_ov30$position_1)リリーフの登板と球数のヒートマップと勝ち負けのヒートマップ.
p1DeNA <- datDeNA %>% filter(position_1 %in% pitchersDeNA_ov30) %>% ggplot() +
geom_tile(aes(x=position_1,y=gamedate,fill=nball)) +
scale_fill_gradient(low="skyblue",high="darkblue") + theme_classic()
p1DeNA
p2DeNA <- gameresTDeNA1 %>% mutate(winlose="勝ち負け") %>% ggplot() +
geom_tile(aes(x=winlose,y=gamedate,fill=win)) +
scale_fill_gradient(low="white",high="darkblue") + theme_classic() +
scale_y_date(date_breaks = "1 months", date_labels = "%B",
limits = c(as.Date("2019-3-29"), as.Date("2019-10-10")))
p2DeNA
gridExtra::grid.arrange(p2DeNA, p1DeNA, nrow = 1)
16試合移動平均勝率.
winrate16DeNA <- gameresTDeNA1 %>% mutate(winlose="16試合移動平均勝率",
movemean=stats::filter(win,c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1)) %>%
as.vector()/16) %>%
ggplot() + geom_line(aes(gamedate,movemean)) +
scale_x_date(date_breaks = "1 months", date_labels = "%B",
limits = c(as.Date("2019-3-29"), as.Date("2019-10-10")))
winrate16DeNA## Warning: Removed 30 rows containing missing values (geom_path).
指標作成の試行錯誤で, f+g以外も作ってみている.
# 無理です辛いです指数MRTR
datDeNAindex <- datDeNA %>% filter(position_1 %in% pitchersDeNA_ov30) %>%
group_by(position_1) %>% mutate(
d = c(0,diff(gamedate)),
d1 = lag(d,1) %>% ifelse(is.na(.),0,.),
d2 = lag(d,2) %>% ifelse(is.na(.),0,.),
d3 = lag(d,3) %>% ifelse(is.na(.),0,.))
dfdatDeNAindex <- datDeNAindex %>% mutate(
f = apply(as.matrix(d),1,findex),
g = purrr::pmap(list(d,d1,d2,d3),.f = gindex) %>% unlist(),
fg = f + g,
cumfg = cumsum(fg)/100
) %>% ungroup() %>% group_by(gamedate) %>% summarise(mrtr=sum(cumfg),
mrtrf=sum(f),
mrtrg=sum(g),
MRTR=sum(fg))pfgDeNA <- ggplot(dfdatDeNAindex) + geom_line(aes(gamedate,MRTR)) +
scale_x_date(date_breaks = "1 months", date_labels = "%B",
limits = c(as.Date("2019-3-29"), as.Date("2019-10-10"))) +
geom_hline(aes(yintercept=7.5),colour="red")
pfgDeNA
他のセリーグチームについても作成. ほとんど同じなのでコードは省略.
【学習内容(続く)】
はてなブログの記事の容量制限でその2に続く.
