library(tidyverse)
library(textrecipes)
library(tidymodels)
library(tidytext)
library(stylo)
library(udpipe)
library(ggcorrplot)
library(dplyr)
library(embed)
library(baguette)
library(discrim)
library(broom)
library(future)
library(ggplot2)
library(forcats)Стилистические особенности британских авторов конца XVIII — XIX веков
Анализ стилистических особенностей авторов и классификация текстов по авторам на основе корпуса из 28 произведений британской прозы конца XVIII — XIX веков с применением фреймворка tidymodels в R
Введение
В данном исследовании реализуются две модели авторской атрибуции, каждая из которых отличается составом используемых предикторов. Модели строятся на основе текстов, нарезанных на чанки по 1000 токенов, что позволяет обеспечить унифицированную структуру данных для обучения и кросс-валидации.
Модель на основе лингвистических признаков. Используются агрегированные количественные характеристики текстов, такие как средняя длина слова, индекс лексического разнообразия (TTR), относительная частотность различных частей речи (глаголов, существительных, прилагательных и др.), средняя длина предложения и др.
Модель на основе частотных n-грамм и стоп-слов. Во второй модели используются 1000 наиболее частотных биграмм и триграмм по корпусу и относительная частотность стоп-слов в каждом чанке
Imports
Подготовка данных
files <- list.files("corpus", pattern = "\\.txt$", full.names = TRUE)
corpus <- tibble(
file = files,
text = sapply(files, readLines, encoding = "UTF-8") |>
sapply(paste, collapse = " ")
) |>
mutate(
filename = basename(file),
author = str_extract(filename, "^[^_]+")
) |>
select(author, text)На графике представлено распределение произведений по авторам, включённым в корпус. По оси X указано количество текстов каждого автора, по оси Y — имена авторов. Наибольшее число произведений представлено у Trollope, Thackeray, Eliot и Dickens. Меньше всего — у EBronte.
corpus |>
count(author) |>
ggplot(aes(reorder(author, n), n, fill = author)) +
geom_col(show.legend = FALSE) +
xlab("Автор") +
ylab("Количество текстов") +
scale_fill_viridis_d() +
theme_light() +
coord_flip()
Сбор признаков для модели 1
Средняя длина предложений
sentences_df <- corpus |>
unnest_tokens(sentence, text, token = "sentences")
sentence_lengths <- sentences_df |>
mutate(word_count = str_count(sentence, "\\S+")) # любое непробельное слово
avg_sent_len <- sentence_lengths |>
group_by(author) |>
summarise(avg_sentence_length = mean(word_count))Токенизация текстов и разбиение на отрывки фиксированной длины. Для достаточной обучающей выборки и проведения кросс-валидации все тексты каждого автора объединяются в одну строку, после чего токенизируются и разбиваются на чанки по 1000 токенов. В результате получаем корпус из 6472 наблюдений, где каждое наблюдение - последовательность из 1000 токенов, принадлежащих одному автору.
combined_corpus <- corpus |>
group_by(author) |>
summarise(full_text = paste(text, collapse = " "))
tokenized <- combined_corpus |>
unnest_tokens(word, full_text)
tokenized <- tokenized |>
group_by(author) |>
mutate(token_id = row_number())
chunked <- tokenized |>
mutate(chunk_id = (token_id - 1) %/% 1000 + 1) |>
group_by(author, chunk_id) |>
summarise(text_chunk = paste(word, collapse = " "))Очистим одну из версий корпуса при помощи TF-IDF. Предположим, что термины с высоким TF-IDF у конкретного автора, но с низкой распространённостью в других текстах, часто бывают именами и названиями (например, имена персонажей, фамилии, локации)
word_counts <- tokenized |>
count(author, word, sort = TRUE)
word_tf_idf <- word_counts |>
bind_tf_idf(term = word, document = author, n = n)
names_to_remove <- word_tf_idf |>
arrange(desc(tf_idf)) |>
slice_max(tf_idf, n = 50) |>
pull(word)
tokenized_clean <- tokenized |>
filter(!word %in% names_to_remove)
chunked_clean <- tokenized_clean |>
mutate(chunk_id = (token_id - 1) %/% 1000 + 1) |>
group_by(author, chunk_id) |>
summarise(text_chunk = paste(word, collapse = " "))Создание таблицы признаков, в которой каждому чанку сопоставляется средняя длина предложения, характерная для соответствующего автора
features_df <- chunked |>
select(author, chunk_id) |>
left_join(avg_sent_len, by = "author")Средняя длина слов
corpus_words <- chunked |>
mutate(text_chunk = str_split(text_chunk, "\\s+")) |>
rowwise() |>
mutate(avg_word_length = mean(str_length(unlist(text_chunk)), na.rm = TRUE)) |>
ungroup()
features_df <- features_df |>
left_join(
corpus_words |> select(author, chunk_id, avg_word_length),
by = c("author", "chunk_id")
)POS-tagging. Для извлечения грамматических признаков используем модель UDPipe ― english-ewt, основанную на корпусе English Web Treebank. К каждому чанку применяем POS-теггер, а результат аннотации сохраняем, чтобы избежать повторных длительных вычислений. После выполнения этого кода каждая строка tagged содержит одну лексему с указанием её части речи (upos), леммы, грамматических характеристик (feats) и других синтаксических параметров.
tagged <- readRDS("tagged_udpipe.rds")
chunk_meta <- chunked |> select(author, chunk_id)
tagged <- tagged |>
mutate(chunk_id = chunk_meta$chunk_id,
author = chunk_meta$author) |>
unnest(cols = annotation)
tagged# A tibble: 6,539,916 × 17
author chunk_id text_chunk doc_id paragraph_id sentence_id sentence token_id
<chr> <dbl> <chr> <chr> <int> <int> <chr> <chr>
1 ABronte 1 agnes gre… doc1 1 1 agnes g… 1
2 ABronte 1 agnes gre… doc1 1 1 agnes g… 2
3 ABronte 1 agnes gre… doc1 1 1 agnes g… 3
4 ABronte 1 agnes gre… doc1 1 1 agnes g… 4
5 ABronte 1 agnes gre… doc1 1 1 agnes g… 5
6 ABronte 1 agnes gre… doc1 1 1 agnes g… 6
7 ABronte 1 agnes gre… doc1 1 1 agnes g… 7
8 ABronte 1 agnes gre… doc1 1 1 agnes g… 8
9 ABronte 1 agnes gre… doc1 1 1 agnes g… 9
10 ABronte 1 agnes gre… doc1 1 1 agnes g… 10
# ℹ 6,539,906 more rows
# ℹ 9 more variables: token <chr>, lemma <chr>, upos <chr>, xpos <chr>,
# feats <chr>, head_token_id <chr>, dep_rel <chr>, deps <chr>, misc <chr>Подсчет TTR (Type-Token Ratio) — отношения количества уникальных лемм (types) к общему количеству слов (tokens). Этот индекс позволяет измерить лексическое разнообразие автора.
ttr <- tagged |>
group_by(author, chunk_id) |>
summarise(
types = n_distinct(lemma),
tokens = n(),
TTR = types / tokens)
features_df <- features_df |>
left_join(ttr |> select(author, chunk_id, TTR), by = c("author", "chunk_id"))Относительная частотность различных частей речи
pos_freqs <- tagged |>
count(author, chunk_id, upos) |>
group_by(author, chunk_id) |>
mutate(freq = n / sum(n)) |>
filter(upos %in% c("VERB", "NOUN", "ADJ", "ADV", "PRON", "CCONJ", "SCONJ", "PART", "DET", "PUNCT", "NUM")) |>
select(author, chunk_id, upos, freq) |>
pivot_wider(names_from = upos, values_from = freq, values_fill = 0) |>
rename(
verb_freq = VERB,
noun_freq = NOUN,
adj_freq = ADJ,
adv_freq = ADV,
pron_freq = PRON,
cconj_freq = CCONJ,
sconj_freq = SCONJ,
part_freq = PART,
det_freq = DET,
punct_freq = PUNCT,
num_freq = NUM
)
features_df <- features_df |>
left_join(pos_freqs, by = c("author", "chunk_id"))Грамматические характеристики глаголов - доли инфинитивов и глаголов в прошедшем и настоящем временах
verb_features <- tagged |>
filter(upos == "VERB") |>
count(author, chunk_id, feats) |>
group_by(author, chunk_id) |>
mutate(freq = n / sum(n)) |>
summarise(
infinitive_ratio = sum(freq[str_detect(feats, "VerbForm=Inf")], na.rm = TRUE),
past_ratio = sum(freq[str_detect(feats, "Tense=Past")], na.rm = TRUE),
present_ratio = sum(freq[str_detect(feats, "Tense=Pres")], na.rm = TRUE))
features_df <- features_df |>
left_join(verb_features, by = c("author", "chunk_id"))Относительная частотность степеней сравнения прилагательных и наречий
# Сравнительная степень
comparative_forms <- tagged |>
filter(upos %in% c("ADJ", "ADV")) |>
count(author, chunk_id, feats) |>
group_by(author, chunk_id) |>
mutate(freq = n / sum(n)) |>
filter(str_detect(feats, "Degree=Cmp")) |>
summarise(comparative_ratio = sum(freq))
# Превосходная степень
superlative_forms <- tagged |>
filter(upos %in% c("ADJ", "ADV")) |>
count(author, chunk_id, feats) |>
group_by(author, chunk_id) |>
mutate(freq = n / sum(n)) |>
filter(str_detect(feats, "Degree=Sup")) |>
summarise(superlative_ratio = sum(freq))
# Объединение с features_df
features_df <- features_df |>
left_join(comparative_forms, by = c("author", "chunk_id")) |>
left_join(superlative_forms, by = c("author", "chunk_id"))Приведениек формату tidy
colnames(features_df) <- make.names(colnames(features_df))
features_df[is.na(features_df)] <- 0
features_df# A tibble: 6,472 × 21
# Groups: author [11]
author chunk_id avg_sentence_length avg_word_length TTR adj_freq adv_freq
<chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 ABronte 1 23.0 4.39 0.407 0.0763 0.0664
2 ABronte 2 23.0 4.64 0.438 0.0695 0.0785
3 ABronte 3 23.0 4.06 0.343 0.0574 0.0752
4 ABronte 4 23.0 4.30 0.418 0.0896 0.0766
5 ABronte 5 23.0 4.20 0.431 0.0627 0.102
6 ABronte 6 23.0 4.28 0.407 0.0833 0.0724
7 ABronte 7 23.0 3.87 0.338 0.0581 0.0788
8 ABronte 8 23.0 4.31 0.406 0.0634 0.0813
9 ABronte 9 23.0 4.28 0.394 0.0703 0.0802
10 ABronte 10 23.0 4.27 0.391 0.0609 0.0809
# ℹ 6,462 more rows
# ℹ 14 more variables: cconj_freq <dbl>, det_freq <dbl>, noun_freq <dbl>,
# num_freq <dbl>, part_freq <dbl>, pron_freq <dbl>, sconj_freq <dbl>,
# verb_freq <dbl>, punct_freq <dbl>, infinitive_ratio <dbl>,
# past_ratio <dbl>, present_ratio <dbl>, comparative_ratio <dbl>,
# superlative_ratio <dbl>Сбор признаков для модели 2
Относительная частотность стоп-слов
corpus_words_clean <- chunked_clean |>
mutate(text_chunk = str_split(text_chunk, "\\s+")) |>
rowwise()
corpus_long <- corpus_words_clean |>
select(author, chunk_id, text_chunk) |>
unnest(cols = c(text_chunk), names_repair = "minimal") |>
rename(word = text_chunk)
stopword_counts <- corpus_long |>
inner_join(stop_words, by = "word") |>
count(author, chunk_id, word, name = "count") |>
mutate(rel_freq = count / 1000)
# Приведение к широкому формату
stopword_features <- stopword_counts |>
select(author, chunk_id, word, rel_freq) |>
pivot_wider(
names_from = word,
values_from = rel_freq,
values_fill = 0
)
colnames(stopword_features) <- make.names(colnames(stopword_features))
stopword_features# A tibble: 6,472 × 701
# Groups: author [11]
author chunk_id a according against all already always am among
<chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 ABronte 1 0.072 0.001 0.003 0.024 0.002 0.002 0.002 0.002
2 ABronte 2 0.012 0 0.003 0.024 0 0.004 0 0
3 ABronte 3 0.075 0 0 0.015 0.002 0.004 0.006 0
4 ABronte 4 0.066 0 0.003 0.012 0.004 0 0.002 0
5 ABronte 5 0.069 0 0 0.009 0 0 0 0.002
6 ABronte 6 0.078 0 0 0.012 0 0.002 0 0
7 ABronte 7 0.072 0 0 0.009 0 0.002 0.002 0
8 ABronte 8 0.057 0 0 0.012 0.002 0 0.002 0
9 ABronte 9 0.051 0 0.003 0.003 0.002 0.002 0 0
10 ABronte 10 0.036 0 0 0.006 0 0 0 0
# ℹ 6,462 more rows
# ℹ 691 more variables: an <dbl>, and <dbl>, any <dbl>, as <dbl>, at <dbl>,
# be <dbl>, became <dbl>, been <dbl>, before <dbl>, being <dbl>,
# believe <dbl>, besides <dbl>, beyond <dbl>, both <dbl>, but <dbl>,
# by <dbl>, case <dbl>, come <dbl>, contain <dbl>, could <dbl>, do <dbl>,
# doing <dbl>, early <dbl>, even <dbl>, ever <dbl>, every <dbl>, few <dbl>,
# find <dbl>, five <dbl>, for. <dbl>, from <dbl>, further <dbl>, …Ngrams
# Биграммы
bigrams_df <- corpus_words_clean |>
ungroup() |>
mutate(lemma_text = map_chr(text_chunk, ~ paste(.x, collapse = " "))) |>
unnest_tokens(bigram, lemma_text, token = "ngrams", n = 2)
top_bigrams <- bigrams_df |>
count(bigram, sort = TRUE) |>
slice_max(n, n = 1000)
bigrams_df <- bigrams_df |>
semi_join(top_bigrams, by = "bigram")
bigram_features <- bigrams_df |>
count(author, chunk_id, bigram) |>
pivot_wider(
names_from = bigram,
values_from = n,
values_fill = 0
)
# Триграммы
trigrams_df <- corpus_words_clean |>
ungroup() |>
mutate(lemma_text = map_chr(text_chunk, ~ paste(.x, collapse = " "))) |>
unnest_tokens(trigram, lemma_text, token = "ngrams", n = 3)
top_trigrams <- trigrams_df |>
count(trigram, sort = TRUE) |>
slice_max(n, n = 1000)
trigrams_df <- trigrams_df |>
semi_join(top_trigrams, by = "trigram")
trigram_features <- trigrams_df |>
count(author, chunk_id, trigram) |>
pivot_wider(
names_from = trigram,
values_from = n,
values_fill = 0
)
# Конкатенация
features_two <- full_join(bigram_features, trigram_features, by = c("author", "chunk_id"))
features_two <- features_two |>
left_join(stopword_features, by = c("author", "chunk_id"))
colnames(features_two) <- make.names(colnames(features_two))Модель на основе лингвистических признаков
Актуальная версия features_df, содержащая 18 предикторов - разнообразные количественные лингвистические характеристики (например, TTR, длину слов, частотность частей речи, грамматические особенности и др.), будет использована в качестве матрицы признаков для построения модели авторской атрибуции.
Разведывательный анализ
Матрица корреляций
numeric_features <- features_df |>
ungroup() |>
select(where(is.numeric)) |>
select(-chunk_id)
corr_matrix <- cor(numeric_features, use = "complete.obs")
ggcorrplot(corr_matrix,
method = "circle",
type = "lower",
lab = TRUE,
tl.cex = 8,
lab_size = 3,
colors = c("blue", "white", "red"))
На графике мы наблюдаем значимые взаимосвязи между признаками:
- past_ratio и present_ratio (–0.78). Авторы склонны использовать либо прошедшее, либо настоящее время
- past_ratio и infinitive_ratio (–0.7). Повышенное использование прошедшего времени связано со снижением доли инфинитивов
- part_freq и infinitive_ratio (0.65). Частицы используются значительно чаще в текстах с высокой долей инфинитивов
- det_freq и pron_freq (–0.78), а det_freq и noun_freq (0.7). В текстах с высоким использованием определителей (the, a) наблюдается меньше местоимений. В свою очередь, имена существительные часто сопровождаются детерминантами
Положительные корреляции:
- avg_word_length и TTR (0.70). Чем длиннее слова в тексте, тем выше лексическое разнообразие. Можно предположить, что более редкие слова обычно длиннее
- noun_freq и TTR (0.64); noun_freq и avg_word_length (0.66). Авторы с частым использованием имен существительных, как правило, обладают более разнообразной лексикой и используют более длинные слова
Распределение признаков
Гистограммы позволят выявить выбросы и определить, какие признаки дают большее разнообразие между авторами.
features_df |>
select(-chunk_id) |>
pivot_longer(cols = where(is.numeric)) |>
ggplot(aes(value)) +
geom_histogram(bins = 30, fill = "skyblue") +
facet_wrap(~name, scales = "free") +
theme_minimal()
Лексические и синтаксические признаки:
- avg_sentence_length - пиковые значения, которые появляются, вероятнее всего, из-за того, что была посчитана средняя длина предложения по всему автору, а затем приписана каждому наблюдению. Вероятнее всего, лучше будет исключить этот предиктор.
- TTR - распределение скошено влево
- avg_word_length - практически нормальное распределение
Частотности частей речи:
- noun_freq, verb_freq, adj_freq, adv_freq, pron_freq, det_freq, part_freq - практически нормальное распределение
- num_freq, punct_freq - сильная скошенность влево
Грамматические признаки:
- comparative_ratio, superlative_ratio - скошенность влево
- infinitive_ratio, present_ratio, past_ratio - довольно широкие распределения; past_ratio доминирующий
Исключим chunk_id из данных, поделим на тренировочную и тестовую выборки
features_df <- features_df |>
select(-chunk_id, -avg_sentence_length)
set.seed(20)
data_split <- features_df |>
mutate(author = as.factor(author)) |>
initial_split(strata = author)
data_train <- training(data_split)
data_test <- testing(data_split)
folds <- vfold_cv(data_train, strata = author, v = 15)Подготовка базового рецепта
base_rec <- recipe(author ~ ., data = data_train) |>
step_zv(all_predictors()) |>
step_normalize(all_predictors())
base_trained <- base_rec |>
prep(data_train)
base_trained |>
bake(new_data = NULL)# A tibble: 4,851 × 19
avg_word_length TTR adj_freq adv_freq cconj_freq det_freq noun_freq
<dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 -0.799 -0.742 -0.730 0.368 1.28 -0.822 -1.13
2 -1.78 -0.873 -0.669 0.644 1.26 -1.63 -1.28
3 0.273 0.430 -0.446 0.803 2.50 -0.493 -1.05
4 1.04 0.995 -0.494 0.218 1.59 0.375 0.0727
5 0.551 0.735 -1.31 -0.203 1.02 -0.576 -0.0784
6 1.03 1.05 1.06 -0.333 1.76 -0.723 -0.391
7 0.561 1.04 0.0135 -2.08 1.64 1.62 1.13
8 0.983 0.884 2.38 1.68 1.53 -0.339 -0.544
9 1.48 1.17 1.13 1.02 0.839 -0.668 0.0484
10 -0.191 0.0288 -1.22 3.03 0.213 -1.01 -1.02
# ℹ 4,841 more rows
# ℹ 12 more variables: num_freq <dbl>, part_freq <dbl>, pron_freq <dbl>,
# sconj_freq <dbl>, verb_freq <dbl>, punct_freq <dbl>,
# infinitive_ratio <dbl>, past_ratio <dbl>, present_ratio <dbl>,
# comparative_ratio <dbl>, superlative_ratio <dbl>, author <fct>PCA для разведывательного анализа
pca_rec <- base_rec |>
step_pca(all_predictors(), num_comp = 10)
pca_trained <- pca_rec |>
prep(data_train)
pca_trained |>
juice()# A tibble: 4,851 × 11
author PC01 PC02 PC03 PC04 PC05 PC06 PC07 PC08 PC09
<fct> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 ABronte -3.41 -0.467 0.468 0.942 0.719 -0.0952 1.74 -1.19 -0.708
2 ABronte -3.28 1.07 2.31 0.662 1.06 -0.0437 1.63 -1.50 0.718
3 ABronte -1.33 0.797 0.916 2.27 0.402 0.183 0.306 -0.658 -2.03
4 ABronte 1.14 0.604 1.28 1.26 0.498 0.245 0.463 -0.0300 0.407
5 ABronte -0.545 0.771 0.536 -0.493 -0.243 -0.240 1.08 -1.31 -0.878
6 ABronte 0.136 0.139 0.148 2.22 0.358 0.210 0.464 1.21 -2.33
7 ABronte 3.34 1.02 1.72 0.399 -1.43 0.117 1.58 -0.409 -0.415
8 ABronte 1.85 0.451 0.624 2.00 1.93 0.450 -2.11 0.367 -1.46
9 ABronte 1.01 -0.105 -0.321 0.588 2.08 0.000526 -0.213 -0.486 -0.129
10 ABronte -2.48 1.73 -0.00840 0.948 1.90 -0.0650 0.176 -0.729 1.93
# ℹ 4,841 more rows
# ℹ 1 more variable: PC10 <dbl>pca_trained |>
juice() |>
ggplot(aes(PC01, PC02, color = author)) +
geom_point() +
theme_light()
Мы видим, что точки сильно перекрываются, авторы не образуют чётких кластеров в проекции на первые две главные компоненты. Так как PCA — линейный метод, возможно, это связано с тем, что данные не рапределены линейно.
UMAP для разведывательного анализа
set.seed(20)
base_trained |>
step_umap(all_numeric_predictors(), outcome = "author", num_comp = 5) |>
prep() |>
juice() |>
ggplot(aes(UMAP1, UMAP2, color = author)) +
geom_point(alpha = 0.5) +
theme_light()
umap_rec <- base_rec |>
step_umap(all_numeric_predictors(),
outcome = "author",
num_comp = tune(),
neighbors = tune(),
min_dist = tune()
)UMAP — метод нелинейного понижения размерности, который пытается сохранить локальную структуру данных при проекции в двумерное пространство. В данном случае он дал лучший по сравнению с PCA, но не идеальный результат. Начинают просматриваться отдельные кластеры, но, тем не менее, мы наблюдаем заметное перекрытие.
Построение модели
Так как у нас всего 18 признаков, они плотные, числовые, не разреженные, будем использовать модели Support Vector Machine (SVM), Single-layer Neural Network (MLP), Bagging with Decision Trees, Logistic Regression, Extreme Gradient Boosting (XGBoost) и Random Forest
svm_spec <- svm_linear(cost = tune()) |>
set_mode("classification") |>
set_engine("LiblineaR")
mlp_spec <- mlp(hidden_units = tune(),
penalty = tune(),
epochs = tune()) |>
set_engine("nnet") |>
set_mode("classification")
bagging_spec <- bag_tree(mode = "classification") |>
set_engine("rpart", times = 25)
logreg_spec <- multinom_reg(mode = "classification") |>
set_engine("nnet")
boost_spec <- boost_tree(
mode = "classification",
trees = 500,
tree_depth = tune()
) |>
set_engine("xgboost")
rand_forest_spec <- rand_forest(
mode = "classification",
trees = 500,
min_n = tune()
) |>
set_engine("ranger")Собираем workflow_set
wflow_set <- workflow_set(
preproc = list(base = base_rec,
pca = pca_rec,
umap = umap_rec),
models = list(svm = svm_spec,
mlp = mlp_spec,
bagging = bagging_spec,
logreg = logreg_spec,
boost = boost_spec,
rf = rand_forest_spec),
cross = TRUE
)Подгружаем модель, чтобы не ждать ее обучения
train_res <- readRDS("train_res.rds")
# train_res <- wflow_set |>
# workflow_map(
# verbose = TRUE,
# seed = 20,
# resamples = folds,
# grid = 5,
# metrics = metric_set(f_meas, accuracy),
# control = control_grid(save_pred = TRUE, parallel_over = "everything")
# )Оценка и выбор модели
autoplot(train_res, metric = "accuracy") +
theme_light() +
theme(legend.position = "none") +
geom_text(aes(y = (mean - 2*std_err), label = wflow_id),
angle = 90, hjust = 1.5) +
coord_cartesian(ylim = c(-0.3, NA))
На графике видим, что наилучший результат показали модели, обученные на базовом рецепте без использования методов уменьшения размерности (PCA или UMAP). Лучшими моделями по точности оказались Logistic Regression, XGBoost и MLP.
rank_results(train_res, select_best = TRUE) |>
print()# A tibble: 36 × 9
wflow_id .config .metric mean std_err n preprocessor model rank
<chr> <chr> <chr> <dbl> <dbl> <int> <chr> <chr> <int>
1 base_logreg Preprocesso… accura… 0.706 0.00729 15 recipe mult… 1
2 base_logreg Preprocesso… f_meas 0.696 0.00786 15 recipe mult… 1
3 base_boost Preprocesso… accura… 0.709 0.00524 15 recipe boos… 2
4 base_boost Preprocesso… f_meas 0.687 0.00901 15 recipe boos… 2
5 base_mlp Preprocesso… accura… 0.706 0.00756 15 recipe mlp 3
6 base_mlp Preprocesso… f_meas 0.685 0.00903 15 recipe mlp 3
7 base_svm Preprocesso… accura… 0.691 0.00737 15 recipe svm_… 4
8 base_svm Preprocesso… f_meas 0.671 0.00793 15 recipe svm_… 4
9 base_rf Preprocesso… accura… 0.671 0.00787 15 recipe rand… 5
10 base_rf Preprocesso… f_meas 0.630 0.00992 15 recipe rand… 5
# ℹ 26 more rowsФинализируем workflow с лучшей моделью Logreg
best_results <-
train_res |>
extract_workflow_set_result("base_logreg") |>
select_best(metric = "accuracy")
print(best_results)# A tibble: 1 × 1
.config
<chr>
1 Preprocessor1_Model1logreg_res <- train_res |>
extract_workflow("base_logreg") |>
finalize_workflow(best_results) |>
last_fit(split = data_split, metrics = metric_set(f_meas, accuracy, roc_auc))
collect_metrics(logreg_res) |>
print()# A tibble: 3 × 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <chr>
1 f_meas macro 0.714 Preprocessor1_Model1
2 accuracy multiclass 0.717 Preprocessor1_Model1
3 roc_auc hand_till 0.959 Preprocessor1_Model1Построим confusion matrix. На графике тепловой карты видно, что, несмотря на четко выделяющуюся диагональ, модель часто ошибалась.
collect_predictions(logreg_res) |>
conf_mat(truth = author, estimate = .pred_class) |>
autoplot(type = "heatmap") +
scale_fill_gradient(low = "white", high = "#233857") +
theme(panel.grid.major = element_line(colour = "#233857"),
axis.text = element_text(color = "#233857"),
axis.title = element_text(color = "#233857"),
plot.title = element_text(color = "#233857"),
axis.text.x = element_text(angle = 90))
Все ROC-кривые располагаются сильно выше диагонали случайных предсказаний, что говорит о хорошем качестве классификации. Плотное переплетение кривых и отсутствие ярко выделяющихся кривых свидетельствуют о том, что ни один класс не доминирует по качеству, а различия между авторами выражены довольно равномерно.
collect_predictions(logreg_res) |>
roc_curve(truth = author, .pred_ABronte:.pred_Trollope) |>
ggplot(aes(1 - specificity, sensitivity, color = .level)) +
geom_abline(slope = 1, color = "gray50", lty = 2, alpha = 0.8) +
geom_path(linewidth = 1.5, alpha = 0.7) +
labs(color = NULL) +
theme_light()
Интерпретация результатов.
Наиболее важные признаки
logreg_wf <- train_res |>
extract_workflow("base_logreg") |>
finalize_workflow(best_results)
logreg_fit <- fit(logreg_wf, data = training(data_split))
logreg_engine <- extract_fit_engine(logreg_fit)
coefs <- coef(logreg_engine)
logreg_coefs <- as.data.frame(coefs) |>
rownames_to_column("author") |>
pivot_longer(-author, names_to = "feature", values_to = "estimate")
logreg_coefs |>
filter(feature != "(Intercept)") |>
group_by(author) |>
slice_max(order_by = abs(estimate), n = 10) |>
ungroup() |>
ggplot(aes(x = estimate, y = fct_reorder(feature, estimate), fill = author)) +
geom_col(alpha = 0.85, show.legend = FALSE) +
facet_wrap(~ author, scales = "free_y", ncol = 3) +
labs(title = "Top-10 most important features") +
scale_fill_viridis_d(option = "C") +
theme_minimal()
На графике представлены топ-10 наиболее важных признаков для каждого автора в модели логистической регрессии. Каждая панель соответствует одному автору и показывает, какие признаки (лингвистические характеристики) в наибольшей степени повлияли на вероятность отнесения текста к этому автору (в one-vs-rest схеме).
- pron_freq (частотность местоимений) и cconj_freq (сочинительные союзы) встречаются среди важных признаков почти у всех авторов
- avg_word_length и TTR (разнообразие лексики) также часто встречаются — они отражают общую сложность лексики автора
- у Thackeray, Dickens, Trollope — высокое значение имеют доли глагольных времен и infinitive_ratio
- Наибольшим лексическим разнообразием отличаются EBronte и CBronte
Вывод
Модели XGBoost и Logistic Regression показали наилучший результат среди всех протестированных: логистическая регрессия достигла accuracy 0.717 и f-measure 0.714, в то время как XGBoost показал сопоставимые значения — accuracy 0.708 и f-measure 0.691. Обе модели продемонстрировали высокое качество по метрике ROC AUC (> 0.95), что говорит о хорошей способности различать классы.
Признаки, основанные на лингвистических характеристиках — частотности частей речи, длине слов и предложений, TTR, соотношении грамматических форм — оказались информативными и достаточными для успешного решения задачи авторской атрибуции.
Модель на основе частотных n-грамм и стоп-слов
Во второй модели используется корпус текстов, разбитый на чанки по 1000 токенов. Из каждого фрагмента извлекаются частотные признаки, связанные с использованием типичных словосочетаний (биграмм и триграмм) и стоп-слов. В отличие от первой модели, здесь не учитываются грамматические или синтаксические характеристики.
Подготовим данные для дальнейшего обучения
features_two <- features_two |>
select(-chunk_id) |>
mutate(across(everything(), ~replace_na(.x, 0)))
data_split <- features_two |>
mutate(author = as.factor(author)) |>
initial_split(strata = author)
data_train <- training(data_split)
data_test <- testing(data_split)
folds <- vfold_cv(data_train, strata = author, v = 10)Создание базового рецепта
base_rec <- recipe(author ~ ., data = data_train) |>
step_zv(all_predictors()) |>
step_normalize(all_numeric_predictors())
base_trained <- base_rec |>
prep(data_train)
base_trained |>
bake(new_data = NULL)# A tibble: 4,852 × 2,699
a.few a.little a.man a.woman against.the all.the all.this among.the and.a
<dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 -0.481 -0.760 -0.616 -0.360 2.23 -0.766 -0.375 -0.290 0.493
2 1.34 0.261 -0.616 -0.360 -0.334 1.36 -0.375 -0.290 1.65
3 -0.481 0.261 -0.616 -0.360 -0.334 -0.766 -0.375 -0.290 -0.662
4 -0.481 -0.760 -0.616 -0.360 -0.334 -0.766 -0.375 -0.290 0.493
5 -0.481 -0.760 -0.616 -0.360 2.23 -0.766 -0.375 -0.290 -0.662
6 -0.481 -0.760 -0.616 -0.360 -0.334 0.296 1.98 -0.290 -0.662
7 -0.481 0.261 0.453 -0.360 -0.334 4.54 -0.375 -0.290 0.493
8 -0.481 -0.760 -0.616 -0.360 -0.334 -0.766 -0.375 -0.290 -0.662
9 3.15 1.28 -0.616 -0.360 -0.334 0.296 1.98 -0.290 -0.662
10 -0.481 -0.760 -0.616 -0.360 -0.334 -0.766 -0.375 -0.290 0.493
# ℹ 4,842 more rows
# ℹ 2,690 more variables: and.all <dbl>, and.as <dbl>, and.by <dbl>,
# and.he <dbl>, and.her <dbl>, and.his <dbl>, and.i <dbl>, and.if <dbl>,
# and.in <dbl>, and.my <dbl>, and.she <dbl>, and.the <dbl>, and.then <dbl>,
# and.to <dbl>, and.when <dbl>, and.who <dbl>, and.will <dbl>, and.yet <dbl>,
# any.other <dbl>, as.the <dbl>, at.least <dbl>, at.once <dbl>, be.the <dbl>,
# before.the <dbl>, but.he <dbl>, but.in <dbl>, but.she <dbl>, …Разведывательный анализ
Мы планируем обучать модель на 2702 предикторах - это частотность стоп-слов и ngrams. Наши данные представляют собой разреженную матрицу. Попробуем использовать методы уменьшения размерности PCA и UMAP.
PCA для разведывательного анализа
pca_rec <- base_rec |>
step_pca(all_predictors(), num_comp = 9)
pca_trained <- pca_rec |>
prep(data_train)
pca_trained |>
juice()# A tibble: 4,852 × 10
author PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8 PC9
<fct> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 ABronte 5.08 -4.65 3.66 -1.02 2.81 -2.07 1.27 -0.228 -2.52
2 ABronte 1.67 0.818 6.11 -3.82 -0.194 -0.527 -2.43 0.565 -2.16
3 ABronte -5.20 6.98 0.0608 2.79 -0.234 0.862 -1.86 -2.99 -3.71
4 ABronte 3.99 -0.992 3.69 -2.56 -1.26 -0.0749 1.59 -0.257 -0.439
5 ABronte 0.712 3.14 2.54 3.04 1.78 2.45 1.17 1.54 -2.04
6 ABronte -8.51 4.10 0.835 -2.22 0.859 -2.84 -0.581 -3.33 -7.59
7 ABronte -5.01 3.08 -2.33 4.19 -2.76 2.06 2.90 -4.06 -6.10
8 ABronte 1.74 -1.78 4.84 -4.44 3.67 -3.07 2.78 -3.12 -1.32
9 ABronte 0.0109 3.15 4.54 -5.29 2.05 -2.34 2.09 -0.182 -1.26
10 ABronte -2.81 -3.33 0.632 -1.39 0.153 -1.64 2.83 -3.11 0.0104
# ℹ 4,842 more rowspca_trained |>
juice() |>
ggplot(aes(PC1, PC2, color = author)) +
geom_point() +
theme_light()
На графике видим, что Richardson довольно хорошо отделяется вдоль PC1. Остальные авторы сильно перекрываются, что говорит о слабой линейной разделимости классов на основе выбранных предикторов.
UMAP для разведывательного анализа
set.seed(20)
base_trained |>
step_umap(all_numeric_predictors(), outcome = "author", num_comp = 5) |>
prep() |>
juice() |>
ggplot(aes(UMAP1, UMAP2, color = author)) +
geom_point(alpha = 0.5) +
theme_light()
umap_rec <- base_rec |>
step_umap(all_numeric_predictors(),
outcome = "author",
num_comp = tune(),
neighbors = tune(),
min_dist = tune()
)В отличие от PCA, здесь видно более чёткое разделение авторов. Особенно хорошо отделяются Richardson, Fielding, Austen. Остальные авторы довольно сильно перекрываются
Построение модели
Создаем спецификации двух моделей — линейной SVM и логистической регрессии с Lasso-регуляризацией, оптимальных для работы с разреженными высокоразмерными текстовыми признаками. Эти модели комбинируются с тремя вариантами предобработки: без изменений, с PCA и с UMAP, что позволяет сравнить эффективность линейного и нелинейного понижения размерности. Все комбинации объединяются в единый workflow_set для последующего тюнинга и оценки.
lasso_spec <- multinom_reg(penalty = tune(), mixture = 1) |>
set_mode("classification") |>
set_engine("glmnet")
svm_spec <- svm_linear(cost = tune()) |>
set_mode("classification") |>
set_engine("LiblineaR")
wflow_set <- workflow_set(
preproc = list(base = base_rec,
pca = pca_rec,
umap = umap_rec),
models = list(svm = svm_spec,
lasso = lasso_spec),
cross = TRUE
)
wflow_set# A workflow set/tibble: 6 × 4
wflow_id info option result
<chr> <list> <list> <list>
1 base_svm <tibble [1 × 4]> <opts[0]> <list [0]>
2 base_lasso <tibble [1 × 4]> <opts[0]> <list [0]>
3 pca_svm <tibble [1 × 4]> <opts[0]> <list [0]>
4 pca_lasso <tibble [1 × 4]> <opts[0]> <list [0]>
5 umap_svm <tibble [1 × 4]> <opts[0]> <list [0]>
6 umap_lasso <tibble [1 × 4]> <opts[0]> <list [0]>Подгрузим модель, чтобы не дожидаться ее обучения
train_res <- readRDS("second.rds")
# train_res <- wflow_set |>
# workflow_map(
# verbose = TRUE,
# seed = 20,
# resamples = folds,
# grid = 3,
# metrics = metric_set(f_meas, accuracy),
# control = control_resamples(save_pred = TRUE)
# )Оценка и выбор модели
Визуализируем точность моделей из workflow_set
autoplot(train_res, metric = "accuracy") +
theme_light() +
theme(legend.position = "none") +
geom_text(aes(y = (mean - 2*std_err), label = wflow_id),
angle = 90, hjust = 1.5) +
coord_cartesian(ylim = c(-0.3, NA))
rank_results(train_res, select_best = TRUE) |>
print()# A tibble: 12 × 9
wflow_id .config .metric mean std_err n preprocessor model rank
<chr> <chr> <chr> <dbl> <dbl> <int> <chr> <chr> <int>
1 base_lasso Preprocessor… accura… 0.967 0.00175 10 recipe mult… 1
2 base_lasso Preprocessor… f_meas 0.950 0.00377 10 recipe mult… 1
3 base_svm Preprocessor… accura… 0.965 0.00259 10 recipe svm_… 2
4 base_svm Preprocessor… f_meas 0.946 0.00631 10 recipe svm_… 2
5 pca_lasso Preprocessor… accura… 0.840 0.00418 10 recipe mult… 3
6 pca_lasso Preprocessor… f_meas 0.770 0.00861 10 recipe mult… 3
7 pca_svm Preprocessor… accura… 0.820 0.00483 10 recipe svm_… 4
8 pca_svm Preprocessor… f_meas 0.732 0.0109 10 recipe svm_… 4
9 umap_svm Preprocessor… accura… 0.563 0.0130 10 recipe svm_… 5
10 umap_svm Preprocessor… f_meas 0.492 0.0118 10 recipe svm_… 5
11 umap_lasso Preprocessor… accura… 0.220 0.00230 10 recipe mult… 6
12 umap_lasso Preprocessor… f_meas 0.361 0.00312 10 recipe mult… 6Наилучший результат показали модели, обученные на базовом рецепте без уменьшения размерности.
Извлекаем параметры, обеспечившие наилучшую точность для модели base_lasso
best_results <-
train_res |>
extract_workflow_set_result("base_lasso") |>
select_best(metric = "accuracy")
print(best_results)# A tibble: 1 × 2
penalty .config
<dbl> <chr>
1 1.16e-10 Preprocessor1_Model1lasso_res <- train_res |>
extract_workflow("base_lasso") |>
finalize_workflow(best_results) |>
last_fit(split = data_split, metrics = metric_set(f_meas, accuracy))
collect_metrics(lasso_res) |>
print()# A tibble: 2 × 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <chr>
1 f_meas macro 0.970 Preprocessor1_Model1
2 accuracy multiclass 0.980 Preprocessor1_Model1Confusion matrix. Модель демонстрирует высокую точность по большинству классов, что видно по хорошо выраженной диагонали
collect_predictions(lasso_res) |>
conf_mat(truth = author, estimate = .pred_class) |>
autoplot(type = "heatmap") +
scale_fill_gradient(low = "white", high = "#233857") +
theme(panel.grid.major = element_line(colour = "#233857"),
axis.text = element_text(color = "#233857"),
axis.title = element_text(color = "#233857"),
plot.title = element_text(color = "#233857"),
axis.text.x = element_text(angle = 90))
Наиболее важные признаки по авторам
lasso_fit <- extract_fit_parsnip(lasso_res$.workflow[[1]])
coefs <- tidy(lasso_fit)
coefs <- coefs |>
filter(term != "(Intercept)")
top_by_class <- coefs |>
group_by(class) |>
slice_max(order_by = abs(estimate), n = 10) |>
ungroup()
ggplot(top_by_class, aes(x = reorder(term, abs(estimate)), y = estimate, fill = class)) +
geom_col(show.legend = FALSE) +
coord_flip() +
facet_wrap(~ class, scales = "free_y") +
labs(x = "feature", y = "coefficient", title = "Top-10 most important features") +
theme_light()
У каждого автора выделяются уникальные устойчивые словоформы и конструкции, которые модель Lasso посчитала наилучшими для их различения.
- Austen отличается частотностью таких выражений, как any.thing, every.thing, don.t, very, soon, could
- CBronte, Eliot и EBronte практически не используют upon, в отличие от других авторов, например, Dickens, Richardson, Sterne.
- Dickens выделяется по обращениям (mr, my.dear), что может отражать диалоговый стиль
- Слово which, вводящее придаточное определительное, отличает Fielding, Sterne, Thackeray и является антипризнаком для ABronte и EBronte
- Союз and, а следовательно, и однородность больше характерна для ABronte и Thackeray, являясь при этом антипризнаком для Fielding и Trollope
- Союз but - один из наиболее значимых и частотных у ABronte, чуть меньшим весом обладает в авторском стиле Richardson
- Sterne характерен использованием конструкций типа my.uncle, my.father
Вывод
Модель Lasso позволила выделить интерпретируемые лексико-грамматические признаки, отражающие индивидуальные особенности авторского стиля. Визуализация наглядно демонстрирует, что у большинства авторов имеются устойчивые языковые маркеры — как положительные, так и отрицательные. Выбранные предикторы, частотность стоп-слов и n-грам, обеспечивают надёжную дифференциацию между авторами и высокую точность классификации.
Общие выводы
С использованием фреймворка tidymodels и лингвистических признаков двух типов, количественно-лингвистических и частотных n-грамм и стоп-слов, удалось построить интерпретируемые модели, довольно точно различающие уникальный стиль авторов классической британской прозы. Лучшие результаты показали Logistic Regression и Lasso, обеспечив точность выше 0.95, а визуальный анализ признаков подтвердил наличие чётких стилистических различий между авторами.