Appendix A — 前処理メニュー

A.1 KH Coder風の可視化のレシピ集

Appendixでは、beta版より以前のKH Coderを参考にした、実践的な可視化の例をまとめています。論文やレポートに掲載するといったことを想定しているわけではないので、わりと躊躇なくHTMLウィジェットを使っています。

なんとなく似たような表現をめざしているだけで、KH Coderでおこなわれていた処理をRで再実装することをめざすものではありません。また、試していることが多岐にわたるため、内容やRパッケージの使い方などに誤りがある可能性があります。参考にされるなら、ご自身でもよく調べて確認しながらにしてください。

KH Coderの機能や可視化をもとにしているのではない表現については、小見出しに🍳という絵文字を付けています。

A.2 使用するデータセット

KH Coderのチュートリアル用のデータを使います。tutorial_data_3x.zipの中に含まれているtutorial_jp/kokoro.xlsというxlsファイルを次のように読み込んでおきます。

tbl <-
  readxl::read_xls("tutorial_jp/kokoro.xls",
    col_names = c("text", "section", "chapter", "label"),
    skip = 1
  ) |>
  dplyr::mutate(
    doc_id = 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)

tbl
#> # A tibble: 1,213 × 5
#>    doc_id text                                             section label chapter
#>     <int> <chr>                                            <chr>   <chr> <chr>  
#>  1      1 私はその人を常に先生と呼んでいた。だからここでもただ先生と書くだけで本名は打ち明けない。これは… [1]上_先… 上・一…… 1_01   
#>  2      2 私が先生と知り合いになったのは鎌倉である。その時私はまだ若々しい書生であった。暑中休暇を利用し… [1]上_先… 上・一…… 1_01   
#>  3      3 学校の授業が始まるにはまだ大分日数があるので鎌倉におってもよし、帰ってもよいという境遇にいた私… [1]上_先… 上・一…… 1_01   
#>  4      4 宿は鎌倉でも辺鄙な方角にあった。玉突きだのアイスクリームだのというハイカラなものには長い畷を一… [1]上_先… 上・一…… 1_01   
#>  5      5 私は毎日海へはいりに出掛けた。古い燻ぶり返った藁葺の間を通り抜けて磯へ下りると、この辺にこれほ… [1]上_先… 上・一…… 1_01   
#>  6      6 私は実に先生をこの雑沓の間に見付け出したのである。その時海岸には掛茶屋が二軒あった。私はふとし… [1]上_先… 上・一…… 1_01   
#>  7      7 私がその掛茶屋で先生を見た時は、先生がちょうど着物を脱いでこれから海へ入ろうとするところであっ… [1]上_先… 上・二…… 1_02   
#>  8      8 その西洋人の優れて白い皮膚の色が、掛茶屋へ入るや否や、すぐ私の注意を惹いた。純粋の日本の浴衣を… [1]上_先… 上・二…… 1_02   
#>  9      9 彼はやがて自分の傍を顧みて、そこにこごんでいる日本人に、一言二言何かいった。その日本人は砂の上… [1]上_先… 上・二…… 1_02   
#> 10     10 私は単に好奇心のために、並んで浜辺を下りて行く二人の後姿を見守っていた。すると彼らは真直に波の… [1]上_先… 上・二…… 1_02   
#> # ℹ 1,203 more rows

このデータでは、夏目漱石の『こころ』が段落(doc_id)ごとにひとつのテキストとして打ち込まれています。『こころ』は上中下の3部(section)で構成されていて、それぞれの部が複数の章(label, chapter)に分かれています。

A.3 語の抽出(A.2.2)

gibasaを使って形態素解析をおこない、語を抽出します。

このデータをIPA辞書を使って形態素解析すると、延べ語数は105,000語程度になります。これくらいの語数であれば、形態素解析した結果をデータフレームとしてメモリ上に読み込んでも問題ないでしょうが、ここではより大規模なテキストデータを扱う場合を想定し、結果をDuckDBデータベースに書き込むことにします。

ここではchapterごとにグルーピングしながら、段落は文に分割せずに処理します。MeCabはバッファサイズの都合上、一度に262万字くらいまで一つの文として入力できるはずですが、極端に長い入力に対してはコスト計算ができず、エラーが出る可能性があります。また、多くの文を与えればそれだけ多くの行からなるデータフレームが返されるため、一度に処理する分量は利用している環境にあわせて適当に加減したほうがよいでしょう。

