R
相撲

編集距離を使って名寄せをしたい (Bradley−Terryモデルで力士の強さを推定)

More than 3 years have passed since last update.


編集距離で名寄せ (相撲の結果から強さを推定する)


はじめに

以前、相撲の対戦結果データを作成しました。

相撲の星取表を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")

## Loading required package: statmod

## 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)列に略称が格納されているのです。

困りました。場合によっては集計できません。

ここで、編集距離を使いましょう。

四股名と略称とでは、大きくは変わらないはずです。

四股名からの編集距離が最も小さいものが、略称になると考えられます。

なので、以下の手順で四股名と略称を紐つけます。


  1. 四股名、略称名のベクトルを作る


  2. 全組み合わせで編集距離を計算する


  3. 四股名ごとに、最も編集距離が近いものを略称と判定する


やってみます。

## 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だと簡単にできますね。