library(tidyverse)
library(xml2)
library(igraph)
library(ggraph)
library(paletteer)Сетевой анализ «военных» частей «Войны и мира»
Извлечение данных и подготовка таблицы
Для начала напишем функцию, которая забирает из xml-файла имена персонажей, их роли, а также номера томов и частей, а потом собирает их в единую таблицу.
make_tibble <- function(xml_file) {
doc <- read_xml(xml_file)
ns <- xml_ns_rename(xml_ns(doc), d1 = 'tei')
root <- xml_root(doc)
volumes <- xml_find_all(root, '//tei:text//tei:div[@type="volume"]', ns)
table <- map_df(volumes, function(volume) {
volume_number <- xml_attr(volume, 'n')
parts <- xml_find_all(volume, './/tei:div[@type="part"]', ns)
map_df(parts, function(part) {
part_number <- xml_attr(part, 'n')
speeches <- xml_find_all(part, './/tei:said', ns)
map_df(speeches, ~tibble(
volume_part = paste(volume_number, part_number, sep = '_'),
speaker = xml_attr(.x, 'who'),
corresp = xml_attr(.x, 'corresp')
))
})
})
return(table)
}
war_and_peace <- make_tibble('War_and_Peace.xml')Почистим таблицу и внесем еще один столбец для последующего построения графа.
war_and_peace <- war_and_peace |>
filter(corresp != '') |>
filter(speaker != corresp) |>
separate_rows(corresp, sep = ";") |>
count(volume_part, speaker, corresp, name = 'weight') Для графа мы не будем использовать весь роман целиком. Нас интересуют только «военные» части, включая также, например, события в Москве в 1812 г. Сразу же создадим на основе полученной таблицы граф.
war_and_peace <- war_and_peace |>
filter(corresp != '') |>
filter(speaker != corresp) |>
separate_rows(corresp, sep = ";") |>
count(volume_part, speaker, corresp, name = 'weight')
wap_war <- war_and_peace |>
filter(volume_part %in% c("1_2", "1_3", "3_1",
"3_2","3_3", "4_1",
"4_2", "4_3")) |>
select(speaker, corresp, weight) |>
group_by(speaker, corresp) |>
summarise(weight = sum(weight), .groups = "drop")
war_graph <- graph_from_data_frame(wap_war)
war_graphIGRAPH 0c06740 DNW- 282 673 --
+ attr: name (v/c), weight (e/n)
+ edges from 0c06740 (vertex names):
[1] Aline_Kuragina ->Vasili_Kuragin
[2] Aline_Kuragina ->пожилая дама
[3] Anatole_Kuragin->Prince_Nikolay_Bolkonsky
[4] Anatole_Kuragin->Vasili_Kuragin
[5] AndreyBolkonsky->Bilibin
[6] AndreyBolkonsky->Boris_Drubetskoy
[7] AndreyBolkonsky->Emperor_Francis_I_of_Austria
[8] AndreyBolkonsky->Mikhail_Ilarionovich_Kutuzov
+ ... omitted several edgesОписание графа
Кратко опишем основные составляющие графа.
Вершины
V(war_graph)+ 282/282 vertices, named, from 0c06740:
[1] Aline_Kuragina
[2] Anatole_Kuragin
[3] AndreyBolkonsky
[4] Anna_Ignatyevna_Malvintsev
[5] Anna_Pavlovna_Scherer
[6] Austrian minister of war
[7] Bagovut
[8] Balashev
[9] Berthier
[10] Bilibin
+ ... omitted several verticesvcount(war_graph)[1] 282Ребра
E(war_graph)+ 673/673 edges from 0c06740 (vertex names):
[1] Aline_Kuragina ->Vasili_Kuragin
[2] Aline_Kuragina ->пожилая дама
[3] Anatole_Kuragin->Prince_Nikolay_Bolkonsky
[4] Anatole_Kuragin->Vasili_Kuragin
[5] AndreyBolkonsky->Bilibin
[6] AndreyBolkonsky->Boris_Drubetskoy
[7] AndreyBolkonsky->Emperor_Francis_I_of_Austria
[8] AndreyBolkonsky->Mikhail_Ilarionovich_Kutuzov
[9] AndreyBolkonsky->NatashaRostova
[10] AndreyBolkonsky->Nikolai_Rostov
+ ... omitted several edgesecount(war_graph)[1] 673Плотность
edge_density(war_graph)[1] 0.008492971Компоненты
components(war_graph)$no[1] 11components(war_graph)$csize [1] 260 2 2 2 4 2 2 2 2 2 2which(components(war_graph)$membership !=1) Данило Терентьич Ефим Игнат
93 97 98
Мишка денщик Ермолова ефрейтор
103 138 147
задний казачий офицер малый
149 153 163
молодой солдат один солдат форейтор
165 176 210
худой солдат штабный товарищ мальчик
214 220 264
кавалергардский офицер Зикин передний мужик
267 270 271
целовальник дяденька Петров
274 275 276
артиллеристы
282 Диаметр
lgc <- largest_component(war_graph)
diameter(lgc, directed = TRUE)[1] 8get_diameter(lgc)+ 8/260 vertices, named, from 0582b3f:
[1] Joachim_Murat Balashev
[3] General_Davoust Pierre_Bezukhov
[5] Count_Rostopchin Mikhail_Ilarionovich_Kutuzov
[7] Miloradovich апшеронцы Транзитивность
transitivity(war_graph)[1] 0.1068615Атрибуты ребер
edge_attr(war_graph)$weight [1] 1 1 1 1 2 1 1 3 2 1 1 1 1 1 2 1 2 1 2 1 1 1 1 1 2 1 1 2 1 1 1 1 1 1 3 1 1
[38] 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 3 1 1 1 1 1 1 1
[75] 1 1 1 1 1 1 1 1 1 2 1 1 2 1 2 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
[112] 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 3 1 1 1 1 1 1 1 1 1 1 1 1 1 3 1 1
[149] 1 1 1 2 2 1 1 1 2 1 1 1 1 1 1 1 1 3 2 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1
[186] 1 1 1 2 1 1 1 1 2 2 1 1 1 2 2 1 1 1 3 1 1 1 1 1 1 1 1 2 1 1 3 1 1 2 1 1 1
[223] 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 2
[260] 1 1 1 2 1 2 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 3 1 1 1 1 1 1 1
[297] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 1 2 2 1 1 1 1 1 1 1
[334] 1 1 3 1 1 1 1 1 1 1 2 1 2 1 1 2 1 1 1 1 1 1 1 2 3 1 1 1 1 1 1 1 1 1 1 1 1
[371] 1 2 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1
[408] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1
[445] 1 1 1 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
[482] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1
[519] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
[556] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
[593] 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
[630] 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 3 1 1 1 1 1 1 1 1
[667] 1 1 1 1 1 1 1Атрибуты вершин
names <-vertex_attr(war_graph)$name
names[1:20] [1] "Aline_Kuragina" "Anatole_Kuragin"
[3] "AndreyBolkonsky" "Anna_Ignatyevna_Malvintsev"
[5] "Anna_Pavlovna_Scherer" "Austrian minister of war"
[7] "Bagovut" "Balashev"
[9] "Berthier" "Bilibin"
[11] "Bolhovitinov" "Bolkonsky's architect"
[13] "Boris_Drubetskoy" "Capt._von_Toll"
[15] "Captain_Ramballe" "Catiche(eldest princess)"
[17] "Clausewitz" "Count_Bennigsen"
[19] "Count_Ilya_Rostov" "Count_Rostopchin" Визуализация
Граф получился огромным и визулизировать его целиком будет трудно: он просто «расползется», собрав в нечитаемую кучку основные связи, даже если удалить изолированные узлы (я пробовала, вышло некрасиво). Вместо этого сфокусируемся на самых важных связях и персонажах и проведем фильтрацию, посчитав центральность по степени.
wDegree <- strength(war_graph)
top_nodes <- names(sort(wDegree, decreasing = TRUE)[1:50])
war_graph_top <- induced_subgraph(war_graph, top_nodes)Построим граф.
wDegree_top <- strength(war_graph_top)
V(war_graph_top)$wDegree <- wDegree_top
threshold <- quantile(wDegree_top, 0.85)
V(war_graph_top)$is_top <- wDegree_top >= threshold
cols <- paletteer_d("NineteenEightyR::miami2")
set.seed(125)
ggraph(war_graph_top, layout = "fr", niter = 2000) +
geom_edge_link(
aes(alpha = weight, width = weight),
color = 'grey5',
show.legend = TRUE
) +
scale_edge_alpha(range = c(0.1, 0.8), guide = "none") +
scale_edge_width(
range = c(0.2, 2),
name = "weight"
) +
geom_node_point(
aes(size = wDegree, fill = is_top),
color = "grey20",
shape = 21,
stroke = 0.3
) +
scale_fill_manual(values = c("TRUE" = cols[1], "FALSE" = cols[4])) +
scale_size(
range = c(2, 15),
name = "wDegree"
) +
geom_node_text(
aes(label = name),
color = "grey10",
repel = TRUE,
size = 2.5,
max.overlaps = 30,
bg.colour = "white",
bg.r = 0.1
) +
labs(title = "Сетевой анализ «военных» частей") +
theme_graph(base_family = "sans") +
theme(
plot.title = element_text(size = 14, face = "bold", hjust = 0.5),
legend.position = "right"
)
Здесь мы видим, какую большую роль играют не только центральные персонажи романа, вроде Пьера Безухова, Андрея Болконского, Николая Ростова, но и другие фигуры, которые, по понятным причинам, отходят на второй план в «мирных» частях: Кутузов (и его адъютанты), Василий Денисов. Также мы здесь видна и значимость женских персонажей: Наташи Ростовой и Марии Болконской. Это случилось потому, что мы намеренно оставили главы, связанные с Москвой и Смоленском во время военных действий.
k-ядра
Для визуализации подграфа выберем метод k-ядер. Для начала определим структуру.
cores <- coreness(war_graph_top)
head(cores) AndreyBolkonsky Anna_Pavlovna_Scherer Bilibin
8 5 5
Bolhovitinov Boris_Drubetskoy Count_Ilya_Rostov
1 8 8 table(cores)cores
1 2 3 4 5 6 7 8
1 2 3 3 7 8 3 23 Построим граф.
V(war_graph_top)$core <- cores
war <- induced_subgraph(war_graph_top, vids=V(war_graph_top)[core > 5]) # здесь выберем величину ядра больше 5
V(war)$wDegree <- strength(war)
ggraph(war, layout = "stress") +
geom_edge_link(aes(alpha = weight),
color = cols[3],
width = 0.3) +
scale_edge_width(range = c(0.2, 2)) +
geom_node_point(aes(color = as.factor(core),
size = wDegree),
show.legend = TRUE) +
scale_size(range = c(1, 8)) +
geom_node_text(aes(filter = wDegree > 10,
label = name),
color = 'grey5',
repel = TRUE) +
scale_color_brewer("k-ядра", type = "qual") +
theme_void()
Анализ сообществ и модулярность
Попробуем применить разные алгоритмы и сравнить результаты, чтобы на основе самого подходящего метода построить еще один граф.
Алгоритм Walktrap
cw <- cluster_walktrap(war_graph_top)
modularity(cw)[1] 0.3232931Алгоритм Spinglass
csg <- cluster_spinglass(war_graph_top)
modularity(csg)[1] 0.2170803Алгоритм Leading eigenvector
cev <- cluster_leading_eigen(war_graph_top)
modularity(cev)[1] 0.3559426У алгоритмов Walktrap и Leading eigenvector получились похожие значения, построим графы для них обоих. Однако графики я буду строить, основываясь на war_graph_top.
V(war_graph_top)$color <- membership(cw)
par(mar = rep(0, 4))
layout_top <- layout_with_fr(war_graph_top, niter = 1000)
set.seed(125)
plot(war_graph_top,
layout = layout_top,
vertex.size = scales::rescale(strength(war_graph_top), to = c(2, 8)),
vertex.color = membership(cw),
vertex.label.cex = 0.6,
vertex.label.color = "grey20",
vertex.label.dist = 0.5,
vertex.frame.color = "white",
edge.arrow.size = 0,
edge.color = "grey80",
edge.width = scales::rescale(E(war_graph_top)$weight, to = c(0.2, 2)),
mark.groups = communities(cw),
main = 'Walktrap')
V(war_graph_top)$color <- membership(cev)
par(mar = rep(0, 4))
layout_top <- layout_with_fr(war_graph_top, niter = 1000)
set.seed(12345)
plot(war_graph_top,
layout = layout_top,
vertex.size = scales::rescale(strength(war_graph_top), to = c(2, 8)),
vertex.color = membership(cev),
vertex.label.cex = 0.6,
vertex.label.color = "grey20",
vertex.label.dist = 0.5,
vertex.frame.color = "white",
edge.arrow.size = 0,
edge.color = "grey80",
edge.width = scales::rescale(E(war_graph_top)$weight, to = c(0.2, 2)),
mark.groups = communities(cev),
main = 'Leading eigen')
Это странно, но уже при публикации графы и показатели модулярности изменились. Я попробовала отдельно прогнать тот кусок кода, и модулярность была выше для обоих случаев примерно на 0.2, а граф выглядит так. Мне кажется, он несколько адекватнее и в целом красивее отражает сообщества, но я не знаю, с чем связаны изменения.
Здесь видно, как женская половина Ростовых образует свою маленькую группу внутри других больших. Наполеон с Балашевым вынесены отдельно, но больше всего мне нравится, как собирательное «солдаты» не соприкасается с группой, где по большей части собрались высшее командование и офицеры.
Клики
Посмотрим, какие клики встречаются в графе.
clique_num(war_graph)[1] 5Самая крупная клика состоит из 5 участников, и она всего одна.
largest_cliques(war_graph)[[1]]
+ 5/282 vertices, named, from 0c06740:
[1] Princess_Mariya_Bolkonskaya NatashaRostova
[3] Pierre_Bezukhov Countess_Natalya_Rostova
[5] Count_Ilya_Rostov Также посмотрим на точки сочленения.
articulation_points(war_graph)+ 52/282 vertices, named, from 0c06740:
[1] Balashev
[2] Napoleon_Bonaparte
[3] Petya_Rostov
[4] Tikhon_Shtcherbatov
[5] гусар
[6] Ferapontov
[7] Yakov_Alpatych
[8] Staff_Captain_Tushin
[9] regimental commander
[10] француз
+ ... omitted several vertices