KH Coderでは、IPA辞書の品詞体系をもとに変更した品詞体系が使われています。そのため、KH Coderで前処理した結果をある程度再現するためには、一部の品詞情報を書き換える必要があります。KH Coder内で使われている品詞体系については、KH Coderのレファレンスを参照してください。

また、このデータを使っているチュートリアルでは、強制抽出する語として「一人」「二人」という語を指定しています。こうした語については、本来はMeCabのユーザー辞書に追加してしまったほうがよいですが、簡単に処理するために、ここではgibasaの制約付き解析機能によって「タグ」として抽出しています(KH Coderは強制抽出した語に対して「タグ」という品詞名を与えます)。

suppressPackageStartupMessages({
  library(duckdb)
})
drv <- duckdb::duckdb()

if (!fs::file_exists("tutorial_jp/kokoro.duckdb")) {
  con <- duckdb::dbConnect(drv, dbdir = "tutorial_jp/kokoro.duckdb", read_only = FALSE)

  dbCreateTable(
    con, "tokens",
    data.frame(
      doc_id = integer(),
      section = character(),
      label = character(),
      token_id = integer(),
      token = character(),
      pos = character(),
      original = character(),
      stringsAsFactors = FALSE
    )
  )

  tbl |>
    dplyr::group_by(chapter) |>
    dplyr::group_walk(~ {
      df <- .x |>
        dplyr::mutate(
          text = stringi::stri_replace_all_regex(text, "(?<codes>([一二三四五六七八九]{1}人))", "\n${codes}\tタグ\n") |>
            stringi::stri_trim_both()
        ) |>
        gibasa::tokenize(text, doc_id, partial = TRUE) |>
        gibasa::prettify(
          col_select = c("POS1", "POS2", "POS3", "Original")
        ) |>
        dplyr::mutate(
          pos = dplyr::case_when(
            (POS1 == "タグ") ~ "タグ",
            (is.na(Original) & stringr::str_detect(token, "^[[:alpha:]]+$")) ~ "未知語",
            (POS1 == "感動詞") ~ "感動詞",
            (POS1 == "名詞" & POS2 == "一般" & stringr::str_detect(token, "^[\\p{Han}]{1}$")) ~ "名詞C",
            (POS1 == "名詞" & POS2 == "一般" & stringr::str_detect(token, "^[\\p{Hiragana}]+$")) ~ "名詞B",
            (POS1 == "名詞" & POS2 == "一般") ~ "名詞",
            (POS1 == "名詞" & POS2 == "固有名詞" & POS3 == "地域") ~ "地名",
            (POS1 == "名詞" & POS2 == "固有名詞" & POS3 == "人名") ~ "人名",
            (POS1 == "名詞" & POS2 == "固有名詞" & POS3 == "組織") ~ "組織名",
            (POS1 == "名詞" & POS2 == "形容動詞語幹") ~ "形容動詞",
            (POS1 == "名詞" & POS2 == "ナイ形容詞語幹") ~ "ナイ形容詞",
            (POS1 == "名詞" & POS2 == "固有名詞") ~ "固有名詞",
            (POS1 == "名詞" & POS2 == "サ変接続") ~ "サ変名詞",
            (POS1 == "名詞" & POS2 == "副詞可能") ~ "副詞可能",
            (POS1 == "動詞" & POS2 == "自立" & stringr::str_detect(token, "^[\\p{Hiragana}]+$")) ~ "動詞B",
            (POS1 == "動詞" & POS2 == "自立") ~ "動詞",
            (POS1 == "形容詞" & stringr::str_detect(token, "^[\\p{Hiragana}]+$")) ~ "形容詞B",
            (POS1 == "形容詞" & POS2 == "非自立") ~ "形容詞(非自立)",
            (POS1 == "形容詞") ~ "形容詞",
            (POS1 == "副詞" & stringr::str_detect(token, "^[\\p{Hiragana}]+$")) ~ "副詞B",
            (POS1 == "副詞") ~ "副詞",
            (POS1 == "助動詞" & Original %in% c("ない", "まい", "ぬ", "ん")) ~ "否定助動詞",
            .default = "その他"
          )
        ) |>
        dplyr::select(doc_id, section, label, token_id, token, pos, Original) |>
        dplyr::rename(original = Original)

      dbAppendTable(con, "tokens", df)
    })
} else {
  con <- duckdb::dbConnect(drv, dbdir = "tutorial_jp/kokoro.duckdb", read_only = TRUE)
}

