library(stylo)
library(dendextend)
data("galbraith")
<- as.data.frame.matrix(galbraith)
data <- dist(scale(data))
distmx
<- as.dendrogram(hclust(distmx, method ="average")) |>
d1 set("labels_col", value = c("skyblue", "orange", "grey40"), k=3) |>
set("branches_k_color", value = c("skyblue", "orange", "grey40"), k = 3)
<- as.dendrogram(hclust(distmx, method ="ward.D2")) |>
d2 set("labels_col", value = c("skyblue", "orange", "grey40"), k=3) |>
set("branches_k_color", value = c("skyblue", "orange", "grey40"), k = 3)
<- dendlist(d1, d2)
dlist
par(family = "Arial Bold")
tanglegram(dlist, common_subtrees_color_lines = FALSE,
highlight_distinct_edges = TRUE,
highlight_branches_lwd=FALSE,
margin_inner=10,
lwd=2,
axes=FALSE,
main_left = "Cредняя",
main_right = "Уорд",
lab.cex = 1.3)
17 Консенсусные деревья и сети
В предыдущих уроках мы говорили об иерархической кластеризации и о дендрограмме как наиболее естественном способе представления таких кластеров. Однако важно помнить, что результат кластеризации зависит от нескольких параметров:
- число предикторов (например, наиболее частотных слов для разных произведений);
- расстояние, которое используется для попарных сравнений (евклидово, косинусное, др.)
- метод связи (метод полной связи, метод средней связи, метод Уорда и др.);
Иногда добавление или удаление буквально одного слова меняет структуру дерева.
17.1 Танглграммы
Поэтому бывает необходимо сравнить разные деревья. Один из способов это сделать визуально – построить tanglegram, например, при помощи пакета dendextend
.
На картинке видно, что книги группируются немного по-разному в зависимости от метода связи, хотя для кластеризации использовалась одна и та же матрица расстояний.
17.2 Консенсусные деревья в stylo
Консенсусное дерево позволяет “обобщить” произвольное число дендрограмм. В stylo
за консенсусные деревья отвечает метод BCT
(Bootstrap Consensus Tree), к которому можно обратиться через GUI (но здесь мы показываем решение без него).
<- stylo(gui = FALSE,
bct_result frequencies = data,
analysis.type = "BCT",
mfw.min = 100,
mfw.max = 500,
mfw.incr = 100,
distance.measure = "wurzburg",
write.png.file = FALSE,
corpus.lang = "Other",
consensus.strength = 0.5,
rooted = T,
plot.custom.width = 8,
plot.custom.height = 8
)
Работать через GUI удобно, но есть нюансы. Во-первых, не получится кастомизировать внешний вид дерева, а, во-вторых, в Stylo реализована достаточно специфическая процедура бутстрепа (повторных выборок).
Вот что пишут разработчики:
Under the FEATURES tab, users can define the minutes of the MFW division and sampling procedure, using the increment, the minimum and maximum parameters. For minimum = 100, maximum = 3000, and increment = 50, stylo will run subsequent analyses for the following frequency bands: 100 MFW, 50–150 MFW, 100–200 MFW, …, 2900–2950 MFW, 2950–3000 MFW.
Для консенсуса нужно много деревьев, и Stylo будет строить эти деревья в заданном интервале. Это значит, что последние деревья будут построены уже не на основе самой частотной лексики, т.е. скорее всего на них отразится тематика текстов, входящих в корпус.
В некоторых случаях это работает неплохо, но, возможно, у вас есть другие идеи для консенсуса. Разные расстояния. Разные методы кластеризации. Случайные выборки из первых двух сотен слов или еще что-то. Тогда придется самим строить сразу множество деревьев.
17.3 Целый лес c purrr
Если изучить изнанку функции stylo()
, которая вызывает GUI в одноименном пакете, то можно заметить, что за консенсусное дерево там отвечает пакет для работы с филогенетическими данными под названием Ape 🦍
Что делает машина, когда вы заказываете у нее консенсусное дерево? Принимает на входе матрицу с 1 … n
столбцами, в которых хранится частотность для слов. Потом отбирает первые сколько-то слов (скажем, сотню или сколько скажете), считает расстояние, строит на основе матрицы расстояний дерево, складывает его в корзинку. Потом берет следующую сотню слов, считает расстояние, строит дерево, складывает в корзинку… Ну вы поняли. Получается целый лес.
Звучит как итерация, а такие задачи в R решаются при помощи цикла for
или пакета purrr
. Функции map()
из пакета purrr
надо вручить другую функцию – у нас это будет пользовательская get_tree()
. Она берет случайные 100 столбцов в таблице с частотностями galbraith
из пакета Stylо
, считает евклидово расстояние между документами и строит дерево.
library(ape)
<- function(df) {
get_tree <- df[ , sample(3000, replace = F, size = 100)]
X <- dist(scale(X))
distmx <- as.phylo(hclust(distmx))
tr
tr }
Запускаем ее 13 раз при помощи map()
, получаем список из тринадцати деревьев. Если хочется на них посмотреть по отдельности, то функцией walk()
печатаем сразу несколько деревьев одной строчкой кода 🧙🪄
library(purrr)
set.seed(123)
<- map(1:13, ~get_tree(data))
trees_result
# отдельные деревья
par(mfrow = c(2, 2), mar = c(1,1,1,1))
walk(trees_result[1:4], plot)
Так можно построить и 100, и 1000 деревьев. Но сравнивать их вручную мы не будем, а вместо этого посчитаем консенсус. Но сначала разберемся, что это такое.
17.4 plot.phylo()
: простой пример
Допустим, у нас есть три дерева. Создадим их с использованием формата Ньюика, т.е. просто-напросто комбинации скобок и запятых.
<- read.tree(text = "((1,2),(3,4));")
tr1 <- read.tree(text = "((1,3),(2,4));")
tr2 <- read.tree(text = "((1,2),(3,4));")
tr3
par(mfrow = c(1, 3), mar = c(5,1,5,1), cex = 1)
walk(list(tr1, tr2, tr3), plot.phylo, tip.color = 2)
Кластеры 1-2, 3-4 встречаются в двух деревьях, остальные лишь в одном. Задача — найти наиболее устойчивые кластеры методом простого большинства. Для этого считаем консенсус, причем аргумент p
указывает, что кластер должен быть представлен не менее, чем в половине деревьев. Также уточняем, что наши деревья укоренены.
<- consensus(list(tr1, tr2, tr3), p = 0.5, rooted = TRUE) cons
Значение p не может быть меньше 0.5, потому что конфликтующие сплиты не могут быть представлены вместе в одном дереве.
Теперь изобразим консенсус в виде дерева; дополнительно для узлов укажем силу консенсуса (2/3 = 0.67):
par(mfrow = c(1,1), mar = c(5,5,5,5))
plot.phylo(cons, tip.color = 2)
nodelabels(round(cons$node.label[3],2), 7, frame = "c", cex = 0.7)
nodelabels(round(cons$node.label[2],2), 6, bg = "yellow")
Это очень простое консенсусное дерево, построенное по методу простого большинства.
17.5 plot.phylo()
: galbraith
Теперь попробуем сделать такое же дерево для текстовых данных.
library(tidyverse)
library(harrypotter)
# добавим красоты
<- hp(n = 5, option = "Gryffindor")
pal
<- consensus(trees_result, p = 0.5, rooted = FALSE)
cons
# назначаем авторам цвета
<- tibble(author = str_remove(cons$tip.label, "_.+")) |>
cols mutate(color = case_when(author == "coben" ~ pal[1],
== "galbraith" ~ pal[2],
author == "lewis" ~ pal[3],
author == "rowling" ~ pal[4],
author == "tolkien" ~ pal[5]))
author
# строим дерево
par(mar = c(0,0,0,0))
plot.phylo(cons,
type = "fan",
use.edge.length = FALSE,
edge.width = 1.5,
node.color = "grey30",
font = 2,
no.margin = TRUE,
label.offset = 0.1,
direction = "rightwards",
plot = TRUE,
lab4ut = "a",
node.depth = 1,
tip.color = cols$color)
# подписываем узлы
nodelabels(text=sprintf("%.2f", cons$node.label),
node=1:cons$Nnode+Ntip(cons),
frame="circle",
bg = "#E8C4A2FF",
cex = 0.5,
)
17.6 consensusNet()
: простой пример
У консенсусного дерева есть одно очевидное ограничение: оно плохо передает конфликтующие сигналы. Допустим, у нас есть три неукоренённых дерева.
<- read.tree(text = "((1,2),(3,4));")
tr1 <- read.tree(text = "((1,3),(2,4));")
tr2 <- read.tree(text = "((1,4),(2,3));")
tr3
par(mfrow = c(1, 3), mar = c(0,0,0,0), cex=1)
walk(list(tr1, tr2, tr3),
plot.phylo, tip.color=2,
type="unrooted",
label.offset = 0.1)
Консенсусное дерево в таком случае никак не поможет: оно не допускает значений p < 0.5. Проверьте сами: код ниже вернет садовые вилы 🔱
par(mfrow = c(1,1))
<- consensus(list(tr1, tr2, tr3), p = 0.5, rooted = F)
cons plot.phylo(cons)
nodelabels(text=sprintf("%.2f", cons$node.label),
node=1:cons$Nnode+Ntip(cons),
frame="circle",
bg = "#E8C4A2FF",
cex = 0.5,
)
В таких случаях на помощь приходит консенсусная сеть. Построим сеть с использованием пакета phangorn
. На входе отдаем объект класса multiPhylo
, это по сути просто три дерева в одном “букете”.
library(phangorn)
library(TreeTools)
<- as.multiPhylo(list(tr1, tr2, tr3))
mph
<- consensusNet(mph, prob = 0.3, rooted = FALSE)
cons.nw class(cons.nw)
[1] "networx" "phylo"
Объект cons.nw относится к классу networx. Его можно изобразить как в двух, так и в трех измерениях. Вот 2D.
set.seed(16092024)
par(mar = c(0,0,0,0))
plot(cons.nw, type = "2D")
А вот 3D.
library(rgl)
plot(cons.nw, "3D")
# create animated gif file
movie3d(spin3d(axis=c(0,1,0), rpm=3),
duration=10,
dir = ".",
type = "gif")
Теперь попробуем понять, что это значит (иллюстрация и объяснение отсюда).
Рассмотрим неукорененные деревья в середине: их внутренние ветви определяют расщепления (splits), а именно 12|34, 13|24 и 14|23, которые явно не могут наблюдаться в одном дереве и, следовательно, все они несовместимы. Сеть в левом верхнем углу представляет одновременно два первых дерева с прямоугольником, символизирующим две внутренние ветви. Чтобы представить все три расщепления, нам нужен куб, как показано справа.
17.7 consensusNet()
: galbraith
Итак, у нас есть 13 деревьев для данных galbraith.
# вычисляем консенсус
<- as.multiPhylo(trees_result)
mph <- consensusNet(mph, prob = 0.3, rooted = FALSE) cons.nw
Придется немного поколдовать, чтобы раскрасить сеть.
library(tidyverse)
$col <- str_remove_all(cons.nw$tip.label, "_.+")
cons.nw
<- tibble(label = unique(cons.nw$col),
col_tbl col = pal)
<- tibble(label = cons.nw$col) |>
color_group left_join(col_tbl)
Joining with `by = join_by(label)`
$col <- color_group$col cons.nw
# рисуем
set.seed(16092024)
par(mar = c(0,0,0,0))
plot(cons.nw, type = "2D",
direction = "axial",
tip.color = cons.nw$col,
edge.color = "grey30",
edge.width = 1,)
Таким образом, consensusNet()
строит консенсусную сеть на основе набора деревьев: это позволяет визуализировать степень поддержки различных связей, найденных в наборе деревьев. Подход полезен для выявления областей неопределенности в филогенетических отношениях, когда несколько разных деревьев одинаково хорошо соответствуют данным.
17.8 neighborNet()
: простой пример
Еще один алгоритм для визуализации неоднозначных филогенетических отношений в R назвается neighborNet. Он подходит для тех случаев, когда мы подозреваем нарушения в древовидной структуре (в генетике это может быть горизонтальный перенос генов, а в литературе – например, отношения подражания или т.п.).
Ключевое различие по сравнению с consensusNet()
заключается в том, что neighborNet()
строит сеть непосредственно из данных, а не на основе набора деревьев.
NeighborNet работает в два шага:
- Сначала строит круговую раскладку для таксонов таким образом, чтобы минимизировать расстояния между парами кластеров, каждый из которых включает в себя 1 или 2 таксона.
- Потом считает веса для сплитов. На этом этапе некоторые ребра удаляются, а другие вытягиваются сообразно весам. Чем длиннее ребро, тем больше вес сплита.
Рассмотрим это на простом примере. Представьте, что у нас есть следующая матрица расстояний.
<- matrix(data = c(0, 0.07, 0.12, 0.12, 0.07, 0, 0.13, 0.09, 0.12, 0.13, 0, 0.06, 0.12, 0.09, 0.06, 0), nrow = 4)
mx colnames(mx) <- c("a", "b", "c", "d")
rownames(mx) <- colnames(mx)
mx
a b c d
a 0.00 0.07 0.12 0.12
b 0.07 0.00 0.13 0.09
c 0.12 0.13 0.00 0.06
d 0.12 0.09 0.06 0.00
<- as.dist(mx)
D D
a b c
b 0.07
c 0.12 0.13
d 0.12 0.09 0.06
От матрицы расстояний можно перейти к длине ребер. Для нашей простой матрицы длина горизонтальных ребер, например, считается по формуле:
\(1/2 (max(D[a,d]+D[b,c], D[a,c]+D[b,d])-D[a,b] – D[d,c])\)
\(1/2 (max(0.12+0.13, 0.12+0.09) – 0.07 – 0.06) = 0.06\)
<- neighborNet(D)
nnet par(mar = c(0,0,0,0))
plot(nnet, show.edge.label = T,
edge.label = nnet$edge.length,
edge.color = "grey",
col.edge.label = "navy")
Аналогичным образом считается длина вертикальных ребер. Формула сработает максимум для четырех таксонов, для более сложных структур понадобится метод наименьших квадратов. Все вычисления делает функция neighborNet из пакета phangorn
.
Если аргументу edge.label
оставить значение по умолчанию, то на картинке увидите номер сплита.
par(mar = c(0,0,0,0))
plot(nnet, show.edge.label = T,
edge.color = "grey",
col.edge.label = "red")
У каждого сплита есть свой вес (рассчитанный методом наименьших квадратов). Его можно достать из объекта nnet.
= attr(nnet$splits, "weights")
w w
[1] 0.01 0.03 0.03 0.02 0.06 0.02
Это можно понять так: чтобы попасть из пунка b в пункт d, нужно сложить веса для сплитов 4, 5 и 1:
4] + w[5] + w[1] w[
[1] 0.09
Это вернет нам 0.09. Сверяемся с матрицей расстояний — все верно!
Сплит — это разбиение совокупности таксонов на два непустых множества. Посмотрим, какие сплиты возможны для 4 таксонов из нашего примера:
as.matrix(nnet$splits)
d c a b
[1,] 1 0 0 0
[2,] 0 1 0 0
[3,] 0 0 1 0
[4,] 0 0 0 1
[5,] 1 1 0 0
[6,] 1 0 0 1
Первые четыре сплита довольно заурядны: мы просто откусываем по одному углу от нашего прямоугольника. Пятый сплит делит прямоугольник поперек, а шестой — вдоль. Дальше алгоритм для каждого сплита считает, какие пары таксонов оказались с разных сторон сплита. На основе матрицы сплитов А
и исходной матрицы расстояний D
рассчитывается длина ребра таким образом, чтобы кратчайшие пути между таксонами были максимально приближены к исходной матрице расстояний.
Как уже говорилось, для 4-х таксонов соответствие может быть полным. Это легко проверить, достав атрибут RSS (Residual Sum of Squares, остаточная сумма квадратов) из объекта nnet, который мы создали.
round(attr(nnet$splits, "RSS"), 3)
[1] 0
17.9 neighborNet()
: galbraith
Теперь применим алгоритм к реальным данным.
par(mar = c(0,0,0,0), cex = 0.8)
<- neighborNet(distmx)
nnet
#remotes::install_github("MatthewBJane/ThemePark")
library(ThemePark)
<- lordoftherings_theme_colors[c(1:4, 7)]
pal
# назначаем авторам цвета
<- tibble(author = str_remove(nnet$tip.label, "_.+")) |>
cols mutate(color = case_when(author == "coben" ~ pal[1],
== "galbraith" ~ pal[2],
author == "lewis" ~ pal[3],
author == "rowling" ~ pal[4],
author == "tolkien" ~ pal[5]))
author
plot(nnet,
direction = "axial",
edge.color = "grey30",
use.edge.length = TRUE, # попробуйте FALSE
edge.width = 1,
tip.color = cols$color)
В статье “Untangling Our Past: Languages, Trees, Splits and Networks” создатели алгоритма NeighborNet объясняют, как правильно интерпретировать подобный граф на примере дерева германских языков.
Конфликтующие сигналы передаются за счет “ретикулярной структуры” (квадратиков, проще говоря). Там, где конфликта нет, мы видим дерево.
Каждый сплит представлен несколькими параллельными линиями, и если эти параллели удалить, то граф распадется на два. Чем длиннее ребро, тем “весомее” сплит.
На графе видно, что креольский язык сранан-тонго обладает сходством и с английским, и с нидерландским (граф можно разрезать по зеленым линиям двояко).
Более слабый конфликтующий сигнал прослеживается между немецким, нидерландским и фламандским, с одной стороны, и пенсильванским немецким, с другой (синий разрез).
Рассмотренные филогенетические методы (консенсусные сети, консенсусные деревья и neighborNet) ничего не говорят о происхождении одного текста от другого. Филограмма, полученная дистанционными методами, не отражает эволюционный процесс, а показывает степень дивергенции таксонов.
Это значит, что модель NeighborNet не делает никаких допущений о происхождении, однако в каком-то смысле она вполне способна показывать то, что называют «конфликтующими сигналами». В биологии это рекомбинация, гибридизация и т.п., а в гуманитарных науках — жанровые и диалектные особенности, отношения подражания, заимствования и все то, что способно влиять на результат классификации текстов, помимо авторства.
17.10 Сетевой анализ в stylo
Пакет stylo
не создает сетей как таковых, однако он генерирует таблицы ребер/узлов (или только ребер), используя два алгоритма Эдера для установления связей между узлами. Таблицу можно загрузить в Gephi (https://gephi.org) или прочитать в R (что мы сделаем дальше). Чтобы получить такую таблицу, вызовите функцию stylo()
с аргументом network=TRUE
и, по желанию, с некоторыми другими аргументами.
stylo(network = TRUE,
frequencies = galbraith,
network.type="undirected",
network.tables="both",
linked.neighbors=3,
edge.weights="linear",
gui=FALSE)
Теперь в рабочей директории должны были появиться два файла .csv
.
<- list.files(pattern = "csv")
my_csv my_csv
[1] "book_CA_100_MFWs_Culled_0__Classic Delta_EDGES.csv"
[2] "book_CA_100_MFWs_Culled_0__Classic Delta_NODES.csv"
<- read_csv(my_csv[1])
galbraith_edges galbraith_edges
<- read_csv(my_csv[2])
galbraith_nodes galbraith_nodes
Соединим две таблицы.
<- galbraith_edges |>
net_data left_join(galbraith_nodes,
by = join_by(Source == Id)) |>
select(-Source) |>
rename(Source = Label) |>
relocate(Source, .before = Target) |>
left_join(galbraith_nodes,
by = join_by(Target == Id)) |>
select(-Target) |>
rename(Target = Label) |>
relocate(Target, .after = Source) |>
select(Source, Target, Weight)
net_data
library(igraph)
<- graph_from_data_frame(net_data, directed = FALSE)
galbraith_graph galbraith_graph
IGRAPH e39ee28 UN-- 26 104 --
+ attr: name (v/c), Weight (e/n)
+ edges from e39ee28 (vertex names):
[1] coben_breaker --coben_dropshot coben_breaker --coben_fadeaway
[3] coben_breaker --coben_falsemove coben_breaker --coben_dropshot
[5] coben_dropshot --coben_fadeaway coben_dropshot --coben_falsemove
[7] coben_breaker --coben_fadeaway coben_dropshot --coben_fadeaway
[9] coben_fadeaway --coben_falsemove coben_breaker --coben_falsemove
[11] coben_dropshot --coben_falsemove coben_fadeaway --coben_falsemove
[13] coben_falsemove--coben_goneforgood coben_falsemove--coben_nosecondchance
[15] coben_falsemove--coben_tellnoone coben_falsemove--coben_goneforgood
+ ... omitted several edges
library(ggraph)
# нормализация весов
<- (E(galbraith_graph)$Weight - min(E(galbraith_graph)$Weight)) / (max(E(galbraith_graph)$Weight) - min(E(galbraith_graph)$Weight))
weights E(galbraith_graph)$Weight <- weights
# атрибут с именем автора
= str_remove(V(galbraith_graph)$name, "_.+$")
labels V(galbraith_graph)$label <- labels
# граф
ggraph(galbraith_graph, layout = "kk") +
geom_edge_link(aes(alpha = Weight),
linewidth = 1.1,
show.legend = FALSE,
color = "grey70") +
geom_node_point(aes(color = label),
size = 3, shape = 21,
fill = "white",
show.legend = FALSE) +
geom_node_label(aes(label = name, color = label),
vjust = -1, cex = 2,
show.legend = FALSE) +
labs(x = NULL, y = NULL) +
theme_void()
У нас получились три не связанные между собой подсети. О том, как работать с такого рода объектами в R, и как их интерпретировать, мы поговорим уже в следующий раз 🧙♂️.