Rでカウント推移の図を描きたいんじゃ!

みなさんは

こういうグラフとか

f:id:tsuyu_pon:20210726183645j:plain:w400 *1

こういうグラフを

f:id:tsuyu_pon:20210726183810p:plain:w400 *2

見たことありますか?



これは、前者がカウントごとの球種割合で、後者がカウントの状態推移確率を表したグラフです。


このグラフから投手であればカウント別の球種の偏りや組み立て方がわかり、打者であれば選球眼や打席での粘りがわかります。

さらに、投球ゾーンの情報やスイング率、空振り率、O-Swing%などと組み合わせると、選手の特徴がより詳細に把握できます。



今回は、これを自分でも描けるようになりたい!と思って、やってみたという記事です。


使用したデータ

以前、作成した{mlbr}パッケージでMLBの2021シーズン(~7/25)のデータを抽出しました。

tsuyupon.hatenablog.com

# devtools::install_github("pontsuyu/mlbr")
library(mlbr)
library(tidyverse)

dat21 <- sc_pbp("2021-04-01", "2021-07-25")



使用したパッケージ

Rでネットワーク図と言えば{igraph}パッケージですが、細かな設定ができるものの設定の仕方が大変だったり、描画に時間がかかったりするので、細かく設定できなくてもいいからもっと簡単にできるパッケージないかな~と思って探してみたところ、、、



{DiagrammeR}パッケージなるものがありました

visualizers.co

(例)

# install.packages(c("DiagrammeR", "DiagrammeRsvg", "rsvg"))
library(DiagrammeR)

# ネットワーク図の内容
a_graph <-
  create_graph() %>%
  add_node() %>%
  add_node() %>%
  add_edge(from = 1, to = 2) %>% 
  add_node() %>% 
  add_edge(from = 2, to = 3) %>% 
  add_edge(from = 1, to = 3)

# 描画
a <- render_graph(a_graph, layout = "nicely")
a
# 図の保存
a %>% DiagrammeRsvg::export_svg() %>% charToRaw %>% rsvg::rsvg_png("test.png")
f:id:tsuyu_pon:20210727201905p:plain

こんな感じで簡単に描くことが出来ます。

パイプでつないで直感的に書けるのは良いですね。

個人的にはプログラム書く時の頭の使い方が、{rvest}パッケージでHTMLページ内の要素にアクセスしていくときのような、パズルのような感覚に近いです。



使ってみた

今年のオオタニサン(打者)でやってみます

まずは投球前カウント,投球後カウントの組み合わせごとの数を算出

dat <- dat21 %>% 
  filter(batter_name=="Ohtani, Shohei")

# 投球前カウント, 投球後カウントの組み合わせごとの数を算出
dat_BS <- dat %>% 
  group_by(game_date, inning, at_bat_number) %>% 
  mutate(
    BS = paste0("B:",balls, " S:",strikes),
    BS_next = lead(BS)
  ) %>% 
  ungroup() %>% 
  mutate(
    BS_next = ifelse(is.na(BS_next), paste0("Event:", strikes+balls+1), BS_next),
    BS_next = BS_next %>% 
      factor(levels = c("B:0 S:0","B:1 S:0","B:0 S:1","B:2 S:0","B:1 S:1","B:0 S:2",
                        "B:3 S:0","B:2 S:1","B:1 S:2","B:3 S:1","B:2 S:2","B:3 S:2",
                        paste0("Event:", 1:6))),
    BS = BS %>% 
      factor(levels = c("B:0 S:0","B:1 S:0","B:0 S:1","B:2 S:0","B:1 S:1","B:0 S:2",
                        "B:3 S:0","B:2 S:1","B:1 S:2","B:3 S:1","B:2 S:2","B:3 S:2",
                        paste0("Event:", 1:6)))
    ) %>% 
  count(BS, BS_next)

# 割合を追加
## EventノードありVer.
dat_BS <- dat_BS %>%
  group_by(BS) %>% 
  mutate(per = round(n/sum(n)*100,0)) %>% 
  ungroup()

## EventノードなしVer.
dat_BS2 <- dat_BS %>% 
  filter(!str_detect(BS_next,"Event"))


作成したデータフレーム(一部抜粋)