A.4 コーディングルール(A.2.5)

KH Coderの強力な機能のひとつとして、「コーディングルール」によるトークンへのタグ付け機能があります。KH Coderのコーディングルールはかなり複雑な記法を扱うため、Rで完璧に再現するには相応の手間がかかりますが、一方で、コードを与えるべき抽出語を基本形とマッチングする程度であれば、次のように比較的少ないコード量で似たようなことを実現できます。

rules <- list(
  "人の死" = c("死後", "死病", "死期", "死因", "死骸", "生死", "自殺", "殉死", "頓死", "変死", "亡", "死ぬ", "亡くなる", "殺す", "亡くす", "死"),
  "恋愛" = c("愛", "恋", "愛す", "愛情", "恋人", "愛人", "恋愛", "失恋", "恋しい"),
  "友情" = c("友達", "友人", "旧友", "親友", "朋友", "友", "級友"),
  "信用・不信" = c("信用", "信じる", "信ずる", "不信", "疑い", "疑惑", "疑念", "猜疑", "狐疑", "疑問", "疑い深い", "疑う", "疑る", "警戒"),
  "病気" = c("医者", "病人", "病室", "病院", "病症", "病状", "持病", "死病", "主治医", "精神病", "仮病", "病気", "看病", "大病", "病む", "病")
)
rules_chr <- purrr::flatten_chr(rules)

codes <-
  dplyr::tbl(con, "tokens") |>
  dplyr::filter(original %in% rules_chr) |>
  dplyr::collect() |>
  dplyr::mutate(
    codings = purrr::map(
      original,
      ~ purrr::imap(rules, \(.x, .y) tibble::tibble(code = .y, flag = . %in% .x)) |>
        purrr::list_rbind() |>
        dplyr::filter(flag == TRUE) |>
        dplyr::select(!flag)
    )
  ) |>
  tidyr::unnest(codings)

codes
#> # A tibble: 537 × 8
#>    doc_id section        label  token_id token    pos      original code      
#>     <int> <chr>          <chr>     <int> <chr>    <chr>    <chr>    <chr>     
#>  1      2 [1]上_先生と私 上・一       36 友達     名詞     友達     友情      
#>  2      2 [1]上_先生と私 上・一       96 友達     名詞     友達     友情      
#>  3      2 [1]上_先生と私 上・一      115 病気     サ変名詞 病気     病気      
#>  4      2 [1]上_先生と私 上・一      124 友達     名詞     友達     友情      
#>  5      2 [1]上_先生と私 上・一      128 信じ     動詞     信じる   信用・不信
#>  6      2 [1]上_先生と私 上・一      132 友達     名詞     友達     友情      
#>  7      2 [1]上_先生と私 上・一      240 病気     サ変名詞 病気     病気      
#>  8      3 [1]上_先生と私 上・一       44 友達     名詞     友達     友情      
#>  9     19 [1]上_先生と私 上・三      207 疑っ     動詞     疑う     信用・不信
#> 10     21 [1]上_先生と私 上・四      161 亡くなっ 動詞     亡くなる 人の死    
#> # ℹ 527 more rows

また、集計するだけだったらquanteda::dictionary()を使うのが手っ取り早いです。

rules <- quanteda::dictionary(rules)

dfm <-
  dplyr::tbl(con, "tokens") |>
  dplyr::mutate(token = dplyr::if_else(is.na(original), token, original)) |>
  dplyr::count(doc_id, token) |>
  dplyr::collect() |>
  tidytext::cast_dfm(doc_id, token, n) |>
  quanteda::dfm_lookup(rules)

dfm
#> Document-feature matrix of: 1,213 documents, 5 features (94.23% sparse) and 0 docvars.
#>     features
#> docs 人の死 恋愛 友情 信用・不信 病気
#>    1      0    0    0          0    0
#>    2      0    0    4          1    2
#>    3      0    0    1          0    0
#>    4      0    0    0          0    0
#>    6      0    0    0          0    0
#>    7      0    0    0          0    0
#> [ reached max_ndoc ... 1,207 more documents ]

