霞と側杖を食らう

ほしいものです。なにかいただけるとしあわせです。[https://www.amazon.jp/hz/wishlist/ls/2EIEFTV4IKSIJ?ref_=wl_share]

リリーフ運用指標MRTRの作成の学習記録その1

【学習動機】

プロ野球ペナントレースで優勝するためには, どうすればいいのかを考えた. 『メジャー』,『八月のシンデレラナイン』, 『大正野球娘。』, 『ONE OUTS』あたりを見た経験などから色々考えた結果, シーズン中のペース配分が戦略として重要だという考えに至った. どのタイミングでペースを上げ, どのタイミングでペースを落とすか. 短期決戦とは異なる戦略がペナントレースにはあるように思われる. 優勝経験の多い球団や監督はそのペースの加減をその経験から理解しているのではないだろうか. 一方で, 優勝の浅いチームや監督はそのようなことを知らない. 知らないのならば, データで客観的に捉えられないだろうかと考える. データとして捉えやすいであろうペース配分の一つとして, リリーフの運用が挙げられる. 以下で, リリーフの運用をデータで捉えるために指標を作成する.

【学習内容】

speakerdeck.com

以下では, この発表スライドの分析と追加分析に使用したRのコードを記載していく.

パッケージの読み込み

library(tidyverse)
library(ggplot2)
library(ggthemes)
library(rvest)
library(stringr)

指標mrtrの関数fと関数gの定義とその挙動確認

 こんな感じで開発されました.

# 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.5
findex(2)
## [1] 0.8068528
findex(3)
## [1] 0.4013877
findex(4)
## [1] 0.1137056
findex(5)
## [1] -0.1094379
findex(100)
## [1] -3.10517
apply(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.8025851
plot(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] 0
gindex(1,1,1,1)
## [1] 2.25
gindex(4,1,1,1)
## [1] 0
gindex(1,1,4,1)
## [1] 1
gindex(1,4,4,1)
## [1] 0.25
gindex(1,4,4,4)
## [1] 0

DeNAについてのデータ確認と指標作成.

プロ野球Freakから勝敗データをスクレイピング.

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回表 横浜   中日 DeNA  中日 DeNA    0 平田良介
## 2 2019032901 1回表 横浜   中日 DeNA  中日 DeNA    0 平田良介
## 3 2019032901 1回表 横浜   中日 DeNA  中日 DeNA    0 平田良介
## 4 2019032901 1回表 横浜   中日 DeNA  中日 DeNA    0 平田良介
## 5 2019032901 1回表 横浜   中日 DeNA  中日 DeNA    0 平田良介
## 6 2019032901 1回表 横浜   中日 DeNA  中日 DeNA    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-29

DeNAのデータのみ抽出. 各試合日の合計投球数のヒストグラム作成.

datDeNA <- dat %>% group_by(gamedate,gameid,defense,position_1) %>% 
  summarise(nball=n()) %>% filter(defense=="DeNA")
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に続く.

moratoriamuo.hatenablog.com