> dat_BS
# A tibble: 33 x 4
   BS      BS_next     n   per
   <fct>   <fct>   <int> <dbl>
 1 B:0 S:0 B:1 S:0   156    42
 2 B:0 S:0 B:0 S:1   175    47
 3 B:0 S:0 Event:1    40    11
 4 B:1 S:0 B:2 S:0    54    35
 5 B:1 S:0 B:1 S:1    79    51
 6 B:1 S:0 Event:2    23    15
 7 B:0 S:1 B:1 S:1    92    53
 8 B:0 S:1 B:0 S:2    62    35
 9 B:0 S:1 Event:2    21    12
10 B:2 S:0 B:3 S:0    21    39
# ... with 23 more rows

> dat_BS2
# A tibble: 21 x 4
   BS      BS_next     n   per
   <fct>   <fct>   <int> <dbl>
 1 B:0 S:0 B:1 S:0   156    42
 2 B:0 S:0 B:0 S:1   175    47
 3 B:1 S:0 B:2 S:0    54    35
 4 B:1 S:0 B:1 S:1    79    51
 5 B:0 S:1 B:1 S:1    92    53
 6 B:0 S:1 B:0 S:2    62    35
 7 B:2 S:0 B:3 S:0    21    39
 8 B:2 S:0 B:2 S:1    29    54
 9 B:1 S:1 B:2 S:1    61    36
10 B:1 S:1 B:1 S:2    81    47
# ... with 11 more rows


これで、投球前カウント、投球後カウント、推移回数、割合が揃いました。

続いて、{DiagrammeR}を使ってカウント推移図を描いていきます。


カウント推移図の設定

Eventなしの場合

Eventなしの場合の方が簡単なのでこちらから。

今回のようにデータフレームがあらかじめ用意できる場合は、create_node_df関数とcreate_edge_df関数を使います。

# ノードの設定
nodes <- create_node_df(
  n = n_distinct(dat_BS2$BS_next)+1, # B:0 S:0がないので+1する
  label = levels(dat_BS2$BS_next)[-13:-18], # Eventなしにしぼる
  shape = "circle" # ノードの形。四角ならrectangle
)

# エッジの設定
edges <- create_edge_df(
  from = dat_BS2$BS %>% as.numeric(), # characterやfactorではなく、数値で指定
  to = dat_BS2$BS_next %>% as.numeric(), # characterやfactorではなく、数値で指定
  label = paste0(dat_BS2$n,"\n(",dat_BS2$per,"%)"), # 推移回数と割合
  penwidth = dat_BS2$per/10, # エッジの太さ
  color = case_when(
    dat_BS2$per <= 25 ~ "skyblue",
    dat_BS2$per <= 50 ~ "yellow",
    dat_BS2$per <= 75 ~ "orange",
    dat_BS2$per == 100 ~ "gray",
    TRUE ~ "red"
  ) # エッジの色
)

# 描画
g <- create_graph(nodes_df = nodes, edges_df = edges) %>%
  render_graph(layout = "tree", width = 1000, height = 600) # 上から下に推移していくようにしたかったのでlayoutはtree
g

# 保存
g %>% DiagrammeRsvg::export_svg() %>% charToRaw %>% rsvg::rsvg_png("Ohtani21_simple.png")
f:id:tsuyu_pon:20210727210740p:plain


特に複雑な指定をすることなく、簡単にきれいに描くことが出来ました!


Eventありの場合

Eventなしの場合とほとんどの同じですが、ノードをきれいに並べるのに少し工夫が必要です。

# ノードの設定
nodes <- create_node_df(
  n = length(unique(dat_BS$BS_next))+1,
  label = levels(dat_BS$BS_next),
  shape = "circle"
)

# エッジの設定
edges <- create_edge_df(
  from = dat_BS$BS %>% as.numeric(),
  to = dat_BS$BS_next %>% as.numeric(),
  label = paste0(dat_BS$n,"\n(",dat_BS$per,"%)"),
  penwidth = dat_BS$per/10,
  color = case_when(
    dat_BS$per <= 25 ~ "skyblue",
    dat_BS$per <= 50 ~ "yellow",
    dat_BS$per <= 75 ~ "orange",
    dat_BS$per == 100 ~ "gray",
    TRUE ~ "red"
  )
)

# 描画
g <- create_graph(nodes_df = nodes, edges_df = edges) %>% 
  render_graph(layout = "tree", width = 1000, height = 600)
g

ここまでは先ほどと同じですが、このまま描画すると

f:id:tsuyu_pon:20210727233902p:plain

このようにEventの列がずれて、わかりずらくなります。

これをわかりやすくするには、このノードの順番を入れ替える必要があります。