A.5 抽出語リスト(A.3.4)

「エクスポート」メニューから得られるような抽出語リストをデータフレームとして得る例です。

Excel向けの出力は見やすいようにカラムを分けていますが、Rのデータフレームとして扱うならtidyな縦長のデータにしたほうがよいです。

A.5.1 品詞別・上位15語

dplyr::tbl(con, "tokens") |>
  dplyr::filter(
    !pos %in% c("その他", "名詞B", "動詞B", "形容詞B", "副詞B", "否定助動詞", "形容詞(非自立)")
  ) |>
  dplyr::mutate(token = dplyr::if_else(is.na(original), token, original)) |>
  dplyr::count(token, pos) |>
  dplyr::slice_max(n, n = 15, by = pos) |>
  dplyr::collect()
#> # A tibble: 232 × 3
#>    token pos       n
#>    <chr> <chr> <dbl>
#>  1 二人  タグ    115
#>  2 一人  タグ     73
#>  3 三人  タグ     10
#>  4 日蓮  人名     10
#>  5 乃木  人名      8
#>  6 寧    人名      6
#>  7 鄭    人名      6
#>  8 ちよ  人名      6
#>  9 房州  人名      5
#> 10 源    人名      5
#> # ℹ 222 more rows

A.5.2 頻出150語

dplyr::tbl(con, "tokens") |>
  dplyr::filter(
    !pos %in% c("その他", "名詞B", "動詞B", "形容詞B", "副詞B", "否定助動詞", "形容詞(非自立)")
  ) |>
  dplyr::mutate(token = dplyr::if_else(is.na(original), token, original)) |>
  dplyr::count(token, pos) |>
  dplyr::slice_max(n, n = 150) |>
  dplyr::collect()
#> # A tibble: 152 × 3
#>    token  pos        n
#>    <chr>  <chr>  <dbl>
#>  1 先生   名詞     595
#>  2 K      未知語   411
#>  3 奥さん 名詞     388
#>  4 思う   動詞     293
#>  5 父     名詞C    269
#>  6 自分   名詞     264
#>  7 見る   動詞     225
#>  8 聞く   動詞     218
#>  9 出る   動詞     179
#> 10 人     名詞C    176
#> # ℹ 142 more rows

A.6 「文書・抽出語」表(A.3.5)

いわゆる文書単語行列の例です。dplyr::collectした後にtidyr::pivot_wider()などで横に展開してもよいですが、多くの場合、疎行列のオブジェクトにしてしまったほうが、この後にRでの解析に用いる上では扱いやすいと思われます。quantedaのdfmオブジェクトをふつうの密な行列にしたいときは、as.matrix(dfm)すればよいです。

dfm <-
  dplyr::tbl(con, "tokens") |>
  dplyr::filter(
    !pos %in% c("その他", "名詞B", "動詞B", "形容詞B", "副詞B", "否定助動詞", "形容詞(非自立)")
  ) |>
  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) |>
  quanteda::dfm_trim(min_termfreq = 75, termfreq_type = "rank")

quanteda::docvars(dfm, "section") <-
  dplyr::filter(tbl, doc_id %in% quanteda::docnames(dfm)) |>
  dplyr::pull("section")

dfm
#> Document-feature matrix of: 1,189 documents, 76 features (92.93% sparse) and 1 docvar.
#>     features
#> docs 行く/動詞 東京/地名 知る/動詞 外/名詞C 先生/名詞 一人/タグ 前/副詞可能
#>    2         1         1         0        0         1         1           0
#>    3         0         0         0        0         0         1           0
#>    4         0         0         0        0         0         0           0
#>    5         0         0         1        0         0         1           0
#>    6         1         0         0        1         1         0           0
#>    7         0         0         0        0         5         1           0
#>     features
#> docs 見る/動詞 出る/動詞 見える/動詞
#>    2         0         0           0
#>    3         0         0           0
#>    4         0         0           0
#>    5         0         0           0
#>    6         0         0           0
#>    7         1         0           0
#> [ reached max_ndoc ... 1,183 more documents, reached max_nfeat ... 66 more features ]

