-
Notifications
You must be signed in to change notification settings - Fork 0
/
words-menu-3.qmd
363 lines (303 loc) · 11.2 KB
/
words-menu-3.qmd
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
# 抽出語メニュー3
```{r}
#| label: setup
suppressPackageStartupMessages({
library(ggplot2)
library(duckdb)
})
drv <- duckdb::duckdb()
con <- duckdb::dbConnect(drv, dbdir = "tutorial_jp/kokoro.duckdb", read_only = TRUE)
tbl <-
readxl::read_xls("tutorial_jp/kokoro.xls",
col_names = c("text", "section", "chapter", "label"),
skip = 1
) |>
dplyr::mutate(
doc_id = factor(dplyr::row_number()),
dplyr::across(where(is.character), ~ audubon::strj_normalize(.))
) |>
dplyr::filter(!gibasa::is_blank(text)) |>
dplyr::relocate(doc_id, text, section, label, chapter)
```
## 階層的クラスター分析(A.5.9)
### 非類似度のヒートマップ🍳
Jaccard係数を指定して非類似度のヒートマップを描くと、そもそもパターンがほとんど見えなかった。
```{r}
#| label: plot-heatmap
dfm <-
dplyr::tbl(con, "tokens") |>
dplyr::filter(
pos %in% c(
"名詞", #"名詞B", "名詞C",
"地名", "人名", "組織名", "固有名詞",
"動詞", "未知語", "タグ"
)
) |>
dplyr::mutate(
token = dplyr::if_else(is.na(original), token, original),
token = paste(token, pos, sep = "/")
) |>
dplyr::count(doc_id, token) |>
dplyr::collect() |>
tidytext::cast_dfm(doc_id, token, n)
dat <- dfm |>
quanteda::dfm_trim(min_termfreq = 30, termfreq_type = "rank") |>
quanteda::dfm_weight(scheme = "boolean") |>
proxyC::simil(margin = 2, method = "dice") |>
rlang::as_function(~ 1 - .)()
factoextra::fviz_dist(as.dist(dat))
```
### 階層的クラスタリング
```{r}
#| label: hclust
clusters <-
as.dist(dat) |>
hclust(method = "ward.D2")
```
### シルエット分析🍳
```{r}
#| label: plot-hclust-silhoutte-1
factoextra::fviz_nbclust(
as.matrix(dat),
FUNcluster = factoextra::hcut,
k.max = ceiling(sqrt(nrow(dat)))
)
```
```{r}
#| label: plot-hclust-silhoutte-2
cluster::silhouette(cutree(clusters, k = 5), dist = dat) |>
factoextra::fviz_silhouette(print.summary = FALSE) +
theme_classic()
```
### デンドログラム
デンドログラムについては、似たような表現を手軽に実現できる方法が見つけられない。ラベルの位置が左右反転しているが、`factoextra::fviz_dend(horiz = TRUE)`とするのが簡単かもしれない。
```{r}
#| label: plot-hclust-factoextra
factoextra::fviz_dend(clusters, k = 5, horiz = TRUE, labels_track_height = 0.3)
```
### デンドログラムと棒グラフ
KH Coderのソースコードを見た感じ、デンドログラムと一緒に語の出現回数を描いている表現は、やや独特なことをしている。むしろ語の出現回数のほうが主な情報になってよいなら、ふつうの棒グラフの横に`ggh4x::scale_y_dendrogram()`でデンドログラムを描くことができる。
```{r}
#| label: plot-hclust-ggplot2
dfm |>
quanteda::dfm_trim(min_termfreq = 30, termfreq_type = "rank") |>
quanteda::colSums() |>
tibble::enframe() |>
dplyr::mutate(
clust = (clusters |> cutree(k = 5))[name]
) |>
ggplot(aes(x = value, y = name, fill = factor(clust))) +
geom_bar(stat = "identity", show.legend = FALSE) +
scale_x_sqrt() +
ggh4x::scale_y_dendrogram(hclust = clusters) +
labs(x = "出現回数", y = element_blank()) +
theme_bw()
```
## 共起ネットワーク(A.5.10)
### グラフの作成
描画するグラフを`tbl_graph`として作成する。
```{r}
#| label: create-graph
dfm <-
dplyr::tbl(con, "tokens") |>
dplyr::filter(
pos %in% c(
"名詞", #"名詞B", "名詞C",
"地名", "人名", "組織名", "固有名詞",
"動詞", "未知語", "タグ"
)
) |>
dplyr::mutate(
token = dplyr::if_else(is.na(original), token, original),
token = paste(token, pos, sep = "/")
) |>
dplyr::count(doc_id, token) |>
dplyr::collect() |>
tidytext::cast_dfm(doc_id, token, n)
dat <- dfm |>
quanteda::dfm_trim(min_termfreq = 45, termfreq_type = "count") |>
quanteda::dfm_weight(scheme = "boolean") |>
proxyC::simil(margin = 2, method = "jaccard", rank = 3) |>
as.matrix() |>
tidygraph::as_tbl_graph(directed = FALSE) |>
dplyr::distinct() |> # 重複を削除
tidygraph::activate(edges) |>
dplyr::filter(from != to)
dat
```
### 相関係数の計算
`ggraph::geom_edge_link2()`の`alpha`に渡す相関係数を計算する。このあたりのコードは書くのがなかなか難しかったので、あまりスマートなやり方ではないかもしれない。
KH Coderには、それぞれの共起が文書集合内のどのあたりの位置に出現したかを概観できるようにするために、共起ネットワーク中のエッジについて、共起の出現位置との相関係数によって塗り分ける機能がある。これを実現するには、まずそれぞれの文書について文書集合内での通し番号を振ったうえで、それぞれの文書についてエッジとして描きたい共起の有無を1, 0で表してから、通し番号とのあいだの相関係数を計算するということをやる。
まず、共起ネットワーク中に描きこむ共起と、それらを含む文書番号をリストアップした縦長のデータフレームをつくる。
```{r}
#| label: calc-correlations-1
#| cache: true
nodes <- tidygraph::activate(dat, nodes) |> dplyr::pull("name")
from <- nodes[tidygraph::activate(dat, edges) |> dplyr::pull("from")]
to <- nodes[tidygraph::activate(dat, edges) |> dplyr::pull("to")]
has_coocurrences <-
dplyr::tbl(con, "tokens") |>
dplyr::filter(
pos %in% c(
"名詞", #"名詞B", "名詞C",
"地名", "人名", "組織名", "固有名詞",
"動詞", "未知語", "タグ"
)
) |>
dplyr::mutate(
token = dplyr::if_else(is.na(original), token, original),
token = paste(token, pos, sep = "/")
) |>
dplyr::filter(token %in% nodes) |>
dplyr::collect() |>
dplyr::reframe(
from = from,
to = to,
has_from = purrr::map_lgl(from, ~ . %in% token),
has_to = purrr::map_lgl(to, ~ .%in% token),
.by = doc_id
) |>
dplyr::filter(has_from & has_to) |>
dplyr::group_by(from, to) |>
dplyr::reframe(doc_id = doc_id)
has_coocurrences
```
次に、このデータフレームを共起ごとにグルーピングして、共起の有無と通し番号とのあいだの相関係数を含むデータフレームをつくる。
```{r}
#| label: calc-correlations-2
#| cache: true
correlations <- has_coocurrences |>
dplyr::group_by(from, to) |>
dplyr::group_map(\(.x, .y) {
tibble::tibble(
doc_number = seq_len(nrow(tbl)),
from = which(nodes == .y$from),
to = which(nodes == .y$to)
) |>
dplyr::group_by(from, to) |>
dplyr::summarise(
cor = cor(doc_number, as.numeric(doc_number %in% .x[["doc_id"]])),
.groups = "drop"
)
}) |>
purrr::list_rbind()
correlations
```
最後に、相関係数を`tbl_graph`のエッジと結合する。
```{r}
#| label: join-correlations
dat <- dat |>
tidygraph::activate(edges) |>
dplyr::left_join(correlations, by = dplyr::join_by(from == from, to == to))
```
### 共起ネットワーク
上の処理が間違っていなければ、文書集合の後のほうによく出てくる共起であるほど、エッジの色が濃くなっているはず。
```{r}
#| label: plot-network
#| cache: true
dat |>
tidygraph::activate(nodes) |>
dplyr::mutate(
community = factor(tidygraph::group_leading_eigen())
) |>
ggraph::ggraph(layout = "fr") +
ggraph::geom_edge_link2(
aes(
alpha = dplyr::percent_rank(cor) + .01, # パーセンタイルが0だと透明になってしまうので、適当に下駄をはかせる
width = dplyr::percent_rank(weight) + 1
),
colour = "red"
) +
ggraph::geom_node_point(aes(colour = community), show.legend = FALSE) +
ggraph::geom_node_label(aes(colour = community, label = name), repel = TRUE, show.legend = FALSE) +
ggraph::theme_graph()
```
## 自己組織化マップ(A.5.11)
### 自己組織化マップ(SOM)
SOMの実装としては、KH Coderは[som](https://cran.r-project.org/package=som)を使っているようだが、[kohonen](https://cran.r-project.org/package=kohonen)を使ったほうがよい。
行列が非常に大きい場合には`kohonen::som(mode = "online")`としてもよいのかもしれないが、一般にバッチ型のほうが収束が早く、数十ステップ程度回せば十分とされる。
与える単語文書行列は、ここでは`tidytext::bind_tf_idf()`を使ってTF-IDFで重みづけし、上位100語ほど抽出する。
```{r}
#| label: fit-som
#| cache: true
dat <-
dplyr::tbl(con, "tokens") |>
dplyr::filter(
pos %in% c(
"名詞", #"名詞B", "名詞C",
"地名", "人名", "組織名", "固有名詞",
"動詞", "未知語", "タグ"
)
) |>
dplyr::mutate(
token = dplyr::if_else(is.na(original), token, original),
token = paste(token, pos, sep = "/")
) |>
dplyr::count(doc_id, token) |>
dplyr::collect() |>
tidytext::bind_tf_idf(token, doc_id, n) |>
tidytext::cast_dfm(doc_id, token, tf_idf) |>
quanteda::dfm_trim(
min_termfreq = 100,
termfreq_type = "rank"
) |>
as.matrix() |>
scale() |>
t()
som_fit <-
kohonen::som(
dat,
grid = kohonen::somgrid(20, 16, "hexagonal"),
rlen = 50, # 学習回数
alpha = c(0.05, 0.01),
radius = 8,
dist.fcts = "sumofsquares",
mode = "batch",
init = aweSOM::somInit(dat, 20, 16)
)
```
```{r}
#| label: quality-som
aweSOM::somQuality(som_fit, dat)
```
### U-Matrix
U-matrixは「各ノードの参照ベクトルが近傍ノードと異なる度合いで色づけする方法」([自己組織化マップ入門](https://www.brain.kyutech.ac.jp/~furukawa/data/SOMtext.pdf))。暖色の箇所はデータ密度が低い「山間部」で、寒色の箇所はデータ密度が高い「平野部」みたいなイメージ、写像の勾配が急峻になっている箇所を境にしてクラスタが分かれていると判断するみたいな見方をする。
```{r}
#| label: plot-umatrix
aweSOM::aweSOMsmoothdist(som_fit)
```
```{r}
#| label: plot-umatrix-interactive
aweSOM::aweSOMplot(
som_fit,
data = dat,
type = "UMatrix"
)
```
### ヒットマップ🍳
色を付けるためのクラスタリングをしておく。一部の「山間部」や「盆地」がクラスタになって、後はその他の部分みたいな感じに分かれるようだが、解釈するのに便利な感じで分かれてはくれなかったりする。
```{r}
#| label: cluster-som
clusters <- som_fit |>
purrr::pluck("codes", 1) |> # 参照ベクトル(codebook vectors)は`codes`にリストとして格納されている
dist() |>
hclust(method = "ward.D2") |>
cutree(k = 10)
```
ヒットマップ(hitmap, proportion map)は以下のような可視化の方法。ノードの中の六角形は各ノードが保持する参照ベクトルの数(比率)を表している。ノードの背景色が上のコードで得たクラスタに対応する。
```{r}
#| label: plot-hitmap
aweSOM::aweSOMplot(
som_fit,
data = dat,
type = "Hitmap",
superclass = clusters
)
```
---
```{r}
#| label: cleanup
duckdb::dbDisconnect(con)
duckdb::duckdb_shutdown(drv)
sessioninfo::session_info(info = "packages")
```