ノードの順番をイジる

描画に関する情報はg$x$diagramに含まれています。

> cat(g$x$diagram)
digraph {

graph [layout = "neato",
       outputorder = "edgesfirst",
       bgcolor = "white"]

node [fontname = "Helvetica",
      fontsize = "10",
      shape = "circle",
      fixedsize = "true",
      width = "0.5",
      style = "filled",
      fillcolor = "aliceblue",
      color = "gray70",
      fontcolor = "gray50"]

edge [fontname = "Helvetica",
     fontsize = "8",
     len = "1.5",
     color = "gray80",
     arrowsize = "0.5"]

  "1" [label = "B:0 S:0", shape = "circle", fillcolor = "#F0F8FF", fontcolor = "#000000", pos = "1,7!"] 
  "2" [label = "B:1 S:0", shape = "circle", fillcolor = "#F0F8FF", fontcolor = "#000000", pos = "1,6!"] 
  "3" [label = "B:0 S:1", shape = "circle", fillcolor = "#F0F8FF", fontcolor = "#000000", pos = "2.5,6!"] 
  "4" [label = "B:2 S:0", shape = "circle", fillcolor = "#F0F8FF", fontcolor = "#000000", pos = "1,5!"] 
  "5" [label = "B:1 S:1", shape = "circle", fillcolor = "#F0F8FF", fontcolor = "#000000", pos = "2,5!"] 
  "6" [label = "B:0 S:2", shape = "circle", fillcolor = "#F0F8FF", fontcolor = "#000000", pos = "3,5!"] 
(以下省略)

このpos = "1,7!"などの部分がノードの場所を示していて、ちょっとトリッキーですが"7行1列目に描画する"ことを指しています。
※行は下から1,2,3,...,7と数える。


つまり、この部分を適切な位置に書きかえることでノードの位置を入れ替えることが出来ます。

g$x$diagram <- g$x$diagram %>% 
  str_replace("2.5,6", "0.5,6") %>% 
  str_replace("0,6", "3,6") %>% 
  str_replace("1,6", "0,6") %>% 
  str_replace("0.5,6", "1,6") %>% 
  str_replace("0,5", "3.5,5") %>% 
  str_replace("1,5", "0,5") %>% 
  str_replace("2,5", "1,5") %>% 
  str_replace("3,5", "2,5") %>% 
  str_replace("3.5,5", "3,5") %>% 
  str_replace("2,3", "3,3") %>% 
  str_replace("1,2", "3,2") %>% 
  str_replace("0,1", "3,1")

# 描画
g
# 保存
g %>% DiagrammeRsvg::export_svg() %>% charToRaw %>% rsvg::rsvg_png("Ohtani21.png")
f:id:tsuyu_pon:20210727233940p:plain

位置が合っているかは試しながらになるので、どうしてもちょっと時間はかかってしまいますが先ほどより見やすくなりました!



おまけ:Plate Disciplineも見てみる



f:id:tsuyu_pon:20210728001152p:plain *3


オオタニサンのPlate Disciplineを見るとZone%は平均よりやや低めでSwing%はMLB平均程度ですが、SwStr%が高くHRが多いことから強振多用を感じますね(パワプロ脳)


これを踏まえて、もう一度カウント推移を見てみます。


←オオタニサン   Juan Soto→

f:id:tsuyu_pon:20210727210740p:plainf:id:tsuyu_pon:20210728003500p:plain


試しにJuan Sotoのカウント推移と比較してみると追い込まれてからの推移が異なっていて、オオタニサンはボール球が少なく三振を恐れず強振しているのだろうなと見てとれます。

もちろん、カウント別のPlate Disciplineを見てみないと断言は出来ませんが、全体のPlate Disciplineとカウント推移から筋の良い仮説を列挙することは出来そうです。



まとめ

  • {DiagrammeR}パッケージを使用してカウント推移を描いてみた

  • たいていの場合、簡単な設定のみで済むが、ノードの並び替えなど手の込んだことをしようとするとやや手間がかかる(とはいえ{igraph}より楽)

  • Eventありにするとさすがに見づらい(わかりづらい)ので、EventなしVer.のグラフとPlate Discipline(スイング率、空振り率、O-Swing%など選球眼に関する指標)の表を駆使して解釈するのが良さそう

  • エッジとラベルが重なる場合があるので、別途対処する必要はありそう…

「こういう使い方・見方もできるのでは?」という意見があればぜひ教えてください!

ではでは