A.7 「文書・コード」表(A.3.6)

「文書・コード」行列の例です。コードの出現頻度ではなく「コードの有無をあらわす2値変数」を出力します。

dfm <- codes |>
  dplyr::count(doc_id, code) |>
  tidytext::cast_dfm(doc_id, code, n) |>
  quanteda::dfm_weight(scheme = "boolean")

quanteda::docvars(dfm, "section") <-
  dplyr::filter(tbl, doc_id %in% quanteda::docnames(dfm)) |>
  dplyr::pull("section")

dfm
#> Document-feature matrix of: 294 documents, 5 features (76.19% sparse) and 1 docvar.
#>     features
#> docs 信用・不信 友情 病気 人の死 恋愛
#>   2           1    1    1      0    0
#>   3           0    1    0      0    0
#>   19          1    0    0      0    0
#>   21          0    0    0      1    0
#>   37          0    0    0      1    0
#>   49          0    1    0      0    0
#> [ reached max_ndoc ... 288 more documents ]

A.8 「抽出語・文脈ベクトル」表(A.3.7)

A.8.1 word2vec🍳

Caution

以下で扱っているベクトルは、KH Coderにおける「抽出語・文脈ベクトル」とは異なるものです

KH Coderにおける「文脈ベクトル」は、これを使って抽出語メニューからおこなえるような分析をすることによって、「似たような使われ方をする語を調べる」使い方をするためのものだと思われます。

「似たような使われ方をする語を調べる」ためであれば、単語埋め込みを使ってもよさそうです。ただし、KH Coderの「文脈ベクトル」を使う場合の「似たような使われ方をする」が、あくまで分析対象とする文書のなかでという意味であるのに対して、単語埋め込みを使う場合では、埋め込みの学習に使われた文書のなかでという意味になってしまう点に注意が必要です。

試しに、既存のword2vecモデルから単語ベクトルを読み込んでみます。ここでは、Wikipedia2Vecの100次元のものを使います。だいぶ古いモデルですが、MeCab+IPA辞書で分かち書きされた語彙を使っていることが確認できる単語埋め込みとなると(参考)、これくらいの時期につくられたものになりそうです。

# word2vecのテキスト形式のファイルは、先頭行に埋め込みの「行数 列数」が書かれている
readr::read_lines("tutorial_jp/jawiki_20180420_100d.txt.bz2", n_max = 1)
#> [1] "1593143 100"

# 下のほうは低頻度語で、全部読み込む必要はないと思われるので、ここでは先頭から1e5行だけ読み込む
embeddings <-
  readr::read_delim(
    "tutorial_jp/jawiki_20180420_100d.txt.bz2",
    delim = " ",
    col_names = c("token", paste0("dim_", seq_len(100))),
    skip = 1,
    n_max = 1e5,
    show_col_types = FALSE
  )

# メモリ上でのサイズ
lobstr::obj_size(embeddings)
#> 117.94 MB

このうち、分析対象の文書に含まれる語彙のベクトルだけを適当に取り出しておきます。

embeddings <-
  dplyr::tbl(con, "tokens") |>
  dplyr::filter(
    !pos %in% c("その他", "名詞B", "動詞B", "形容詞B", "副詞B", "否定助動詞", "形容詞(非自立)")
  ) |>
  dplyr::transmute(
    doc_id = doc_id,
    token = token,
    label = paste(token, pos, sep = "/")
  ) |>
  dplyr::distinct(doc_id, token, .keep_all = TRUE) |>
  dplyr::collect() |>
  dplyr::inner_join(embeddings, by = dplyr::join_by(token == token))

