Подключаем необходимые библиотеки

library(xml2)       
library(tidyverse)  
library(igraph)     
library(ggraph)     
library(paletteer)

Загружаем файл “war_and_peace.xml” и переименовываем namespace

doc <- read_xml("war_and_peace.xml")
ns <- xml_ns_rename(xml_ns(doc), d1 = "tei")

cat("Файл загружен\n")
## Файл загружен

Находим всех персонажей в разметке

persons <- xml_find_all(doc, ".//tei:listPerson/tei:person", ns)

nodes <- tibble(
  id = xml_attr(persons, "xml:id"),
  name = map_chr(persons, ~{
    forename <- xml_text(xml_find_all(.x, ".//tei:forename", ns))
    surname <- xml_text(xml_find_all(.x, ".//tei:surname", ns))
    name_text <- paste(c(forename, surname), collapse = " ") |> str_squish()
    if(name_text == "") {
      name_text <- xml_text(xml_find_first(.x, ".//tei:persName", ns)) |> str_squish()
    }
    name_text
  })
) |> 
  filter(name != "", !is.na(name)) |> 
  distinct(name, .keep_all = TRUE)

cat("Всего персонажей:", nrow(nodes), "\n")
## Всего персонажей: 80

Из XML-разметки было извлечено 80 уникальных персонажей. Имена были очищены, объединены (имя + фамилия) и удалены дубликаты.

Берём первые 300 абзацев текста

paragraphs <- xml_find_all(doc, ".//tei:text//tei:p", ns)[1:300]

text_df <- tibble(
  text = map_chr(paragraphs, xml_text)
) |> 
  filter(str_length(text) > 30) |> 
  mutate(text_lower = str_to_lower(text))

cat("Абзацев:", nrow(text_df), "\n")
## Абзацев: 287

Разбиваем имена на части для поиска

name_parts <- nodes$name %>%
  str_to_lower() %>%
  str_split(" ") %>%
  unlist() %>%
  unique() %>%
  .[str_length(.) > 2]

# Функция поиска персонажей в абзаце
find_chars <- function(text) {
  found <- c()
  for(part in name_parts) {
    if(str_detect(text, fixed(part))) {
      full_names <- nodes$name[str_detect(str_to_lower(nodes$name), fixed(part))]
      found <- c(found, full_names)
    }
  }
  unique(found)
}

# Добавляем список персонажей, встречающихся в каждом абзаце
text_df$chars <- map(text_df$text_lower, find_chars)

# Оставляем только абзацы с 2 и более персонажами
text_df <- text_df |> 
  filter(lengths(chars) >= 2)

cat("Абзацев с взаимодействиями:", nrow(text_df), "\n")
## Абзацев с взаимодействиями: 114

Взаимодействие персонажей определяется как их совместное упоминание в одном абзаце.
В результате было получено 114 абзацев, содержащих взаимодействия (не менее двух персонажей).

Создаём список всех пар персонажей в абзацах

edges_list <- list()
for(i in 1:nrow(text_df)) {
  chars <- text_df$chars[[i]]
  for(j in 1:(length(chars)-1)) {
    for(k in (j+1):length(chars)) {
      edges_list <- append(edges_list, list(c(chars[j], chars[k])))
    }
  }
}

# Превращаем список в таблицу и считаем вес рёбер
edges <- do.call(rbind, edges_list) |> 
  as.data.frame() |> 
  setNames(c("from", "to")) |> 
  count(from, to, name = "weight")

cat("Уникальных связей:", nrow(edges), "\n")
## Уникальных связей: 154

Было выявлено 154 уникальных связей между персонажами.
Вес ребра отражает количество абзацев, в которых персонажи встречаются вместе.

Создаём неориентированный граф

g <- graph_from_data_frame(edges, directed = FALSE)

cat("Вершин:", vcount(g), "\n")
## Вершин: 25
cat("Рёбер:", ecount(g), "\n")
## Рёбер: 154
cat("Плотность:", edge_density(g), "\n")
## Плотность: 0.5133333
cat("Компонент связности:", components(g)$no, "\n")
## Компонент связности: 1

Построен неориентированный граф, где вершины представляют персонажей, а рёбра — их взаимодействия.

Граф содержит 25 вершин и 154 ребра.
Плотность графа равна 0.51, что указывает на высокую связанность сети.
Граф является полностью связным, то есть все персонажи соединены между собой.

Добавляем метрики важности узлов

V(g)$degree <- degree(g)
V(g)$wDegree <- strength(g)

Цветовая палитра

cols <- paletteer_d("nbapalettes::hawks_statement")

ggraph(g, layout = "fr") + 
  geom_edge_link(aes(alpha = weight), color = cols[3]) +
  geom_node_point(aes(size = wDegree), color = cols[2]) +
  geom_node_text(aes(label = name), repel = TRUE, max.overlaps = Inf) +
  theme_graph()

Выбираем ядро сети с coreness >= 3

core_vals <- coreness(g)
g_sub <- induced_subgraph(g, V(g)[core_vals >= 3])

cat("Вершин в k-core:", vcount(g_sub), "\n")
## Вершин в k-core: 23
cat("Рёбер в k-core:", ecount(g_sub), "\n")
## Рёбер в k-core: 150
# Визуализация подграфа
ggraph(g_sub, layout = "fr") +
  geom_edge_link(alpha = 0.5) +
  geom_node_point(aes(size = strength(g_sub)), color = "darkred") +
  geom_node_text(aes(label = name), repel = TRUE, max.overlaps = Inf) +
  theme_graph()

Был выделен подграф k-core (k ≥ 3), содержащий наиболее связанных персонажей.
В подграфе осталось 23 вершины и 150 рёбер, что говорит о высокой плотности ядра сети.

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

Алгоритм Louvain для выявления сообществ

comm <- cluster_louvain(g)
V(g)$community <- membership(comm)

cat("Модулярность:", modularity(comm), "\n")
## Модулярность: 0.2561213
# Визуализация сообществ
ggraph(g, layout = "fr") +
  geom_edge_link(alpha = 0.3) +
  geom_node_point(aes(color = as.factor(community), size = wDegree)) +
  theme_graph()

Для выявления сообществ использован алгоритм Louvain.
Модулярность равна 0.256, что указывает на слабо выраженную структуру сообществ.

Это означает, что персонажи активно взаимодействуют между разными группами, а не формируют чётко разделённые кластеры.

Находим точки сочленения

art_pts <- articulation_points(g)
cat("Точки сочленения:\n")
## Точки сочленения:
print(V(g)$name[art_pts])
## character(0)

Находим все клики размером >= 3

clq <- cliques(g, min = 3)
cat("Количество клик (>=3):", length(clq), "\n")
## Количество клик (>=3): 3771
# Вывод первых 5 клик
for(i in 1:min(5, length(clq))) {
  cat("Клика", i, ":\n")
  print(V(g)$name[clq[[i]]])
}
## Клика 1 :
## [1] "Анатоль Курагин" "Анна Шерер"      "Толь"           
## Клика 2 :
## [1] "Борис Боря Друбецкой"      "Михаил Ларионович Кутузов"
## [3] "Михаил Сперанский"        
## Клика 3 :
## [1] "Анатоль Курагин"      "Борис Боря Друбецкой" "Толь"                
## Клика 4 :
## [1] "Анна Мальвинцева" "Анна Шерер"       "Толь"            
## Клика 5 :
## [1] "Анатоль Курагин"  "Анна Мальвинцева" "Анна Шерер"       "Толь"