Сеть совместной встречаемости персонажей героев текстовых арифметических задач

Введение

В этом документе представлен анализ графа персонажей, построенного на основе совместных появлений в арифметических задачах (N=44177). Исходные данные содержат строки с именами персонажей, разделёнными запятыми.

Как выглядят данные

library(tidyverse)
library(knitr)
library(DT)
library(igraph)
library(ggraph)

# файл с данными заранее подготовлен
tasks <- read_tsv("tasks.txt", 
                  col_names = c("year", "text", "characters"),
                  locale = locale(encoding = "UTF-8")) |>
  filter(!is.na(year), !is.na(text))

# Случайная выборка из 100 задач (всего в файле 44177 задач)
set.seed(123)
random_100 <- tasks |> sample_n(100)

# Интерактивная таблица, показывает по 10 строк
datatable(random_100,
          colnames = c("Год", "Задача", "Персонажи"),
          options = list(pageLength = 10,
                         language = list(search = "Поиск:"),
                         dom = 'Bfrtip'),
          caption = htmltools::tags$caption(
            style = 'caption-side: top; text-align: center; font-size: 1.2em;',
            '100 случайных задач из коллекции (1703–1963 гг.)'
          ))

Подготавливаем данные для отрисовки графа

Этот код в режиме реального времени выполняться не будет, слишком долго, он выполнился локально один раз и сохранен в файл, данные для отрисовки подгружаются из файла

 # Обработка строк
  problems <- raw_lines |>
    str_split(",") |>
    map(str_trim) |>
    map(~ .x[.x != ""]) |>
    keep(~ length(.x) > 0)
  
  # Подсчёт упоминаний персонажей
  mention_counts <- tibble(character = unlist(problems)) |>
    count(character, name = "mentions")
  
  # Создаём пустой граф
  g <- make_empty_graph(directed = FALSE)
  
  # Добавляем вершины
  g <- add_vertices(g, nrow(mention_counts), 
                    name = mention_counts$character,
                    mentions = mention_counts$mentions)
  
  # словарь для весов рёбер
  edge_weights <- list()
  
  # Проходим по каждой задаче
  for (prob in problems) {
    if (length(prob) < 2) next
    pairs <- combn(prob, 2, simplify = FALSE)
    for (pair in pairs) {
      key <- paste(sort(pair), collapse = "|")
      if (is.null(edge_weights[[key]])) {
        edge_weights[[key]] <- 1
      } else {
        edge_weights[[key]] <- edge_weights[[key]] + 1
      }
    }
  }
  
  # Добавляем рёбра в граф
  if (length(edge_weights) > 0) {
    edge_list <- map2(names(edge_weights), edge_weights, function(k, w) {
      nodes <- str_split(k, "\\|")[[1]]
      data.frame(from = nodes[1], to = nodes[2], weight = w)
    }) |> bind_rows()
    
    g <- add_edges(g, t(as.matrix(edge_list[, c("from", "to")])), 
                   weight = edge_list$weight)

Эти данные лежат в “graph_cache.rds”, вынимаем их из файла

cache_file <- "graph_cache.rds"

g <- readRDS(cache_file)

# Вычисляем степень и взвешенную степень
V(g)$degree <- degree(g)
V(g)$strength <- strength(g, weights = E(g)$weight)


s <- summary(g)

IGRAPH 404c293 UNW- 4015 7463 -- 
+ attr: name (v/c), mentions (v/n), degree (v/n), strength (v/n),
| weight (e/n)

vcount(g) # количество вершин

[1] 4015

ecount(g) # количество ребер

[1] 7463

edge_density(g)  # плотность графа

[1] 0.0009261483

Подграф

k-core

Так как персонажей в нашем корпусе более 4000, мы выделим подграф - k-ядро методом k-core (экспериментальным путем лучше всего k=10):

cores <- coreness(g)
table(cores)

cores
   0    1    2    3    4    5    6    7    8    9   10   11   12   13   49 
 957 1095  744  449  276  167   69   33   17   15   53   17   11   62   50 

# Выделяем ядро степени 10
g_core <- induced_subgraph(g, vids = V(g)[cores >= 10])

V(g_core)$degree <- degree(g_core)
V(g_core)$strength <- strength(g_core, weights = E(g_core)$weight)
V(g_core)$core <- coreness(g_core)

cat("Размер ядра степени 10:", vcount(g_core), "персонажей,", ecount(g_core), "ребер\n")

Размер ядра степени 10: 193 персонажей, 2465 ребер

# визуализация
set.seed(123)
ggraph(g_core, layout = "fr", weights = E(g_core)$weight) + 
  geom_edge_link(aes(alpha = weight), width = 0.4, color = "gray50", show.legend = FALSE) +
  geom_node_point(aes(size = mentions, fill = as.factor(core)), 
                  shape = 21, alpha = 0.8) +
  geom_node_text(aes(label = name),
                 repel = TRUE, 
                 size = 2.5,
                 max.overlaps = 100) +
  scale_fill_brewer("k-ядро", palette = "Set2") +
  scale_size_continuous("Число упоминаний") +
  theme_graph() +
  labs(title = "Ядро степени 10 графа персонажей",
       subtitle = paste(vcount(g_core), "персонажей,", ecount(g_core), "связей"),
       caption = "Цвет узла - степень ядра")

Видно, что здесь отдельно выделяется группа космонавтов, императоров “людей неких” (это учебники 18 века), и ядро из членов семьи-профессий-имен.

Сообщества (алгоритм Walktrap)

Теперь попробуем разделить персонажей на сообщества.

communities <- cluster_walktrap(g_core, weights = E(g_core)$weight)
V(g_core)$community <- membership(communities)

# Визуализация
set.seed(123)
ggraph(g_core, layout = "fr", weights = E(g_core)$weight) + 
  geom_edge_link(aes(alpha = weight), width = 0.3, color = "gray50", show.legend = FALSE) +
  geom_node_point(aes(size = mentions, fill = as.factor(community)), 
                  shape = 21, alpha = 0.8) +
  geom_node_text(aes(label = name),  
                 repel = TRUE, 
                 size = 2,
                 max.overlaps = 200) +    scale_fill_brewer("Сообщество", palette = "Set3") +
  scale_size_continuous("Число упоминаний") +
  theme_graph() +
  labs(title = "Сообщества в ядре графа персонажей",
       subtitle = paste("Алгоритм Walktrap,", length(unique(V(g_core)$community)), "сообществ"),
       caption = "Подписаны все персонажи ядра")

# Модулярность
modularity(communities)

[1] 0.6076374

Модулярность 0.6 говорит о том, что структура сообществ достаточно четкая, они хорошо, но не идеально различимы. Это видно и на графе: сообщества, выделенные алгоритмом, легко интерпретируемы: семейные отношения, дружеские отношения-детские имена, рабочие/деловые отношения, торговые отношения, космонавты, императоры, “некие люди” из задач 18 века), но персонажи из разных групп иногда встречаются в задачах вместе, чтение примеров из таблицы выше это подтверждает. ## Точки сочленения