embeddings
#> # A tibble: 10,578 × 103
#>    doc_id token  label      dim_1   dim_2   dim_3   dim_4   dim_5   dim_6  dim_7
#>     <int> <chr>  <chr>      <dbl>   <dbl>   <dbl>   <dbl>   <dbl>   <dbl>  <dbl>
#>  1      1 遠慮   遠慮/サ変名詞…  0.653  -0.404  -0.112  -0.242   0.114   0.155  0.0425
#>  2      2 勧     勧/人名   1.00   -0.378  -0.202   0.621   0.344  -1.16   0.444 
#>  3      2 工面   工面/サ変名詞…  0.87   -0.640  -0.308  -0.534  -0.351   0.582  0.300 
#>  4      2 暑中   暑中/名詞……  0.962   0.0949 -0.0537 -0.0839  0.0502 -0.568  0.952 
#>  5      2 金     金/名詞C  0.389  -0.466   0.103  -0.0886  0.261  -0.453  0.682 
#>  6      3 変り   変り/名詞…… -0.0866 -0.638   0.234   0.258  -0.0035 -0.183  0.259 
#>  7      4 行っ   行っ/動詞……  0.428   0.0491  0.158   0.505  -0.436   0.123  0.460 
#>  8      5 燻     燻/名詞C  0.231  -0.448   0.449   0.158  -0.0838 -0.798  0.818 
#>  9      6 見付け 見付け/動詞……  0.888  -0.274  -0.0161  0.0271  0.264   0.0593 0.428 
#> 10     10 広々   広々/副詞……  0.136  -0.0064  0.673   0.406   0.350   0.438  0.496 
#> # ℹ 10,568 more rows
#> # ℹ 93 more variables: dim_8 <dbl>, dim_9 <dbl>, dim_10 <dbl>, dim_11 <dbl>,
#> #   dim_12 <dbl>, dim_13 <dbl>, dim_14 <dbl>, dim_15 <dbl>, dim_16 <dbl>,
#> #   dim_17 <dbl>, dim_18 <dbl>, dim_19 <dbl>, dim_20 <dbl>, dim_21 <dbl>,
#> #   dim_22 <dbl>, dim_23 <dbl>, dim_24 <dbl>, dim_25 <dbl>, dim_26 <dbl>,
#> #   dim_27 <dbl>, dim_28 <dbl>, dim_29 <dbl>, dim_30 <dbl>, dim_31 <dbl>,
#> #   dim_32 <dbl>, dim_33 <dbl>, dim_34 <dbl>, dim_35 <dbl>, dim_36 <dbl>, …

A.8.2 独立成分分析(ICA)🍳

word2vecを含む埋め込み表現は、「独立成分分析(ICA)で次元削減することで、人間にとって解釈性の高い成分を取り出すことができる」ことが知られています(参考)。これを応用すると、ICAで取り出した成分をもとにして、コーディングルールにするとよさそうなカテゴリや語彙を探索できるかもしれません。

ica <- embeddings |>
  dplyr::select(label, dplyr::starts_with("dim")) |>
  dplyr::distinct() |>
  tibble::column_to_rownames("label") |>
  as.matrix() |>
  fastICA::fastICA(n.comp = 20)

dat <- ica$S |>
  rlang::as_function(~ {
    . * sign(moments::skewness(.)) # 正方向のスコアだけを扱うため、歪度が負の成分を変換する
  })() |>
  dplyr::as_tibble(
    .name_repair = ~ paste("dim", stringr::str_pad(seq_along(.), width = 2, pad = "0"), sep = "_"),
    rownames = "label"
  ) |>
  tidyr::pivot_longer(cols = !label, names_to = "dim", values_to = "score")

ここでは正方向のスコアだけを扱うため、歪度が負の成分を正方向に変換する処理をしています。もちろん、実際には負の方向のスコアが大きい語彙とあわせて解釈したほうがわかりやすい成分もありそうなことからも、そのあたりも含めてそれぞれの成分を探索し、ほかの分析とも組み合わせながらコーディングルールを考えるべきでしょう。

各成分の正方向のスコアが大きい語彙を図示すると次のような感じになります。

library(ggplot2)

dat |>
  dplyr::slice_max(score, n = 8, by = dim) |>
  ggplot(aes(x = reorder(label, score), y = score)) +
  geom_col() +
  coord_flip() +
  facet_wrap(vars(dim), ncol = 4, scales = "free_y") +
  theme_minimal() +
  labs(x = NULL, y = NULL)

実際にはこうして得られたスコアの大きい語をそのままコーディングルールとして採用することはしないほうがよいでしょうが、ここから次のようにして「文書・コード」表をつくることもできます。

rules <- dat |>
  dplyr::slice_max(score, n = 10, by = dim) |>
  dplyr::reframe(
    label = list(label),
    .by = dim
  ) |>
  tibble::deframe()

