library(ggraph)
library(paletteer)
library(igraph)
library(rdracor)
library(tidyverse)
library(xml2)
library(tidygraph)
library(RColorBrewer)
library(stringr)
library(purrr)Анализ сетевых данных персонажей «Войны и мира» Л. Н. Толстого
Подготовка к работе
Загрузим все необходимые для рабоыт библиотеки
1. Импорт и сбор данных
doc <- read_xml("War_and_Peace.xml")
ns <- xml_ns(doc)
ns <- xml_ns_rename(xml_ns(doc), d1 = "tei")
person_nodes <- xml_find_all(doc, ".//tei:person", ns = ns)Сбор и обработка имён
Хочу сохранить имена в словарь и хранить person ID (pid) и full name (forename+surname).
char_names <- list()
char_ids <- character()Методом пристального вглядывания выяснилось, что в данных есть люди только с pid и без полного имени, есть с pid, но только с фамилией, есть только с именем, поэтому тут будет много проверок.
for (person in person_nodes) {
pid <- xml_attr(person, "id")
persName <- xml_find_first(person, ".//tei:persName", ns = ns)
#Методом пристального вглядывания выяснилсь,
#что в данных есть люди только с pid и без полного имени,
#есть с pid, но только с фамилией, есть только с именем,
#поэтому тут будет много проверок
if (!is.null(persName)) {
forenames <- xml_text(xml_find_all(persName, ".//tei:forename", ns = ns))
surname <- xml_text(xml_find_first(persName, ".//tei:surname", ns = ns))
patronymic <- xml_text(xml_find_first(persName, ".//tei:patronymic", ns = ns))
if (is.null(forenames) || length(forenames) == 0) {
forenames <- character() #здесь пустой символьный вектор, потому что имен может быть несколько, например, Сонюшка Софья Соня (Ростова)
}
if (is.null(surname) || is.na(surname)) {
surname <- "" #а здесь просто пустая строка, потому что фамилия обычно одна
}
if (is.null(patronymic) || is.na(patronymic)) {
patronymic <- "" #здесь то же самое
}
# собираем полные имена
if (length(forenames) > 0) {
name_parts <- c(forenames, patronymic, surname)
name_parts <- name_parts[name_parts != ""]
full_name <- paste(name_parts, collapse = " ")
} else {
# если нет имени, собираем из отчества и фамилии, это, например, Ростова, Раевский
name_parts <- c(patronymic, surname)
name_parts <- name_parts[name_parts != ""]
full_name <- paste(name_parts, collapse = " ")
}
#привожу в порядок имена, убираю лишние пробелы и переносы строк
full_name <- str_trim(full_name)
full_name <- gsub("\n", " ", full_name)
full_name <- gsub(" +", " ", full_name)
if (!is.na(full_name) && full_name != "") { #если имя "сформировалось", то записываем его
char_names[[pid]] <- full_name
} else {
char_names[[pid]] <- pid #если нет, то записываем person id
}
} else {
char_names[[pid]] <- pid #этот else обрабатывает is.null(persName), тогда тоже записывается pid
}
char_ids <- c(char_ids, pid) #делаем вектор с айдишками для быстрого доступа
}Сохраняем диалоги и участвующие в них лица
said_nodes <- xml_find_all(doc, ".//tei:said", ns = ns)
interactions <- list()
for (said in said_nodes) {
speaker <- xml_attr(said, "who") #получаем говорящего
corresp <- xml_attr(said, "corresp") #получаем адресата
#проверку наличия говорящего и адрессата в "словаре имен" пришлось добавить,
#чтобы не учитывать монологи и убрать связи без действующих лиц, которых мы вытаскивали ранее
#количество said_nodes - 6306, а interactions почти в два раза меньше - 3732
if (speaker %in% names(char_names) && corresp %in% names(char_names)) {
interactions <- append(interactions, list(c(speaker, corresp)))
} else {next}
}Собираем датафрейм, по которому будем считать кол-во диалогов между людьми (и считать веса для графа)
interactions_df <- do.call(rbind, interactions) %>%
as.data.frame(stringsAsFactors = FALSE) %>%
setNames(c("speaker", "corresp"))Так как нам нужен неориентированный граф, нам надо убрать дубликаты диалога. Граф неориентированны , потому что нас интересует сам акт взаимодействия и количество таких актов, а не данные о том, как распределены роли в диалоге
interactions_df <- interactions_df %>%
mutate(
from = pmin(speaker, corresp),
to = pmax(speaker, corresp)
)Считаем веса
edge_weights <- interactions_df %>%
group_by(from, to) %>%
summarise(weight = n()) `summarise()` has grouped output by 'from'. You can override using the
`.groups` argument.2. Создание объекта графа
G <- graph_from_data_frame(
edge_weights[, c("from", "to", "weight")],
directed = FALSE,
vertices = data.frame(name = char_ids,
name_full = unlist(char_names[char_ids]))
)3. Осмысляем атрибуты рёбер
characteristics <- paste0(
"Количество вершин в графе - количество персонажей: ", vcount(G), "\n",
"Количество рёбер в графе: ", ecount(G), "\n",
"Плотность графа: ", edge_density(G), "\n",
"Количество компонент связности в графе: ", components(G)$no, "\n",
"Размеры компонент связности: ", paste(components(G)$csize, collapse = " "), "\n"
)
cat(characteristics)Количество вершин в графе - количество персонажей: 84
Количество рёбер в графе: 228
Плотность графа: 0.0654044750430293
Количество компонент связности в графе: 14
Размеры компонент связности: 71 1 1 1 1 1 1 1 1 1 1 1 1 14. Собираем атрибуты узлов
Так как мы выяснили, что у нас есть 13 компонент связности, отдельных от основного “скопления”, почистим данные.
G <- delete_vertices(G, which(degree(G) == 0))Для узлов посчитаем центральность по степени и взвешенную центральность
degrees <- degree(G)
degrees %>%
sort(decreasing = T) %>%
head() Pierre_Bezukhov AndreyBolkonsky
32 31
Nikolai_Rostov NatashaRostova
28 22
Mikhail_Ilarionovich_Kutuzov Count_Ilya_Rostov
19 17 V(G)$degrees <- degrees
wDegree <- strength(G)
wDegree %>%
sort(decreasing = TRUE) %>%
head() NatashaRostova Nikolai_Rostov
1019 913
Pierre_Bezukhov AndreyBolkonsky
896 734
Princess_Mariya_Bolkonskaya Countess_Natalya_Rostova
475 306 V(G)$wDegree <- wDegreeЦентральность по степени показывает самых важных участников Войны и Мира - Пьер Безухов, Андрей Болконский, Николай Ростов. Взвешенная центральность показывает уже чуть другие результаты - топ-3 становятся Наташа Ростова, Николай Ростов и Пьер Безухов.
#центральность по близости
closeness_centrality <- closeness(G,
mode = "all",
normalized = TRUE)
closeness_centrality %>%
sort() %>%
tail() Sonya_Rostova AndreyBolkonsky
0.1241135 0.1241135
Weyrother Miloradovich
0.1245552 0.1247772
Pierre_Bezukhov Mikhail_Ilarionovich_Kutuzov
0.1293900 0.1351351 V(G)$closeness <- closeness_centrality
#центральность по посредничеству
betweenness_centrality <- betweenness(G,
directed = FALSE,
normalized = TRUE)
betweenness_centrality %>%
sort() %>%
tail() Tsar_Alexander_I_of_Russia Nikolai_Rostov
0.1279145 0.1369467
Boris_Drubetskoy AndreyBolkonsky
0.1614258 0.2089694
Pierre_Bezukhov Mikhail_Ilarionovich_Kutuzov
0.2616111 0.4450353 V(G)$betweenness <- betweenness_centralityПроанализируем, например, персонажа Андрея Болконского с точки зрения характеристик соответствующего узла. Его центральность по степени 31 говорит о том, что у него много связей, он активно общается с другими персонажами. Центральность по близости 0.1241135 говорит о том, что он не центральная фигура (так как значение не близко к 1), но он на небольшом расстоянии от других персонажей, значит, находится в центре сюжетных событий. Центральность по посредничеству 0.14829889 показывает, что Андрей Болконский - важный второстепенный персонаж, чья значимость обуславливается количеством и качеством связей с другими героями.
5. Cтроим подграф k-ядро
cores_g <- coreness(G)
head(cores_g)Mavra_Kuzminishna Ilyin Dron_Zakharych Count_Ilya_Rostov
1 2 3 7
Lavrushka Bilibin
3 4 table(cores_g)cores_g
1 2 3 4 5 6 7
12 17 6 12 3 5 16 V(G)$core <- cores_gcols <- paletteer_d("nbapalettes::hawks_statement")
set.seed(22092024)
ggraph(G, layout = "stress") +
geom_edge_link(color = cols[3],
alpha = 0.3,
width = 0.6) +
geom_node_point(aes(color = as.factor(core)),
size = 3,
show.legend = TRUE) +
geom_node_text(aes(filter = wDegree > 400,
label = name_full),
color = cols[3],
repel = TRUE,
check_overlap = TRUE) +
scale_color_brewer("k-ядра", type = "qual") +
theme_void()
6. Визуализация графа и подграфа
library(visNetwork)
vis_nodes <- tibble(
id = V(G)$name,
label = V(G)$name_full,
value = V(G)$wDegree,
color.background = scales::col_numeric(
palette = c("pink", "purple"),
domain = range(V(G)$betweenness)
)(V(G)$betweenness),
title = paste0("<b>", V(G)$name_full, "</b><br>
Центральность по степени: ", V(G)$degrees, "<br>
Центральность по посредничеству: ", round(V(G)$betweenness, 3))
)
vis_edges <- tibble(
from = get.edgelist(G)[,1],
to = get.edgelist(G)[,2],
value = E(G)$weight
)Warning: `get.edgelist()` was deprecated in igraph 2.0.0.
ℹ Please use `as_edgelist()` instead.visNetwork(vis_nodes, vis_edges,
main = "Персонажи «Война и мир»") |>
visNodes(scaling = list(min = 10, max = 50)) |>
visEdges(scaling = list(min = 1, max = 8)) |>
visOptions(
highlightNearest = list(enabled = TRUE),
nodesIdSelection = TRUE
) |>
visPhysics(
solver = "forceAtlas2Based",
stabilization = list(enabled = TRUE)
) |>
visIgraphLayout() Посмотрим на самое большое 7-ядро
g7 <- induced_subgraph(G, vids=V(G)[core > 6])
ggraph(g7, layout = "stress") +
geom_edge_link(color = cols[3],
alpha = 0.3,
width = 0.6) +
geom_node_point(aes(color = as.factor(core)),
size = 3,
show.legend = TRUE) +
geom_node_text(aes(filter = wDegree > 10,
label = name_full),
color = cols[3],
repel = TRUE,
check_overlap = TRUE) +
scale_color_brewer("k-ядра", type = "qual") +
theme_void()
Продолжим дальше анализировать Болконского. Как мы видим, Андрей Болконский попал в сообщество 7-ядра (16 персонажей) - в наиболее плотно связанный кластер сети. Это опять же подтверждает то, что персонаж задействован в ключевых событиях.
Эго-граф для Болконского
p_bolkonsky <- make_ego_graph(
G,
order = 1,
nodes = "AndreyBolkonsky",
mode = "all"
)[[1]]
layout_bolkonsky <- layout_in_circle(p_bolkonsky)
plot(p_bolkonsky,
vertex.size = 10,
edge.arrow.size = 0.5,
vertex.label.dist = 1.5,
edge.curved = 0.2,
edge.color = "grey80",
vertex.color = "plum",
layout = layout_bolkonsky,
vertex.label.cex = 0.8,
vertex.label.font = 2)
Естественно, что в эго-графе с Болконским связан 31 персонаж - столько же, сколько его центральность по степени.
7 и 8. Поиск сообществ и вычисление их модулярности
Посмотрим на сообщества по алгоритму случайного блуждания
cw <- cluster_walktrap(G)
membership(cw) %>% head()Mavra_Kuzminishna Ilyin Dron_Zakharych Count_Ilya_Rostov
1 1 5 1
Lavrushka Bilibin
1 5 par(mar = rep(0, 4))
plot(cw, G)
modularity(cw)[1] 0.3048683Смотрим разбиение «спиновые стекла»
csg <- cluster_spinglass(G)
membership(csg) %>% head()Mavra_Kuzminishna Ilyin Dron_Zakharych Count_Ilya_Rostov
5 4 3 5
Lavrushka Bilibin
4 6 par(mar = rep(0, 4))
plot(csg, G)
modularity(csg)[1] 0.0266197В этом алгоритме модулярность меньше, это плохо, так как при выделении сообществ наша задача – максимизировать модулярность
Используем алгоритм под названием “главный собственный вектор”.
cev <- cluster_leading_eigen(G)
par(mar = rep(0, 4))
plot(cev, G)
modularity(cev) [1] 0.3400967У этого алгоритма самая большая модулярность.
9. Анализ ключевых узлов / структур
#точки сочленения
articulation_points(G)+ 10/71 vertices, named, from 1ff0663:
[1] AndreyBolkonsky Bolhovitinov
[3] Mikhail_Ilarionovich_Kutuzov Pierre_Bezukhov
[5] Captain_Ramballe Vasily__Vasska__Denisov
[7] Pfuel Napoleon_Bonaparte
[9] Nikolai_Rostov NatashaRostova Наличие всего 10 точек сочленения на граф из 71 узла свидетельствует о высокой связности сети
#посмотрим на самую большую клику
clique_num(G)[1] 7cliques(G, min=7)[[1]]
+ 7/71 vertices, named, from 1ff0663:
[1] Princess_Mariya_Bolkonskaya Sonya_Rostova
[3] Pierre_Bezukhov AndreyBolkonsky
[5] Nikolai_Rostov Countess_Natalya_Rostova
[7] NatashaRostova