# Находим точки сочленения
art_points <- articulation_points(g_core)
cat("Найдено точек сочленения:", length(art_points), "\n")

Найдено точек сочленения: 2 

cat("Примеры:", paste(head(V(g_core)$name[art_points], 15), collapse = ", "), "\n")

Примеры: купец, Анна 

# Визуализация с выделением точек сочленения
V(g_core)$is_articulation <- ifelse(seq_len(vcount(g_core)) %in% art_points, "Точка сочленения", "Обычный узел")

set.seed(123)
ggraph(g_core, layout = "fr", weights = E(g_core)$weight) + 
  geom_edge_link(aes(alpha = weight), width = 0.3, color = "gray70", show.legend = FALSE) +
  geom_node_point(aes(size = mentions, fill = is_articulation), 
                  shape = 21, alpha = 0.8) +
  geom_node_text(aes(label = ifelse(is_articulation == "Точка сочленения" | mentions > 100, name, "")), 
                 repel = TRUE, size = 2.5) +
  scale_fill_manual("Тип узла", values = c("Точка сочленения" = "red", "Обычный узел" = "steelblue")) +
  scale_size_continuous("Число упоминаний") +
  theme_graph() +
  labs(title = "Точки сочленения в ядре графа",
       subtitle = "Красные узлы — критически важные для связности сети")