codes <-
  embeddings |>
  dplyr::select(doc_id, label) |>
  dplyr::filter(label %in% purrr::flatten_chr(rules)) |>
  dplyr::mutate(
    codings = purrr::map(
      label,
      ~ purrr::imap(rules, \(.x, .y) tibble::tibble(code = .y, flag = . %in% .x)) |>
        purrr::list_rbind() |>
        dplyr::filter(flag == TRUE) |>
        dplyr::select(!flag)
    )
  ) |>
  tidyr::unnest(codings)

dfm <- codes |>
  dplyr::count(doc_id, code) |>
  tidytext::cast_dfm(doc_id, code, n) |>
  quanteda::dfm_weight(scheme = "boolean")

dfm
#> Document-feature matrix of: 347 documents, 20 features (93.14% sparse) and 0 docvars.
#>     features
#> docs dim_04 dim_14 dim_05 dim_01 dim_17 dim_19 dim_06 dim_15 dim_20 dim_08
#>    2      1      1      0      0      0      0      0      0      0      0
#>    3      0      0      1      0      0      0      0      0      0      0
#>    4      0      0      0      1      0      0      0      0      0      0
#>    5      0      0      0      1      1      1      0      0      0      0
#>    6      0      0      0      0      0      0      1      0      0      0
#>    7      1      0      0      0      0      0      0      0      0      0
#> [ reached max_ndoc ... 341 more documents, reached max_nfeat ... 10 more features ]

duckdb::dbDisconnect(con)
duckdb::duckdb_shutdown(drv)

