【Rでセイバーメトリクス】福岡ソフトバンクホークス投手陣を比較
はじめに
こんにちは。 最近、RStudioとtidyverseをこの本で学んでいます 。
リンク
学べば学ぶほどにRStudioとtidyverseの便利さを感じさせられています。色んなデータで使ってみたくなります。
なので、今回はRStudioおよびtidyverseを活用して、データを弄ってみたいと思います。以前行ったように、野球をテーマにデータを触ってみます。ちなみにこの記事は、RStudioを使ってRmarkdownで更新してみました。
目的
- RStudioおよびtidyverseを使ってデータを操作する
- ソフトバンクホークス投手陣のデータを取得し、投手の能力を表すFIPを計算する
- それぞれの投手のK/BBを計算し、すごい感じの投手をみる
準備
まずは必要なパッケージをインストールし、使える準備をしましょう。
#rvestパッケージはスクレイピングで必要
install.packages("tidyverse")## Installing package into '/home/rstudio-user/R/x86_64-pc-linux-gnu-library/4.0'
## (as 'lib' is unspecified)install.packages("rvest")## Installing package into '/home/rstudio-user/R/x86_64-pc-linux-gnu-library/4.0'
## (as 'lib' is unspecified)library(tidyverse)## ── Attaching packages ───────────────────────────────── tidyverse 1.3.0 ──## ✓ ggplot2 3.3.2 ✓ purrr 0.3.4
## ✓ tibble 3.0.3 ✓ dplyr 1.0.2
## ✓ tidyr 1.1.2 ✓ stringr 1.4.0
## ✓ readr 1.3.1 ✓ forcats 0.5.0## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()library(rvest)## Loading required package: xml2##
## Attaching package: 'rvest'## The following object is masked from 'package:purrr':
##
## pluck## The following object is masked from 'package:readr':
##
## guess_encodingスクレイピング
それではデータを取得していきます。以前もそうしたように、NPBのサイトからデータを拝借します。
ちなみに今回使用したデータは2020年10月7日時点のものです。
では、ソフトバンクホークス投手陣のデータ及び、FIPの計算で必要なパ・リーグ全体の投手データを取得します。
データ取得には先ほどインストールしたrvestパッケージを使用します。
#for構文を使って、それぞれのチームの投手記録からテーブルを取得。
#assign関数は１つ目の引数に、２つ目の引数を代入する関数。
#paste関数は引数同士を結合して文字列を取得する関数（Rでは文字列を純粋に＋できない）。
team_list <- c("h","l","e","m","f","b") #チームの頭文字
for (i in team_list) {
assign(paste("table_", i, sep = ""), assign(paste("html_", i, sep = ""),
read_html(paste("https://npb.jp/bis/2020/stats/idp1_", i, ".html",sep = ""))) %>%
html_node(xpath = '//*[@id="stdivmaintbl"]/table') %>%
html_table())
}table_hからtable_bまで６球団の投手データが取得できました。
ちなみに環境によってうまくできませんでした。調べてもわからず…エラーメッセージからはセキュリティの問題っぽいけど…結局、RStudio Cloudから行うことができました。（ただRStudio Cloudは日本語表示が微妙なので、後述するように一度csvデータを保存して、別の環境からその先の処理を行っています。）
前処理
取得したtableデータはそのままでは使えないので、前処理を行います。
#余計なtableの1,2行目を削除
table_h <- table_h[c(-1,-2),]
table_b <- table_b[c(-1,-2),]
table_e <- table_e[c(-1,-2),]
table_f <- table_f[c(-1,-2),]
table_l <- table_l[c(-1,-2),]
table_m <- table_m[c(-1,-2),]
#パ・リーグ全チームの成績を縦結合して一つのデータフレームにまとめる
table_pa <- rbind(table_b, table_e, table_f, table_h, table_l, table_m)
#ホークスのデータフレームと、パ・リーグ全体のデータフレームの列名を設定
columns_list <- c("Lt","NAME", "G","W", "L", "SV", "HLD", "HP", "CG", "SHO", "NBB", "WPCT",
"BF", "IP", "IP.", "H", "HR", "BB", "IBB", "HBP", "SO", "WP", "BK", "R", "ER", "ERA")
colnames(table_h) <- columns_list
colnames(table_pa) <- columns_list
#データ型がCharacterなので、数値に変換。また、後述の計算のためにIP（投球回数）のNAを0で補完
table_h <- table_h %>%
type_convert()## Parsed with column specification:
## cols(
## .default = col_double(),
## Lt = col_character(),
## NAME = col_character()
## )## See spec(...) for full column specifications.table_h$IP <- as.double(table_h$IP)
table_h <- table_h %>%
tbl_df() %>%
mutate_at(vars(matches("IP",.)), funs(ifelse(is.na(.),0,.)))## Warning: `tbl_df()` is deprecated as of dplyr 1.0.0.
## Please use `tibble::as_tibble()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.## Warning: `funs()` is deprecated as of dplyr 0.8.0.
## Please use a list of either functions or lambdas:
##
## # Simple named list:
## list(mean = mean, median = median)
##
## # Auto named with `tibble::lst()`:
## tibble::lst(mean, median)
##
## # Using lambdas
## list(~ mean(., trim = .2), ~ median(., na.rm = TRUE))
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.table_pa <- table_pa %>%
type_convert()## Parsed with column specification:
## cols(
## .default = col_double(),
## Lt = col_character(),
## NAME = col_character(),
## IP = col_character(),
## ERA = col_character()
## )
## See spec(...) for full column specifications.table_pa$IP <- as.double(table_pa$IP)## Warning: NAs introduced by coerciontable_pa$ERA <- as.double(table_pa$ERA)## Warning: NAs introduced by coerciontable_pa <- table_pa %>%
tbl_df() %>%
mutate_at(vars(matches("IP",.)), funs(ifelse(is.na(.),0,.)))
#tibbleなデータフレームに変換
tibble_h <- as_tibble(table_h)
tibble_pa <- as_tibble(table_pa)
#csvデータに保存
tibble_h %>%
write_csv("tibble_h.csv")
tibble_pa %>%
write_csv("tibble_pa.csv")とりあえずここまでである程度の前処理は終わりです。
FIP
では、本題のFIPについてです。 以前は防御率が投手を評価する指標としてよく使われていましたが、防御率は失点のみで計算するため、野手の守備力や運も反映されてしまいます。そこで野手のプレーが関与せず、投手の能力のみによって完結する結果である、本塁打・四死球・三振から計算するFIPというものが使われるようになってきています。FIPが低いほど、一般的には投手としての能力が高いと言われています。しかし、ゴロを打たせるような投手はやや数値が悪く出るようなので絶対ではありません。
また、数値が防御率に近いように計算されており、その差を見ることで野手の影響を見ることができます（投手本来の実力か、野手の能力に助けられたり運がよいかなどがみえる）。標準的にはゼロとなり、数値が大きい場合は投手個人の能力よりも失点していることになるため、不運だった可能性があり、逆に数値が小さい場合は実力以上の結果になっていると見ることができます。
さて、実際の計算ですが、その前にFIPの計算に必要なリーグ補正値を算出します 。
#リーグ補正値のためのリーグ成績計算
library(tidyverse)## ─ Attaching packages ────────────────────────────── tidyverse 1.3.0 ─## ✓ ggplot2 3.3.2 ✓ purrr 0.3.4
## ✓ tibble 3.0.3 ✓ dplyr 1.0.2
## ✓ tidyr 1.1.2 ✓ stringr 1.4.0
## ✓ readr 1.3.1 ✓ forcats 0.5.0## ─ Conflicts ─────────────────────────────── tidyverse_conflicts() ─
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()tibble_h <- read_csv("tibble_h.csv")## Parsed with column specification:
## cols(
## .default = col_double(),
## Lt = col_character(),
## NAME = col_character()
## )## See spec(...) for full column specifications.tibble_pa <- read_csv("tibble_pa.csv")## Parsed with column specification:
## cols(
## .default = col_double(),
## Lt = col_character(),
## NAME = col_character()
## )
## See spec(...) for full column specifications.ER_sum <- tibble_pa %>%
summarise(ER_sum = sum(ER))
IP_sum <- tibble_pa %>%
summarise(IP_sum = sum(IP))
HR_sum <- tibble_pa %>%
summarise(HR_sum = sum(HR))
BB_sum <- tibble_pa %>%
summarise(BB_sum = sum(BB))
HBP_sum <- tibble_pa %>%
summarise(HBP_sum = sum(HBP))
IBB_sum <- tibble_pa %>%
summarise(IBB_sum = sum(IBB))
SO_sum <- tibble_pa %>%
summarise(SO_sum = sum(SO))#リーグ全体の防御率[(自責点 × 9) ÷ 投球回]
pa_ERA <- (ER_sum * 9) / IP_sum
pa_ERA## ER_sum
## 1 4.020881#リーグ補正値[リーグ全体の防御率-｛13×被本塁打+3×（与四球＋与死球-敬遠）-2×奪三振｝÷投球回]
corr_val <- pa_ERA - {13 * HR_sum + 3 * (BB_sum + HBP_sum - IBB_sum) - 2 * SO_sum} / IP_sum
corr_val <- corr_val[1,1]
corr_val## [1] 2.996279FIP計算のためのリーグ補正値が算出できたので、tibble_h、tibble_paそれぞれにFIPとE-F（防御率とFIPの差）の列を追加します。
#tibble_hにFIP[｛13×被本塁打+3×（与四球+与死球-敬遠）-2×奪三振｝÷投球回数＋リーグ補正値]とE-F[ERA-FIP]の列を追加
tibble_h <- tibble_h %>%
mutate(FIP = {13 * HR + 3 * (BB + HBP - IBB) - 2 * SO } / IP + corr_val, E_F = ERA - FIP)
tibble_h## # A tibble: 27 x 28
## Lt NAME G W L SV HLD HP CG SHO NBB WPCT BF
## <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 <NA> 石川 柊… 13 7 3 0 0 0 2 1 0 0.7 331
## 2 <NA> 泉 圭輔… 29 0 1 0 6 6 0 0 0 0 115
## 3 <NA> 岩嵜 翔… 6 0 2 0 3 3 0 0 0 0 34
## 4 * 大竹 耕… 2 1 0 0 0 0 0 0 0 1 43
## 5 <NA> 尾形 崇… 1 0 0 0 0 0 0 0 0 0 8
## 6 <NA> 奥村 政… 5 0 0 0 0 0 0 0 0 0 20
## 7 * 笠谷 俊… 16 2 3 0 0 1 0 0 0 0.4 169
## 8 <NA> 加治屋 … 6 0 0 0 0 0 0 0 0 0 30
## 9 * 嘉弥真 … 38 2 1 0 16 18 0 0 0 0.667 90
## 10 * 川原 弘… 22 0 0 0 4 4 0 0 0 0 79
## # … with 17 more rows, and 15 more variables: IP <dbl>, IP. <dbl>, H <dbl>,
## # HR <dbl>, BB <dbl>, IBB <dbl>, HBP <dbl>, SO <dbl>, WP <dbl>, BK <dbl>,
## # R <dbl>, ER <dbl>, ERA <dbl>, FIP <dbl>, E_F <dbl>#tibble_paにFIP[｛13×被本塁打+3×（与四球+与死球-敬遠）-2×奪三振｝÷投球回数＋リーグ補正値]とE-F[ERA-FIP]の列を追加
tibble_pa <- tibble_pa %>%
mutate(FIP = {13 * HR + 3 * (BB + HBP - IBB) - 2 * SO } / IP + corr_val, E_F = ERA - FIP)
tibble_pa## # A tibble: 163 x 28
## Lt NAME G W L SV HLD HP CG SHO NBB WPCT BF
## <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 * アルバー… 13 3 6 0 0 0 0 0 0 0.333 299
## 2 <NA> 荒西 祐… 27 0 0 0 2 2 0 0 0 0 131
## 3 * 飯田 優… 4 1 0 0 0 1 0 0 0 1 24
## 4 <NA> 漆原 大… 12 0 0 1 1 1 0 0 0 0 59
## 5 * 海田 智… 6 0 1 0 2 2 0 0 0 0 22
## 6 <NA> 金田 和… 3 0 0 0 0 0 0 0 0 0 27
## 7 <NA> 神戸 文… 5 0 1 0 1 1 0 0 0 0 33
## 8 <NA> Ｋ－鈴木… 5 0 2 0 0 0 0 0 0 0 63
## 9 <NA> 小林 慶… 7 0 0 0 0 0 0 0 0 0 35
## 10 * 齋藤 綱… 25 1 1 0 3 4 0 0 0 0.5 78
## # … with 153 more rows, and 15 more variables: IP <dbl>, IP. <dbl>, H <dbl>,
## # HR <dbl>, BB <dbl>, IBB <dbl>, HBP <dbl>, SO <dbl>, WP <dbl>, BK <dbl>,
## # R <dbl>, ER <dbl>, ERA <dbl>, FIP <dbl>, E_F <dbl>もう少し見やすく、防御率, FIP, E-Fのみを残して見てみましょう
#ERA, FIP, E_F列を残して、FIPで並び替え
tibble_h %>%
select(NAME, ERA, FIP, E_F) %>%
arrange(FIP)## # A tibble: 27 x 4
## NAME ERA FIP E_F
## <chr> <dbl> <dbl> <dbl>
## 1 モイネロ 1.11 1.27 -0.161
## 2 嘉弥真 新也 1.54 2.04 -0.500
## 3 杉山 一樹 1.5 2.33 -0.830
## 4 千賀 滉大 2.82 2.83 -0.0132
## 5 森 唯斗 2.43 2.85 -0.416
## 6 笠谷 俊介 3.26 2.89 0.369
## 7 ムーア 3.04 2.91 0.129
## 8 古谷 優人 3.18 3.00 0.184
## 9 奥村 政稔 2.08 3.25 -1.17
## 10 板東 湧梧 2.56 3.67 -1.11
## # … with 17 more rows#ERA, FIP, E_F列を残して、FIP上位20人を算出し、並び替え
max20_pa <- tibble_pa %>%
select(NAME, ERA, FIP, E_F) %>%
slice_min(FIP, n = 20) %>%
arrange(FIP)
max20_pa## # A tibble: 20 x 4
## NAME ERA FIP E_F
## <chr> <dbl> <dbl> <dbl>
## 1 飯田 優也 15.8 0.496 15.3
## 2 佐々木 千隼 0 0.996 -0.996
## 3 モイネロ 1.11 1.27 -0.161
## 4 海田 智行 14.5 1.75 12.8
## 5 比嘉 幹貴 0 1.83 -1.83
## 6 久保 裕也 13.5 2.00 11.5
## 7 福山 博之 0 2.00 -2.00
## 8 吉田 侑樹 4.26 2.00 2.26
## 9 嘉弥真 新也 1.54 2.04 -0.500
## 10 益田 直也 2.01 2.25 -0.236
## 11 杉山 一樹 1.5 2.33 -0.830
## 12 山本 由伸 2.26 2.40 -0.142
## 13 唐川 侑己 0.83 2.47 -1.64
## 14 國場 翼 0 2.50 -2.50
## 15 ハーマン 2.27 2.61 -0.339
## 16 山田 修義 4.45 2.65 1.80
## 17 増田 達至 2.06 2.65 -0.593
## 18 池田 駿 4.32 2.68 1.64
## 19 ジャクソン 3.86 2.71 1.15
## 20 二木 康太 3.55 2.74 0.808パ・リーグ全体のFIP上位には、ホークスからはモイネロ選手、嘉弥真 新也選手、杉山一樹選手が顔を出していますね。
これらを見やすく、グラフ表示してみます。横軸にはFIPを、縦軸にはE-Fを設定します。
#グラフのラベルを見やすくするためのggrepelパッケージを読み込み
install.packages("ggrepel")## Installing package into '/usr/local/lib/R/site-library'
## (as 'lib' is unspecified)library(ggrepel)#散布図で表示。横軸にはFIPを、縦軸にはE-Fを設定。それぞれの点に名前を表示。
ggplot(tibble_h, aes(x = FIP, y = E_F, label = NAME)) +
geom_point() +
geom_text_repel()
#散布図で表示。横軸にはFIPを、縦軸にはE-Fを設定。それぞれの点に名前を表示。
ggplot(max20_pa, aes(x = FIP, y = E_F, label = NAME)) +
geom_point() +
geom_text_repel()
投球数がそもそも少なかったりするので確実にそうとは言えないですが、E-Fが高くてFIPが0点台の飯田優也選手（現オリックス、元ホークス）とかはすごいいい感じのピッチングをしていると言えるかもしれません。にしても、モイネロ選手は防御率とFIPの差が少なくて、なおかつFIPも低いので、今年は抜群の働きをしているのがわかりますね。 あとは、リーグ全体のFIP上位者はリリーフピッチャーが多い印象ですが、オリックスの山本由伸選手は先発で入ってますね。すごい…
K/BB
次にK/BBを算出します。K/BBは奪三振と与四球の割合で、投手の制球力を示すと言われています。3.5を超えると優秀と言われているようです。
同じく、列に追加して、FIPとのグラフを表示してみましょう。
#tibble_hにK/BBの列を追加
tibble_h <- tibble_h %>%
mutate(K_BB = SO / BB)
tibble_h## # A tibble: 27 x 29
## Lt NAME G W L SV HLD HP CG SHO NBB WPCT BF
## <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 <NA> 石川 柊… 13 7 3 0 0 0 2 1 0 0.7 331
## 2 <NA> 泉 圭輔… 29 0 1 0 6 6 0 0 0 0 115
## 3 <NA> 岩嵜 翔… 6 0 2 0 3 3 0 0 0 0 34
## 4 * 大竹 耕… 2 1 0 0 0 0 0 0 0 1 43
## 5 <NA> 尾形 崇… 1 0 0 0 0 0 0 0 0 0 8
## 6 <NA> 奥村 政… 5 0 0 0 0 0 0 0 0 0 20
## 7 * 笠谷 俊… 16 2 3 0 0 1 0 0 0 0.4 169
## 8 <NA> 加治屋 … 6 0 0 0 0 0 0 0 0 0 30
## 9 * 嘉弥真 … 38 2 1 0 16 18 0 0 0 0.667 90
## 10 * 川原 弘… 22 0 0 0 4 4 0 0 0 0 79
## # … with 17 more rows, and 16 more variables: IP <dbl>, IP. <dbl>, H <dbl>,
## # HR <dbl>, BB <dbl>, IBB <dbl>, HBP <dbl>, SO <dbl>, WP <dbl>, BK <dbl>,
## # R <dbl>, ER <dbl>, ERA <dbl>, FIP <dbl>, E_F <dbl>, K_BB <dbl>#tibble_paにK/BBの列を追加
tibble_pa <- tibble_pa %>%
mutate(K_BB = SO / BB)
tibble_pa## # A tibble: 163 x 29
## Lt NAME G W L SV HLD HP CG SHO NBB WPCT BF
## <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 * アルバー… 13 3 6 0 0 0 0 0 0 0.333 299
## 2 <NA> 荒西 祐… 27 0 0 0 2 2 0 0 0 0 131
## 3 * 飯田 優… 4 1 0 0 0 1 0 0 0 1 24
## 4 <NA> 漆原 大… 12 0 0 1 1 1 0 0 0 0 59
## 5 * 海田 智… 6 0 1 0 2 2 0 0 0 0 22
## 6 <NA> 金田 和… 3 0 0 0 0 0 0 0 0 0 27
## 7 <NA> 神戸 文… 5 0 1 0 1 1 0 0 0 0 33
## 8 <NA> Ｋ－鈴木… 5 0 2 0 0 0 0 0 0 0 63
## 9 <NA> 小林 慶… 7 0 0 0 0 0 0 0 0 0 35
## 10 * 齋藤 綱… 25 1 1 0 3 4 0 0 0 0.5 78
## # … with 153 more rows, and 16 more variables: IP <dbl>, IP. <dbl>, H <dbl>,
## # HR <dbl>, BB <dbl>, IBB <dbl>, HBP <dbl>, SO <dbl>, WP <dbl>, BK <dbl>,
## # R <dbl>, ER <dbl>, ERA <dbl>, FIP <dbl>, E_F <dbl>, K_BB <dbl>#パ・リーグにおけるK/BB上位20人を表示
max20_pa <- tibble_pa %>%
select(NAME, ERA, FIP, E_F, K_BB) %>%
slice_max(K_BB, n = 20) %>%
arrange(K_BB)
max20_pa## # A tibble: 20 x 5
## NAME ERA FIP E_F K_BB
## <chr> <dbl> <dbl> <dbl> <dbl>
## 1 齋藤 綱記 5.09 4.17 0.917 3.4
## 2 涌井 秀章 3.06 3.79 -0.726 3.54
## 3 モイネロ 1.11 1.27 -0.161 3.55
## 4 バーヘイゲン 3.95 3.08 0.868 3.68
## 5 山本 由伸 2.26 2.40 -0.142 3.88
## 6 美馬 学 4.31 3.11 1.20 3.95
## 7 海田 智行 14.5 1.75 12.8 4
## 8 森 唯斗 2.43 2.85 -0.416 4
## 9 ジャクソン 3.86 2.71 1.15 4
## 10 唐川 侑己 0.83 2.47 -1.64 4.5
## 11 増田 達至 2.06 2.65 -0.593 4.67
## 12 有原 航平 3.83 3.19 0.643 4.79
## 13 飯田 優也 15.8 0.496 15.3 5
## 14 比嘉 幹貴 0 1.83 -1.83 5
## 15 嘉弥真 新也 1.54 2.04 -0.500 5.6
## 16 二木 康太 3.55 2.74 0.808 7
## 17 久保 裕也 13.5 2.00 11.5 Inf
## 18 福山 博之 0 2.00 -2.00 Inf
## 19 佐々木 千隼 0 0.996 -0.996 Inf
## 20 成田 翔 18 10.7 7.34 Inf#ホークス内において散布図を表示。横軸にFIP、縦軸にK/BBを設定。
ggplot(tibble_h, aes(x = FIP, y = K_BB, label = NAME)) +
geom_point() +
geom_text_repel()
#パ・リーグ内において散布図を表示。横軸にFIP、縦軸にK/BBを設定。
ggplot(max20_pa, aes(x = FIP, y = K_BB, label = NAME)) +
geom_point() +
geom_text_repel()
ホークスにおいては、K/BBが3.5を上回るのは嘉弥真新也選手、モイネロ選手、森唯斗 選手となっており、それぞれがチーム内では上位のFIPを記録しています。また、グラフを見ると全体的に反比例しているようにみえます。つまり、制球力がよいと思われるピッチャーほど、良いFIPを残しているといえるでしょう。
パ・リーグ内の上位20人の中にも、先程の3選手は含まれています。こちらも、ピックアップする人数が多くなると、右下にプロットが増えるのではないかと予測できます(実際ある程度そうでした) 。
まとめ
以上のようにRStudioとtidyverseを使って、ソフトバンクホークスやパリーグの投手のセイバーメトリクス指標を算出し、可視化を行いました。
今までPythonを中心に学んだこともあって、Rでのデータ操作は少し手こずりました。本来ならtidyなデータに変換して行う方がtidyverseな使い方としては良かったのかもしれませんが、難しい箇所がありましたので、今回は断念しました。また、スクレイピングの部分も環境によってできないのがわからなかったので、今後更なる勉強が必要です。
しかし、話に聞いてはいましたが、Rはggplotを使用した可視化がとても便利だなと改めて感じました。Pythonでもggplotが使えるようですので、それを使うのも良いなと思います。
ちなみに来月にはRでセイバーメトリクスをする本が発売されるようです。要チェックですね。
リンク
では、今回は以上です！
コメント