.quarto-title-block {
background-image: linear-gradient(rgba(0,0,0,0.5), rgba(0,0,0,0.6)),
url('library.jpg');
background-size: cover;
background-position: center top;
padding: 4rem 2rem 3rem;
margin-bottom: 2rem;
border-radius: 8px;
}
.quarto-title, .quarto-title h1 {
color: white !important;
}
.quarto-title-meta, .quarto-title-meta-contents p,
.subtitle {
color: #e0d8c8 !important;
}
body {
background-color: #faf8f3;
font-family: Georgia, serif;
}Построить модель многоклассовой классификации для атрибуции авторства в корпусе британской прозы конца XVIII–XIX веков. Корпус A Small Collection of British Fiction включает 27 произведений 11 авторов — от Генри Филдинга и Сэмюэля Ричардсона до Джейн Остен и Джорджа Элиота. В качестве признаков используются относительные частоты 500 наиболее употребительных слов (Most Frequent Words), а также дополнительные стилометрические характеристики: средняя длина слова, лексическое разнообразие и биграммы. Классификация выполнена с применением фреймворка {tidymodels} с кросс-валидацией и сравнением нескольких алгоритмов.
library(tidyverse)
library(stylo)
library(tidymodels)
library(patchwork)
library(future)overview <- read_tsv("overview.tsv",
col_names = c("textID", "author", "authorID",
"title", "first_publ", "gender", "comment"),
skip = 1)
# stylo токенизирует тексты
corpus <- load.corpus.and.parse(corpus.dir = "british_fiction")
# сэмплы по 2000 токенов
corpus_samples <- make.samples(corpus,
sample.size = 2000,
sampling = "normal.sampling",
sample.overlap = 0,
sampling.with.replacement = FALSE)В строке заголовка между полями textID и author вместо символа табуляции стоит пробел, из-за чего read_tsv() по умолчанию склеивает их в один столбец textID author. Проблема решена путем задания имен столбцов через аргумент col_names и пропуска исходной строки заголовка (skip = 1).
Корпус содержит 27 произведений (а не 28, как указано в задании) британской прозы конца XVIII–XIX веков, принадлежащих 11 авторам: Джейн Остен, Энн, Шарлотте и Эмили Бронте, Чарльзу Диккенсу, Джорджу Элиоту, Генри Филдингу, Сэмюэлю Ричардсону, Лоренсу Стерну, Уильяму Теккерею и Энтони Троллопу. Токенизация выполнена с помощью пакета stylo. Каждый текст разбит на сэмплы по 2000 слов — итого 3253 сэмпла.
corpus_samples_clean <- map(corpus_samples, function(tokens) {
tokens |>
str_to_lower() |>
# убираем сокращения до удаления пунктуации
str_remove_all("'s|'t|'ll|'ve|'d|'m|'re|n't") |>
# убираем все кроме букв
str_remove_all("[^a-z]") |>
# убираем пустые строки
(\(x) x[nchar(x) > 0])()
})Лемматизацию было решено не применять, поскольку анализ основан на 500 наиболее частотных функциональных словах (местоимения, предлоги, союзы), которые в английском языке практически не изменяются по форме. Применение стемминга к таким словам может исказить результаты.
# Матрица относительных частот 500 MFW
mfw <- make.frequency.list(corpus_samples_clean)[1:500]
corpus_tf <- stylo::make.table.of.frequencies(corpus_samples_clean, mfw) |>
as.data.frame.matrix() |>
rownames_to_column("id") |>
as_tibble()processing 3253 text samples.....................................................................................................................................................................................................................................................................................................................................
combining frequencies into a table...В качестве главного предиктора было решено использовать 500 MFW, так как именно служебные слова являются ядром стилометрического анализа. Именно они используются автором с устойчивой частотой и не зависят от тематики текста.
# Дополнительные стилометрические признаки
extra_features <- map_dfr(names(corpus_samples_clean), function(name) {
tokens <- corpus_samples_clean[[name]]
tokens <- tokens[nchar(tokens) > 0] # убираем пустые строки после чистки
tibble(
id = name,
mean_word_len = mean(nchar(tokens)),
ttr = length(unique(tokens)) / length(tokens),
n_unique = length(unique(tokens))
)
})В дополнение к частотам MFW для каждого сэмпла вычислены еще три структурных признака. Средняя длина слова (mean_word_len) демонстрирует, к каким словам по длине тяготеет автор. Type-Token Ratio (ttr) измеряет лексическое разнообразие как отношение числа уникальных слов к общему числу слов в сэмпле, то есть чем выше значение, тем богаче словарный запас в данном отрывке. Число уникальных слов (n_unique) дополняет TTR.
Следует отметить, что ttr и n_unique частично коррелируют между собой, а их значения зависят от длины сэмпла. Поскольку все сэмплы фиксированной длины (2000 слов), это ограничение несущественно в данном контексте.
# биграммы — топ-20 по корпусу
bigrams <- map_dfr(names(corpus_samples_clean), function(name) {
tokens <- corpus_samples_clean[[name]]
tokens <- tokens[nchar(tokens) > 0]
tibble(
id = name,
bigram = paste(tokens[-length(tokens)], tokens[-1])
)
})
top_bigrams <- bigrams |>
count(bigram, sort = TRUE) |>
slice_head(n = 20)
top_bigrams |>
ggplot(aes(reorder(bigram, n), n)) +
geom_col(fill = "#3B528BFF") +
coord_flip() +
labs(title = "Топ-20 биграмм в корпусе", x = NULL, y = "Частота") +
theme_light()
Топ-20 биграмм по всему корпусу ожидаемо состоит из функциональных конструкций: предложно-артиклевых сочетаний (of the, in the, to the), глагольных форм (to be, he had, he was) и местоименных конструкций (i have, i am, that i). Также высоки показатели биграмм i have и i am, что свидетельствует о частом использовании повествования от первого лица или дневниковой формы произведения.
Объединяем три новых признака и выносим автора.
# Объединяем три новых признака и выносим автора
corpus_features <- corpus_tf |>
left_join(extra_features, by = "id") |>
mutate(
author = str_extract(id, "^[^_]+") |>
fct_recode(
"Bronte_A" = "ABronte",
"Bronte_C" = "CBronte",
"Bronte_E" = "EBronte"
),
.before = 1
) |>
select(-id)
corpus_features |>
select(author, 2:8) |>
head(5)# A tibble: 5 × 8
author the and to of i a `in`
<fct> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 Bronte_A 5.4 4.85 3.55 3.1 1 1.4 1.5
2 Bronte_A 3.2 3.85 4.65 1.95 3.2 2.35 1.2
3 Bronte_A 4.7 4.4 2.7 1.85 3.75 2.45 1.3
4 Bronte_A 3.05 4.5 3.8 2 3.3 2.1 1.1
5 Bronte_A 4.15 4.1 4.8 2.35 3.55 1.5 2.35Посмотрим на превью финального датасета corpus_features. Каждая строка — один сэмпл из текстов Энн Бронте. Числа — относительные частоты слов на 100 токенов в данном сэмпле.
# Сколько сэмплов на автора
corpus_features |>
count(author) |>
ggplot(aes(reorder(author, n), n, fill = author)) +
geom_col(show.legend = FALSE) +
geom_text(aes(label = n), hjust = -0.2, size = 3) +
coord_flip() +
scale_fill_viridis_d() +
labs(title = "Число сэмплов по авторам", x = NULL, y = NULL) +
theme_light()
Корпус несбалансирован: Ричардсон представлен 709 сэмплами (три объемных романа), тогда как Энн Бронте — лишь 59 (одно произведение). Это потенциально влияет на качество классификации малых классов.
# Распределение стилометрических признаков по авторам
p1 <- corpus_features |>
ggplot(aes(author, mean_word_len, fill = author)) +
geom_boxplot(show.legend = FALSE, outlier.size = 0.8) +
scale_fill_viridis_d() +
labs(title = "Средняя длина слова", x = NULL, y = NULL) +
theme_light() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
p2 <- corpus_features |>
ggplot(aes(author, ttr, fill = author)) +
geom_boxplot(show.legend = FALSE, outlier.size = 0.8) +
scale_fill_viridis_d() +
labs(title = "Type-Token Ratio (лексическое разнообразие)", x = NULL, y = NULL) +
theme_light() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
p1 + p2
Боксплоты показывают распределение двух структурных признаков по авторам на основе 3253 сэмплов.
По средней длине слова заметно что Остен, Шарлотта Бронте и Филдинг тяготеют к более длинным словам, тогда как Ричардсон, Стерн и Троллоп — к более коротким.
TTR отражает лексическое разнообразие. Шарлотта и Эмили Бронте выделяются высоким TTR — их тексты лексически богаче на уровне 2000-словных сэмплов. Троллоп и Остен имеют низкий TTR, что типично для авторов с большим объёмом текстов: при многократном повторении одних и тех же слов разнообразие падает. Ричардсон с его огромными романами ожидаемо внизу по TTR.
Оба признака показывают различимость авторов, что подтверждает их роль как вспомогательных предикторов в модели.
# Топ-15 слов по среднечастотности — смотрим, нет ли имен героев в MFW
corpus_features |>
select(-author, -mean_word_len, -ttr, -n_unique) |>
summarise(across(everything(), mean)) |>
pivot_longer(everything(), names_to = "word", values_to = "freq") |>
slice_max(freq, n = 15) |>
ggplot(aes(reorder(word, freq), freq)) +
geom_col(fill = "#3B528BFF") +
coord_flip() +
labs(title = "Топ-15 слов по средней частоте в корпусе",
x = NULL, y = "Относительная частота") +
theme_light()
Видим, что в топ-15 вошла исключительно функциональная лексика: артикли (the, a), предлоги (of, to, in, as), союзы (and, that), местоимения (i, he, it, you, her, his). Имена персонажей не вошли.
# PCA для визуализации разделимости авторов
pca_res <- corpus_features |>
select(-author) |>
prcomp(scale. = TRUE)
pca_res$x |>
as_tibble() |>
bind_cols(author = corpus_features$author) |>
ggplot(aes(PC1, PC2, color = author)) +
geom_point(alpha = 0.5, size = 1.5) +
stat_ellipse(linewidth = 0.7) +
scale_color_manual(values = c(
"Bronte_A" = "#e6194b",
"Austen" = "#3cb44b",
"Bronte_C" = "#4363d8",
"Dickens" = "#f58231",
"Bronte_E" = "#911eb4",
"Eliot" = "#42d4f4",
"Fielding" = "#f032e6",
"Richardson" = "#bfef45",
"Sterne" = "#fabed4",
"Thackeray" = "#469990",
"Trollope" = "#dcbeff"
)) +
labs(title = "PCA: первые две главные компоненты",
color = NULL) +
theme_light()
Наиболее отчетливо выделяется Ричардсон — его облако смещено вправо по PC1 и практически не перекрывается с викторианскими авторами. Это отражает принципиальное стилистическое отличие эпистолярной прозы XVIII века от нарратива XIX века. Филдинг также несколько смещен относительно центра.
Большинство викторианских авторов сконцентрированы в центре и сильно перекрываются — особенно три сестры Бронте, Диккенс, Элиот и Троллоп. PCA подтверждает хронологическое расслоение корпуса, однако не является достаточным инструментом для разделения авторов внутри одного периода — гипотеза, которую проверим при сравнении моделей.
# Объясненная дисперсия
tibble(
pc = factor(paste0("PC", 1:10), levels = paste0("PC", 1:10)),
var = pca_res$sdev[1:10]^2
) |>
mutate(
pct = var / sum(pca_res$sdev^2) * 100,
cum_pct = cumsum(pct)
) |>
ggplot(aes(pc, pct)) +
geom_col(fill = "#3B528BFF") +
geom_line(aes(y = cum_pct, group = 1), color = "tomato", linewidth = 1) +
geom_point(aes(y = cum_pct), color = "tomato", size = 2) +
labs(title = "Scree plot: объясненная дисперсия по компонентам",
x = NULL, y = "%") +
theme_light()
Дисперсия распределена равномерно по многим компонентам, нет одного доминирующего направления. Это позволяет предположить, что снижение размерности до нескольких компонент может привести к потере значительной части информации.
Данные разбиваются на обучающую (75%) и тестовую (25%) выборки с стратификацией по автору, что гарантирует пропорциональное представление всех 11 классов в обеих частях. На обучающей выборке формируются 5 фолдов для кросс-валидации.
Для сравнения подготовлены три рецепта предобработки. Базовый рецепт (base_rec) удаляет признаки с нулевой дисперсией и нормализует все предикторы. Рецепт с PCA (pca_rec) дополнительно снижает размерность методом главных компонент — число компонент подбирается автоматически. Рецепт с PLS (pls_rec) снижает размерность с учетом целевой переменной.
Три алгоритма классификации: ridge-регрессия (L2-регуляризация, все признаки сохраняются с уменьшенными весами), lasso-регрессия (L1-регуляризация, часть признаков обнуляется) и линейный SVM. Каждый алгоритм комбинируется с каждым рецептом через workflow_set — итого 9 комбинаций, которые обучаются и оцениваются параллельно.
# Сплит и фолды
set.seed(31052025)
data_split <- corpus_features |>
initial_split(strata = author, prop = 0.75)
data_train <- training(data_split)
data_test <- testing(data_split)
set.seed(31052025)
folds <- vfold_cv(data_train, strata = author, v = 5)
# Рецепты предобработки
base_rec <- recipe(author ~ ., data = data_train) |>
step_zv(all_predictors()) |>
step_normalize(all_predictors())
pca_rec <- base_rec |>
step_pca(all_predictors(), num_comp = tune())
pls_rec <- base_rec |>
step_pls(all_numeric_predictors(), outcome = "author", num_comp = tune())
# Спецификации моделей
ridge_spec <- multinom_reg(penalty = tune(), mixture = 0) |>
set_mode("classification") |>
set_engine("glmnet")
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")
# Workflow set: 3 рецепта × 3 модели = 9 комбинаций
wflow_set <- workflow_set(
preproc = list(base = base_rec,
pca = pca_rec,
pls = pls_rec),
models = list(ridge = ridge_spec,
lasso = lasso_spec,
svm = svm_spec),
cross = TRUE
)# Обучение с кросс-валидацией
plan(multisession, workers = parallel::detectCores() - 1)
train_res <- wflow_set |>
workflow_map(
verbose = TRUE,
seed = 31052025,
resamples = folds,
grid = 5,
metrics = metric_set(accuracy, f_meas),
control = control_resamples(save_pred = TRUE)
)
plan(sequential)# смотрим результаты
autoplot(train_res, metric = "accuracy") + theme_light()
rank_results(train_res, select_best = TRUE) |>
filter(.metric == "accuracy") |>
print()# A tibble: 9 × 9
wflow_id .config .metric mean std_err n preprocessor model rank
<chr> <chr> <chr> <dbl> <dbl> <int> <chr> <chr> <int>
1 base_ridge pre0_mod1_pos… accura… 0.998 7.69e-4 5 recipe mult… 1
2 base_svm pre0_mod1_pos… accura… 0.995 5.02e-4 5 recipe svm_… 2
3 base_lasso pre0_mod1_pos… accura… 0.989 1.50e-3 5 recipe mult… 3
4 pls_lasso pre4_mod4_pos… accura… 0.851 1.05e-2 5 recipe mult… 4
5 pls_svm pre4_mod4_pos… accura… 0.829 1.02e-2 5 recipe svm_… 5
6 pls_ridge pre4_mod4_pos… accura… 0.791 1.19e-2 5 recipe mult… 6
7 pca_lasso pre4_mod4_pos… accura… 0.741 1.42e-2 5 recipe mult… 7
8 pca_svm pre4_mod4_pos… accura… 0.697 1.79e-2 5 recipe svm_… 8
9 pca_ridge pre4_mod4_pos… accura… 0.676 1.73e-2 5 recipe mult… 9График отображает все 9 комбинаций модель × рецепт, отсортированных по убыванию accuracy на кросс-валидации. Топ-3 занимают комбинации с базовым рецептом без снижения размерности: base_ridge (0.998), base_svm (0.995) и base_lasso (0.989). Модели с PLS дают 0.79–0.85, с PCA — 0.67–0.74. Таким образом, гипотеза о потере информации при снижении размерности подтвердилась.
# Финализация лучшей модели
best_wflow_id <- rank_results(train_res, select_best = TRUE) |>
filter(.metric == "accuracy") |>
slice_head(n = 1) |>
pull(wflow_id)
final_fit <- train_res |>
extract_workflow(best_wflow_id) |>
finalize_workflow(
train_res |>
extract_workflow_set_result(best_wflow_id) |>
select_best(metric = "accuracy")
) |>
last_fit(split = data_split,
metrics = metric_set(accuracy, f_meas, roc_auc))
collect_metrics(final_fit)# A tibble: 3 × 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <chr>
1 accuracy multiclass 0.999 pre0_mod0_post0
2 f_meas macro 0.997 pre0_mod0_post0
3 roc_auc hand_till 1.000 pre0_mod0_post0# матрица ошибок
collect_predictions(final_fit) |>
conf_mat(truth = author, estimate = .pred_class) |>
autoplot(type = "heatmap") +
scale_fill_gradient(low = "white", high = "#3B528BFF") +
theme(axis.text.x = element_text(angle = 90)) +
labs(title = "Матрица ошибок на тестовой выборке")Scale for fill is already present.
Adding another scale for fill, which will replace the existing scale.
Лучшей оказалась модель base_ridge — ridge-регрессия на полных 500 MFW без снижения размерности. Accuracy на тестовой выборке составила 0.999, F1-macro — 0.997, ROC-AUC — 1.000. Единственная ошибка: один сэмпл Энн Бронте классифицирован как Джордж Элиот, что объяснимо — обе авторки пишут в реалистической манере от первого лица.
collect_predictions(final_fit) |>
roc_curve(truth = author,
starts_with(".pred_"),
-`.pred_class`) |>
ggplot(aes(1 - specificity, sensitivity, color = .level)) +
geom_abline(slope = 1, color = "gray50", lty = 2, alpha = 0.8) +
geom_path(linewidth = 1.2, alpha = 0.7) +
labs(title = "ROC-кривые по авторам", color = NULL) +
theme_light()
ROC-кривые для всех 11 авторов проходят вблизи верхнего левого угла, что соответствует высокому качеству разделения классов. Площадь под кривой (AUC) близка к 1 для каждого автора.
# важные признаки
final_fit |>
extract_fit_parsnip() |>
tidy() |>
filter(term != "(Intercept)") |>
group_by(class) |>
slice_max(abs(estimate), n = 7) |>
ungroup() |>
mutate(term = fct_reorder(term, abs(estimate))) |>
ggplot(aes(estimate, term, fill = class)) +
geom_col(show.legend = FALSE, alpha = 0.85) +
facet_wrap(~ class, scales = "free_y") +
labs(title = "Наиболее важные признаки по авторам",
x = "Коэффициент", y = NULL) +
theme_minimal()
Анализ коэффициентов модели подтверждает, что классификация основана на реальных стилистических особенностях. У Ричардсона характерны архаичные местоимения (thou), имена персонажей (lovelace, harlowe) и типичная для писем лексика (dear, upon). Остен выделяется модальными и оценочными словами (every, very, could) — характерная черта ее косвенной речи и внутреннего монолога. Элиот идентифицируется по психологической лексике (feeling, felt) и именам персонажей (maggie, adam). У сестер Бронте модель опирается на имена персонажей (arthur, john) и глаголы диалога (replied, answered) — отражение их насыщенной диалогами прозы.
Среди ограничений: несмотря на предобработку, в признаковое пространство попали артефакты токенизации (s, ll, d) — вероятно, из-за нестандартных апострофов в исходных текстах. Структурные признаки ttr и n_unique оказались значимы для сестер Бронте, однако это может отражать особенности конкретных текстов, а не авторского стиля — особенно для Эмили Бронте, представленной единственным романом.
Результаты подтверждают, что авторский стиль британской прозы XVIII–XIX веков устойчиво кодируется в частотах функциональных слов — простые частотные признаки в сочетании с ridge-регрессией оказались достаточны для почти идеальной классификации по 11 авторам, что согласуется с классической стилометрической традицией.