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 гг.)'
))Сеть совместной встречаемости персонажей героев текстовых арифметических задач
Введение
В этом документе представлен анализ графа персонажей, построенного на основе совместных появлений в арифметических задачах (N=44177). Исходные данные содержат строки с именами персонажей, разделёнными запятыми.
Как выглядят данные
Подготавливаем данные для отрисовки графа
Этот код в режиме реального времени выполняться не будет, слишком долго, он выполнился локально один раз и сохранен в файл, данные для отрисовки подгружаются из файла
# Обработка строк
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] 4015ecount(g) # количество ребер[1] 7463edge_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 = "Красные узлы — купец и Анна")
Клики
Подграфы, где все со всеми связаны.
max_clique_size <- clique_num(g_core)
cat("Размер максимальной клики:", max_clique_size, "\n")Размер максимальной клики: 50 if(max_clique_size >= 3) {
largest_cliques <- largest_cliques(g_core)
cat("Найдено максимальных клик:", length(largest_cliques), "\n")
cat("\nПримеры клик:\n")
for(i in 1:min(3, length(largest_cliques))) {
clique_names <- V(g_core)$name[largest_cliques[[i]]]
cat("Клика", i, ":", paste(head(clique_names, 10), collapse = ", "),
ifelse(length(clique_names) > 10, "...", ""), "\n")
}
}Найдено максимальных клик: 1
Примеры клик:
Клика 1 : человек 1, человек 10, человек 9, человек 8, человек 7, человек 6, человек 50, человек 5, человек 49, человек 48 ...