準備
library(tidyverse)
set.seed(71)集合の類似度
集合の要素を比較するための類似度としていくつかのインデックスが知られています。ここではその中でJaccard係数/Dice係数/Simpson係数をRで計算してみましょう。
cf. 【技術解説】集合の類似度(Jaccard係数，Dice係数，Simpson係数)
- Jaccard index
\[ J(A,B)=\frac{|A\cap B|}{|A \cup B|} \]
- Sørensen–Dice index
\[ DSC(A,B)=\frac{2|A\cap B|}{|A| + |B|} \]
- Simpson index (Overlap coefficient)
\[ overlap(A,B)=\frac{|A\cap B|}{min(|A|, |B|)} \]
capやcupの計算
2つのベクトルを用意します。
vec1 <- sample(1:80, 50)
vec2 <- sample(40:120, 50)2つのベクトルの共通要素からなるベクトルを求めるにはbase::intersect()関数を用います。必要な\(|A \cap B|\)はその要素数なのでlength()関数でベクトルの大きさを求めます。
capN <- intersect(vec1, vec2) %>% length()\(|A \cup B|\)は和集合の重複を除いたサイズです。いくつか求め方はあると思いますが、例えば以下のようにします。
cupN <- c(vec1, vec2) %>% factor() %>% levels() %>% length()ここからJaccard indexは直ちに求まります。
capN / cupN## [1] 0.1627907凝ったサンプルデータ
もう少し凝ったサンプルを作ってみましょう。
dat <-
tibble(tag = LETTERS[1:4],
n = c(50, 40, 30, 80)) %>%
mutate(range = list(1:80, 40:120, 70:160, c(1:50, 100:140))) %>%
mutate(value = map2(range, n, sample)) %>%
select(tag, value) %>%
unnest(value)dat## # A tibble: 200 × 2
## tag value
## <chr> <int>
## 1 A 72
## 2 A 43
## 3 A 74
## 4 A 50
## 5 A 23
## 6 A 60
## 7 A 68
## 8 A 41
## 9 A 4
## 10 A 10
## # … with 190 more rowsごちゃごちゃやっていますが、得られたdatオブジェクトにはtagカラムで対応づけられた4群が含まれています。それぞれnで指定された数だけ整数値を持ち、valueカラムに格納されています。整数値はrangeで指定した範囲からランダムに重複なくサンプルされます。
データの概要はtagカラムをキーにしてデータを畳み込むとよく分かります。
dat_nest <-
group_nest(dat, tag)
dat_nest## # A tibble: 4 × 2
## tag data
## <chr> <list<tibble[,1]>>
## 1 A [50 × 1]
## 2 B [40 × 1]
## 3 C [30 × 1]
## 4 D [80 × 1]それぞれに畳み込まれているデータは例えば次のように取り出すことができます。
dat_nest$data[[1]] %>% c()## $value
## [1] 72 43 74 50 23 60 68 41 4 10 28 44 73 8 53 42 49 75 67 58 77 1 25 48 47
## [26] 18 38 37 12 80 71 54 36 3 6 32 19 65 20 16 9 5 56 11 31 62 51 45 39 55総当たり組み合わせ
さて、この4群の総当たり組み合わせでさまざまな集合の類似度を求めてみましょう。総当たり組み合わせを作るやり方は色々とありますが、僕が作ったroundrobinパッケージが便利です。github上で公開しているのでinstall_github()関数でインストールすることができます。
devtools::install_github("kilometer0101/roundrobin")このパッケージに含まれているroundrobin()関数を使うと、data.frameもしくはtibbleを指定したカラムの水準に応じてたたみ込んだのち、総当たり組み合わせを作ってくれます。畳み込む水準はkey引数で指定しますが、文字列で指定してください。
dat_rr <-
dat %>%
roundrobin::roundrobin(key = "tag")
dat_rr## # A tibble: 16 × 4
## Var1 Var2 data.x data.y
## <chr> <chr> <list<tibble[,1]>> <list<tibble[,1]>>
## 1 A A [50 × 1] [50 × 1]
## 2 B A [40 × 1] [50 × 1]
## 3 C A [30 × 1] [50 × 1]
## 4 D A [80 × 1] [50 × 1]
## 5 A B [50 × 1] [40 × 1]
## 6 B B [40 × 1] [40 × 1]
## 7 C B [30 × 1] [40 × 1]
## 8 D B [80 × 1] [40 × 1]
## 9 A C [50 × 1] [30 × 1]
## 10 B C [40 × 1] [30 × 1]
## 11 C C [30 × 1] [30 × 1]
## 12 D C [80 × 1] [30 × 1]
## 13 A D [50 × 1] [80 × 1]
## 14 B D [40 × 1] [80 × 1]
## 15 C D [30 × 1] [80 × 1]
## 16 D D [80 × 1] [80 × 1]便利ですね！
indexを求める
この総当たり組み合わせで畳み込まれたデータを使って効率的に様々なindexを計算してみましょう。
計算に使う\(|A|+|B|\)、\(\min(|A|,|B|)\)、\(|A \cap B|\)、\(|A \cup B|\)を準備しておきましょう。
dat_for_index <-
dat_rr %>%
mutate(size_sum = map2_dbl(data.x, data.y, ~ nrow(.x) + nrow(.y)),
size_min = map2_dbl(data.x, data.y, ~ min(nrow(.x), nrow(.y)))) %>%
mutate(cap = map2_dbl(data.x, data.y, ~ intersect(.x, .y) %>% nrow()),
cup = map2_dbl(data.x, data.y, ~ bind_rows(.x, .y) %>% distinct() %>% nrow()))
dat_for_index## # A tibble: 16 × 8
## Var1 Var2 data.x data.y size_sum size_min cap cup
## <chr> <chr> <list<tibble[,1]>> <list<tibble[,1> <dbl> <dbl> <dbl> <dbl>
## 1 A A [50 × 1] [50 × 1] 100 50 50 50
## 2 B A [40 × 1] [50 × 1] 90 40 12 78
## 3 C A [30 × 1] [50 × 1] 80 30 5 75
## 4 D A [80 × 1] [50 × 1] 130 50 26 104
## 5 A B [50 × 1] [40 × 1] 90 40 12 78
## 6 B B [40 × 1] [40 × 1] 80 40 40 40
## 7 C B [30 × 1] [40 × 1] 70 30 6 64
## 8 D B [80 × 1] [40 × 1] 120 40 16 104
## 9 A C [50 × 1] [30 × 1] 80 30 5 75
## 10 B C [40 × 1] [30 × 1] 70 30 6 64
## 11 C C [30 × 1] [30 × 1] 60 30 30 30
## 12 D C [80 × 1] [30 × 1] 110 30 9 101
## 13 A D [50 × 1] [80 × 1] 130 50 26 104
## 14 B D [40 × 1] [80 × 1] 120 40 16 104
## 15 C D [30 × 1] [80 × 1] 110 30 9 101
## 16 D D [80 × 1] [80 × 1] 160 80 80 80で、定義式をみながらこんな感じ。
dat_index <-
dat_for_index %>%
mutate(Jaccard = cap / cup,
Dice = cap * 2 / size_sum,
Simpson = cap / size_min) %>%
select(Var1, Var2, Jaccard, Dice, Simpson)
dat_index## # A tibble: 16 × 5
## Var1 Var2 Jaccard Dice Simpson
## <chr> <chr> <dbl> <dbl> <dbl>
## 1 A A 1 1 1
## 2 B A 0.154 0.267 0.3
## 3 C A 0.0667 0.125 0.167
## 4 D A 0.25 0.4 0.52
## 5 A B 0.154 0.267 0.3
## 6 B B 1 1 1
## 7 C B 0.0938 0.171 0.2
## 8 D B 0.154 0.267 0.4
## 9 A C 0.0667 0.125 0.167
## 10 B C 0.0938 0.171 0.2
## 11 C C 1 1 1
## 12 D C 0.0891 0.164 0.3
## 13 A D 0.25 0.4 0.52
## 14 B D 0.154 0.267 0.4
## 15 C D 0.0891 0.164 0.3
## 16 D D 1 1 1可視化
可視化はどうしましょうか。heatmap風にしてみましょう。
dat_g <-
dat_index %>%
pivot_longer(cols = !c(Var1, Var2),
names_to = "index",
values_to = "value")ggplot(dat_g) +
aes(Var1, Var2, fill = value) +
geom_tile() +
scale_fill_gradient(low = "white", high = "blue") +
scale_x_discrete(expand = c(0,0)) +
scale_y_discrete(expand = c(0,0)) +
facet_wrap(~ index)
簡単ですね！！
2022年6月1日