編集距離で名寄せ (相撲の結果から強さを推定する)
はじめに
力士の強さを定量化したいです。戦闘力。いいですよね。興奮します。
以前、相撲の対戦結果データを作成しました。
相撲の星取表をRで扱える形式にしてみた、という内容です。
このデータの中では、一部の四股名が略称で入っています。
詳細は後述しますが、例えば「日馬富士」が「日馬富」とされていることがあるのです。
集計が出来なくて困っていました。前処理が必要です。今回は、編集距離で名寄せする方法を紹介しつつ、最後に力士の戦闘力を出します。
編集距離で名寄せ
編集距離を使ってみます。文字列の近さを測る指標の1つです。
たとえば、「hoge」と「huge」の間の編集距離は1です。
hogeのoをuに"編集"すればhugeになるからです。
詳細は、このサイトを見るとわかると思います。
Rでは, MiscPsychoというパッケージを利用すれば、編集距離の計算ができるらしいです。
...R-3.2.2の場合はCRANからインストール出来ませんでした。
ソースをダウンロードして頑張ってインストールしました。
# install.packages("MiscPsycho_1.6.tar", reposz = NULL, type = "source")
library("MiscPsycho")
## stringMatchを使えばいいらしいです。
stringMatch("hoge", "huge", normalize = "NO")
## [1] 1
## normalize = "NO"としないと、文字数で規格化された距離が出力されます。
stringMatch("hoge", "huge")
## [1] 0.75
この編集距離を利用して、四股名と四股名の略称を紐つけてみます。
(2015年11月8日追記)
非標準のMiscPsycho::stringMatchではなく、標準ライブラリであるutils::adistを使う方がいい、というご指摘を@kos59125 さんより頂きました。
utils::adist("hoge", "huge")
[,1]
[1,] 1
なるほど。こちらのほうがいいです。ありがとうございます。
相撲のデータで名寄せ
実際のデータに使ってみましょう。
星取表をパースして作ったデータがあります。
星取表とは、こんな感じです。相撲でよく見る、結果まとめ表です。
クロス表形式なので、縦方向にバラしています。
library("readr")
library("dplyr")
library("xtable")
dat = read_csv("winLoseDataTable.dat.no_juryou", col_names = FALSE)
## 名前をつける
names(dat) = c("tournament", "class", "name", "room_old", "opponent", "result")
## 実験用に、平成24年初場所のデータを使う
dat =
dat %>% filter(tournament == "H24-1")
## 内容確認
dat %>% head %>%
xtable %>% print(type="html")
| tournament | class | name | room_old | opponent | result | |
|---|---|---|---|---|---|---|
| 1 | H24-1 | 横綱 | 白鵬 | 宮城野26 | 若荒雄 | W |
| 2 | H24-1 | 横綱 | 白鵬 | 宮城野26 | 豪風 | W |
| 3 | H24-1 | 横綱 | 白鵬 | 宮城野26 | 安美錦 | W |
| 4 | H24-1 | 横綱 | 白鵬 | 宮城野26 | 隠岐海 | W |
| 5 | H24-1 | 横綱 | 白鵬 | 宮城野26 | 雅山 | W |
| 6 | H24-1 | 横綱 | 白鵬 | 宮城野26 | 豪栄道 | W |
データの項目の意味は、
場所名、階級、名前、部屋と年齢、対戦相手、結果
です。
1行目は、
H24年の初場所の初戦で、横綱白鵬(宮城野部屋26歳)が若荒雄にWin
という意味です。
対戦相手の項目が厄介です。四股名の略称が入っているのです。
例えば、日馬富士。
## 名前
dat %>% filter(name == "日馬富士") %>% head %>%
xtable %>% print(type="html")
| tournament | class | name | room_old | opponent | result | |
|---|---|---|---|---|---|---|
| 1 | H24-1 | 大関 | 日馬富士 | 伊勢濱27 | 隠岐海 | W |
| 2 | H24-1 | 大関 | 日馬富士 | 伊勢濱27 | 豊ノ島 | W |
| 3 | H24-1 | 大関 | 日馬富士 | 伊勢濱27 | 若荒雄 | W |
| 4 | H24-1 | 大関 | 日馬富士 | 伊勢濱27 | 豪風 | W |
| 5 | H24-1 | 大関 | 日馬富士 | 伊勢濱27 | 北太樹 | W |
| 6 | H24-1 | 大関 | 日馬富士 | 伊勢濱27 | 鶴竜 | L |
## 対戦相手
dat %>% filter(opponent == "日馬富") %>% head %>%
xtable %>% print(type="html")
| tournament | class | name | room_old | opponent | result | |
|---|---|---|---|---|---|---|
| 1 | H24-1 | 横綱 | 白鵬 | 宮城野26 | 日馬富 | L |
| 2 | H24-1 | 大関 | 把瑠都 | 尾上27 | 日馬富 | W |
| 3 | H24-1 | 大関 | 琴欧洲 | 佐渡嶽28 | 日馬富 | L |
| 4 | H24-1 | 関脇 | 鶴竜 | 井筒26 | 日馬富 | W |
| 5 | H24-1 | 小結 | 雅山 | 藤島34 | 日馬富 | L |
| 6 | H24-1 | 前頭1 | 豪風 | 尾車32 | 日馬富 | L |
4文字以上の四股名だと、対戦相手名(opponent)列に略称が格納されているのです。
困りました。場合によっては集計できません。
ここで、編集距離を使いましょう。
四股名と略称とでは、大きくは変わらないはずです。
四股名からの編集距離が最も小さいものが、略称になると考えられます。
なので、以下の手順で四股名と略称を紐つけます。
-
四股名、略称名のベクトルを作る
-
全組み合わせで編集距離を計算する
-
四股名ごとに、最も編集距離が近いものを略称と判定する
やってみます。
## name列の要素
dat_name = dat %>% select(name) %>% unique
## opponent列の要素
dat_opponent = dat %>% select(opponent) %>% unique
## それぞれの長さ
dat_name %>% dim
[1] 42 1
dat_opponent %>% dim
[1] 46 1
## 紐つけたい2つの名前列(nameとopponent)をクロス結合して
## 名前の全組み合わせで編集距離を計算
dat_stringmatch =
dat_name %>%
merge(dat_opponent)
## 本当はdplyr::mutate(dist = stringMatch(name, opponent))としたかった
## 動かないので、無理矢理mapplyする
dist_col = mapply(FUN = function(x,y){return (stringMatch(x,y, normalize = "NO"))}, dat_stringmatch$name, dat_stringmatch$opponent)
dat_stringmatch$dist = dist_col
## 距離の最小値を求める
dat_mindist =
dat_stringmatch %>%
group_by(name) %>%
summarise(dist = min(dist))
## 編集距離が最小のものを抜き出す
## 最小値と名前で結合すればいいはず
dat_stringmatch %>%
merge(dat_mindist, by = c("name", "dist")) %>%
select(name, opponent) %>%
xtable %>% print(type="html")
| name | opponent | |
|---|---|---|
| 1 | 阿覧 | 阿覧 |
| 2 | 旭秀鵬 | 旭秀鵬 |
| 3 | 旭天鵬 | 旭天鵬 |
| 4 | 安美錦 | 安美錦 |
| 5 | 隠岐の海 | 隠岐海 |
| 6 | 嘉風 | 嘉風 |
| 7 | 臥牙丸 | 臥牙丸 |
| 8 | 雅山 | 雅山 |
| 9 | 魁聖 | 魁聖 |
| 10 | 稀勢の里 | 稀勢里 |
| 11 | 琴欧洲 | 琴欧洲 |
| 12 | 琴奨菊 | 琴奨菊 |
| 13 | 高安 | 高安 |
| 14 | 豪栄道 | 豪栄道 |
| 15 | 豪風 | 豪風 |
| 16 | 佐田の富士 | 佐田富 |
| 17 | 時天空 | 時天空 |
| 18 | 若荒雄 | 若荒雄 |
| 19 | 松鳳山 | 松鳳山 |
| 20 | 千代の国 | 千代国 |
| 21 | 大道 | 大道 |
| 22 | 朝赤龍 | 朝赤龍 |
| 23 | 鶴竜 | 鶴竜 |
| 24 | 天鎧鵬 | 天鎧鵬 |
| 25 | 土佐豊 | 土佐豊 |
| 26 | 栃ノ心 | 栃ノ心 |
| 27 | 栃乃若 | 栃乃若 |
| 28 | 栃煌山 | 栃煌山 |
| 29 | 日馬富士 | 日馬富 |
| 30 | 把瑠都 | 把瑠都 |
| 31 | 白鵬 | 白鵬 |
| 32 | 富士東 | 富士東 |
| 33 | 碧山 | 碧山 |
| 34 | 芳東 | 芳東 |
| 35 | 豊ノ島 | 豊ノ島 |
| 36 | 豊響 | 豊響 |
| 37 | 豊真将 | 豊真将 |
| 38 | 北太樹 | 北太樹 |
| 39 | 妙義龍 | 妙義龍 |
| 40 | 隆の山 | 隆の山 |
| 41 | 磋牙司 | 磋牙司 |
| 42 | 鳰の湖 | 鳰の湖 |
おお!!!!!!!!できてます!!!!!
佐田の富士が佐田富に。稀勢の里が稀勢里に。日馬富士が日馬富に紐付いています。
これで、略称から元の四股名が得られました!!!
やった!!! 元データと結合すればお仕事終了です。
dat_opponent_name =
dat_stringmatch %>%
merge(dat_mindist, by = c("name", "dist")) %>%
mutate(opponent_name=name) %>%
select(opponent_name, opponent)
dat_result =
dat %>%
merge(dat_opponent_name, by = "opponent") %>%
select(tournament, class, name, room_old, opponent_name, result)
Bradley-Terryモデルで強さ推定
今まで、できなかったことをやります。
対戦相手の名前が正しく作れたため、例えばBradley-Terryモデルに投げつけることで強さの推定ができます。
library(BradleyTerry2)
## Loading required package: lme4
## Loading required package: Matrix
dat_winlose =
dat_result %>%
group_by(name, opponent_name) %>%
summarise(wins = sum(result == "W"), loses = sum(result=="L")) %>%
mutate(winner = ifelse(wins == 1, name, opponent_name)) %>%
mutate(loser = ifelse(wins == 0, name, opponent_name)) %>%
group_by(winner, loser, add=FALSE) %>%
summarise(wins = sum(wins), loses = 0)
sumoBT = BTm(outcome = cbind(wins, loses),
player1 = winner, player2 = loser,
data = dat_winlose)
## BT
sumoBTdf = BTabilities(sumoBT) %>% as.data.frame %>%
mutate(name = row.names(.)) %>%
arrange(desc(ability))
## 勝数を集計
dat_winlose_result =
dat_winlose %>% group_by(winner) %>%
summarise(wins = sum(wins)) %>%
mutate(name = winner) %>% select(-winner)
## BTモデルで推定された強さと勝数を較べてみます
sumoBTdf %>%
merge(dat_winlose_result, by = "name") %>%
arrange(desc(ability)) %>%
xtable %>% print(type="html")
| name | ability | s.e. | wins | |
|---|---|---|---|---|
| 1 | 把瑠都 | 3.79 | 1.43 | 14 |
| 2 | 白鵬 | 2.52 | 1.20 | 12 |
| 3 | 稀勢の里 | 2.12 | 1.14 | 11 |
| 4 | 日馬富士 | 2.00 | 1.15 | 11 |
| 5 | 鶴竜 | 1.73 | 1.11 | 10 |
| 6 | 琴欧洲 | 1.63 | 1.13 | 10 |
| 7 | 安美錦 | 1.23 | 1.08 | 9 |
| 8 | 臥牙丸 | 1.21 | 0.88 | 12 |
| 9 | 栃煌山 | 1.00 | 0.83 | 11 |
| 10 | 時天空 | 0.89 | 0.83 | 11 |
| 11 | 琴奨菊 | 0.83 | 1.09 | 8 |
| 12 | 栃ノ心 | 0.70 | 0.83 | 10 |
| 13 | 妙義龍 | 0.66 | 0.81 | 9 |
| 14 | 嘉風 | 0.64 | 0.79 | 9 |
| 15 | 旭天鵬 | 0.56 | 0.78 | 9 |
| 16 | 松鳳山 | 0.32 | 0.77 | 8 |
| 17 | 栃乃若 | 0.32 | 0.89 | 8 |
| 18 | 豊真将 | 0.29 | 0.92 | 7 |
| 19 | 豪栄道 | 0.25 | 1.09 | 6 |
| 20 | 高安 | 0.21 | 1.04 | 6 |
| 21 | 千代の国 | 0.15 | 0.89 | 9 |
| 22 | 豊響 | 0.05 | 0.79 | 7 |
| 23 | 阿覧 | 0.00 | 0.00 | 8 |
| 24 | 豊ノ島 | -0.11 | 1.11 | 5 |
| 25 | 若荒雄 | -0.11 | 1.11 | 5 |
| 26 | 碧山 | -0.29 | 0.80 | 6 |
| 27 | 豪風 | -0.33 | 1.10 | 4 |
| 28 | 天鎧鵬 | -0.34 | 0.86 | 8 |
| 29 | 朝赤龍 | -0.35 | 0.86 | 9 |
| 30 | 隠岐の海 | -0.44 | 1.07 | 4 |
| 31 | 佐田の富士 | -0.53 | 0.82 | 8 |
| 32 | 大道 | -0.66 | 0.81 | 6 |
| 33 | 富士東 | -0.75 | 0.83 | 7 |
| 34 | 雅山 | -0.91 | 1.16 | 3 |
| 35 | 隆の山 | -1.30 | 0.88 | 6 |
| 36 | 北太樹 | -1.40 | 1.15 | 2 |
| 37 | 磋牙司 | -1.66 | 0.90 | 5 |
| 38 | 土佐豊 | -1.91 | 0.94 | 4 |
| 39 | 魁聖 | -2.03 | 0.91 | 4 |
| 40 | 鳰の湖 | -2.03 | 0.92 | 4 |
| 41 | 芳東 | -2.34 | 0.96 | 3 |
| 42 | 旭秀鵬 | -2.44 | 0.95 | 3 |
BTモデルで推定した強さ(ability)において、最強だったの把瑠都。14勝1敗で優勝していました。
日馬富士と稀勢の里が11勝で並んでいますが、BTモデルでは稀勢の里のほうが強い、と出ています。
BTモデルにおいては、同じ1勝でも、強い相手からの1勝は高く評価されます。
逆に、弱い相手からの1勝は低く評価されます。
例えば、
千代の国が9勝しているのに順位は低いです。相手が弱かったのでしょう。
できなかったこと
name列のグループごとにdist列が最小の行を取り出す...というデータフレームの操作が出来ませんでした。
なので、dist列最小行データフレームを作って、最小値をキーにしてjoinしています。
dat_mindist =
dat_stringmatch %>%
group_by(name) %>%
summarise(dist = min(dist))
## 編集距離が距離が最小のものを抜き出す
## 最小値と名前で結合すればいいはず
dat_stringmatch %>%
merge(dat_mindist, by = c("name", "dist")) %>%
select(name, opponent)
ここをもう少しスマートにやりたいなと思いました。
まとめ
編集距離で名寄せしました。Rだと簡単にできますね。