sessioninfo::session_info(info = "packages")
#> ═ Session info ═══════════════════════════════════════════════════════════════
#> ─ Packages ───────────────────────────────────────────────────────────────────
#>  package      * version  date (UTC) lib source
#>  audubon        0.5.2    2024-04-27 [1] RSPM (R 4.5.0)
#>  bit            4.6.0    2025-03-06 [1] RSPM (R 4.5.0)
#>  bit64          4.6.0-1  2025-01-16 [1] RSPM (R 4.5.0)
#>  blob           1.2.4    2023-03-17 [1] RSPM
#>  cachem         1.1.0    2024-05-16 [1] RSPM
#>  cellranger     1.1.0    2016-07-27 [1] RSPM (R 4.5.0)
#>  cli            3.6.5    2025-04-23 [1] RSPM
#>  codetools      0.2-20   2024-03-31 [2] CRAN (R 4.5.1)
#>  crayon         1.5.3    2024-06-20 [1] RSPM
#>  curl           7.0.0    2025-08-19 [1] RSPM
#>  DBI          * 1.2.3    2024-06-02 [1] RSPM (R 4.5.0)
#>  dbplyr         2.5.1    2025-09-10 [1] RSPM
#>  digest         0.6.37   2024-08-19 [1] RSPM
#>  dplyr          1.1.4    2023-11-17 [1] RSPM (R 4.5.0)
#>  duckdb       * 1.4.0    2025-09-18 [1] RSPM (R 4.5.0)
#>  evaluate       1.0.5    2025-08-27 [1] RSPM
#>  farver         2.1.2    2024-05-13 [1] RSPM (R 4.5.0)
#>  fastICA        1.2-7    2024-12-11 [1] RSPM (R 4.5.0)
#>  fastmap        1.2.0    2024-05-15 [1] RSPM
#>  fastmatch      1.1-6    2024-12-23 [1] RSPM (R 4.5.0)
#>  fs             1.6.6    2025-04-12 [1] RSPM
#>  generics       0.1.4    2025-05-09 [1] RSPM (R 4.5.0)
#>  ggplot2      * 4.0.0    2025-09-11 [1] RSPM (R 4.5.0)
#>  gibasa         1.1.2    2025-02-16 [1] RSPM (R 4.5.0)
#>  glue           1.8.0    2024-09-30 [1] RSPM
#>  gtable         0.3.6    2024-10-25 [1] RSPM (R 4.5.0)
#>  hms            1.1.3    2023-03-21 [1] RSPM (R 4.5.0)
#>  htmltools      0.5.8.1  2024-04-04 [1] RSPM
#>  htmlwidgets    1.6.4    2023-12-06 [1] RSPM
#>  janeaustenr    1.0.0    2022-08-26 [1] RSPM (R 4.5.0)
#>  jsonlite       2.0.0    2025-03-27 [1] RSPM
#>  knitr          1.50     2025-03-16 [1] RSPM
#>  labeling       0.4.3    2023-08-29 [1] RSPM (R 4.5.0)
#>  lattice        0.22-7   2025-04-02 [2] CRAN (R 4.5.1)
#>  lifecycle      1.0.4    2023-11-07 [1] RSPM
#>  lobstr         1.1.2    2022-06-22 [1] RSPM (R 4.5.0)
#>  magrittr       2.0.4    2025-09-12 [1] RSPM
#>  Matrix         1.7-3    2025-03-11 [2] CRAN (R 4.5.1)
#>  memoise        2.0.1    2021-11-26 [1] RSPM
#>  moments        0.14.1   2022-05-02 [1] RSPM (R 4.5.0)
#>  pillar         1.11.1   2025-09-17 [1] RSPM
#>  pkgconfig      2.0.3    2019-09-22 [1] RSPM
#>  prettyunits    1.2.0    2023-09-24 [1] RSPM
#>  purrr          1.1.0    2025-07-10 [1] RSPM
#>  quanteda       4.3.1    2025-07-10 [1] RSPM (R 4.5.0)
#>  R.cache        0.17.0   2025-05-02 [1] RSPM
#>  R.methodsS3    1.8.2    2022-06-13 [1] RSPM
#>  R.oo           1.27.1   2025-05-02 [1] RSPM
#>  R.utils        2.13.0   2025-02-24 [1] RSPM
#>  R6             2.6.1    2025-02-15 [1] RSPM
#>  RColorBrewer   1.1-3    2022-04-03 [1] RSPM (R 4.5.0)
#>  Rcpp           1.1.0    2025-07-02 [1] RSPM
#>  RcppParallel   5.1.11-1 2025-08-27 [1] RSPM (R 4.5.0)
#>  readr          2.1.5    2024-01-10 [1] RSPM (R 4.5.0)
#>  readxl         1.4.5    2025-03-07 [1] RSPM (R 4.5.0)
#>  rlang          1.1.6    2025-04-11 [1] RSPM
#>  rmarkdown      2.30     2025-09-28 [1] RSPM (R 4.5.0)
#>  S7             0.2.0    2024-11-07 [1] RSPM (R 4.5.0)
#>  scales         1.4.0    2025-04-24 [1] RSPM (R 4.5.0)
#>  sessioninfo    1.2.3    2025-02-05 [1] RSPM
#>  SnowballC      0.7.1    2023-04-25 [1] RSPM (R 4.5.0)
#>  stopwords      2.3      2021-10-28 [1] RSPM (R 4.5.0)
#>  stringi        1.8.7    2025-03-27 [1] RSPM
#>  stringr        1.5.2    2025-09-08 [1] RSPM
#>  styler         1.10.3   2024-04-07 [1] RSPM
#>  tibble         3.3.0    2025-06-08 [1] RSPM
#>  tidyr          1.3.1    2024-01-24 [1] RSPM (R 4.5.0)
#>  tidyselect     1.2.1    2024-03-11 [1] RSPM (R 4.5.0)
#>  tidytext       0.4.3    2025-07-25 [1] RSPM (R 4.5.0)
#>  tokenizers     0.3.0    2022-12-22 [1] RSPM (R 4.5.0)
#>  tzdb           0.5.0    2025-03-15 [1] RSPM (R 4.5.0)
#>  utf8           1.2.6    2025-06-08 [1] RSPM
#>  V8             8.0.0    2025-09-27 [1] RSPM (R 4.5.0)
#>  vctrs          0.6.5    2023-12-01 [1] RSPM
#>  vroom          1.6.6    2025-09-19 [1] RSPM (R 4.5.0)
#>  withr          3.0.2    2024-10-28 [1] RSPM
#>  xfun           0.53     2025-08-19 [1] RSPM
#>  yaml           2.3.10   2024-07-26 [1] RSPM
#> 
#>  [1] /usr/local/lib/R/site-library
#>  [2] /usr/local/lib/R/library
#>  * ── Packages attached to the search path.
#> 
#> ──────────────────────────────────────────────────────────────────────────────