Анализ британской прозы XVIII–XIX веков

Цель

На основе корпуса A Small Collection of British Fiction (28 произведений британской прозы конца XVIII — XIX веков) проанализировать стилистические особенности авторов и классифицировать тексты по авторам с применением фреймворка {tidymodels} в R.

Загрузка, токенизация и сегментация корпуса

Для стандартизации токенизации (очистка от пунктуации, приведение к нижнему регистру) используется движок пакета {stylo}. Длина исходных произведений сильно варьируется, что может смещать частотные оценки. Для стабилизации признакового пространства тексты нарезаются на неперекрывающиеся выборки (чанки) объемом по 2000 слов.

corpus_parsed <- stylo::load.corpus.and.parse(corpus.dir = corpus_path)

original_books <- names(corpus_parsed)

initial_books_table <- tibble(file_name = original_books) |> 
  separate_wider_delim(
    cols = file_name, 
    delim = "_", 
    names = c("author", "book_id"), 
    too_many = "drop"
  ) |> 
  # Группируем по автору и считаем только уникальные ID книг
  distinct(author, book_id) |> 
  count(author, name = "Количество произведений")

# Выводим красивую таблицу Quarto
knitr::kable(
  initial_books_table,
  col.names = c("Автор", "Количество исходных романов/текстов"),
  align = c("l", "c"),
  caption = "Количество исходных произведений авторов в корпусе (до сегментации)"
)

Количество исходных произведений авторов в корпусе (до сегментации)

Автор	Количество исходных романов/текстов
ABronte	2
Austen	3
CBronte	3
Dickens	3
EBronte	1
Eliot	3
Fielding	2
Richardson	2
Sterne	2
Thackeray	3
Trollope	3

Разденлим произведения на чанки по 2000 слов.

# Делим тексты на чанки по 2000 слов
corpus_samples <- stylo::make.samples(
  corpus_parsed, 
  sample.size = 2000, 
  sampling = "normal.sampling", 
  sample.overlap = 0, 
  sampling.with.replacement = FALSE
)

corpus_segmented <- names(corpus_samples) |> 
  map(\(sample_name) {
    metadata <- str_split_1(sample_name, "_")
    tibble(
      author = metadata[1],
      book_id = metadata[2],
      text = paste(corpus_samples[[sample_name]], collapse = " ")
    )
  }) |> 
  list_rbind() |> 
  mutate(author = as.factor(author))

# в таблицу
knitr::kable(
  as.data.frame(table(corpus_segmented$author)),
  col.names = c("Автор", "Количество сегментов (по 2000 слов)"),
  caption = "Распределение текстовых сегментов по авторам"
)

Распределение текстовых сегментов по авторам

Автор	Количество сегментов (по 2000 слов)
ABronte	118
Austen	201
CBronte	236
Dickens	414
EBronte	59
Eliot	379
Fielding	244
Richardson	709
Sterne	115
Thackeray	401
Trollope	377

Наименьшее количество текстов наблюдается у Эмили Бронте (EBronte).

Для валидации моделей применяется стратифицированное разделение выборки на обучающую и тестовую в соотношении 75/25. Дизайн признаков формируется на этапе создания рецепта {recipes}:

Вычисляется средняя длина слова в чанке avg_word_length.

Выделяется 1000 самых частотных слов корпуса (MFW).

Применяется step_zv() для фильтрации признаков с нулевой дисперсией.

Выполняется step_normalize() для корректной работы линейных алгоритмов.

# Выборки
data_split <- initial_split(corpus_segmented, prop = 0.75, strata = author)
train_data <- training(data_split)
test_data  <- testing(data_split)

# Количество чанков для каждого автора в обучающей и тестовой выборках
train_counts <- train_data |> 
  count(author, name = "Обучающая выборка 75%")

test_counts <- test_data |> 
  count(author, name = "Тестовая выборка 25%")

distribution_table <- train_counts |> 
  left_join(test_counts, by = "author") |> 
  mutate(Всего = `Обучающая выборка 75%` + `Тестовая выборка 25%`)

# в таблицу!
knitr::kable(
  distribution_table,
  col.names = c("Автор (Класс)", "Обучающая выборка 75%", "Тестовая выборка 25%", "Всего чанков"),
  align = c("l", "c", "c", "c"),
  caption = "Распределение текстовых сегментов по обучающей и тестовой выборкам после стратификации"
)

Распределение текстовых сегментов по обучающей и тестовой выборкам после стратификации

Автор (Класс)	Обучающая выборка 75%	Тестовая выборка 25%	Всего чанков
ABronte	93	25	118
Austen	150	51	201
CBronte	168	68	236
Dickens	310	104	414
EBronte	48	11	59
Eliot	288	91	379
Fielding	181	63	244
Richardson	530	179	709
Sterne	91	24	115
Thackeray	298	103	401
Trollope	281	96	377

# Создание фолдов для кроссвалидации
folds <- vfold_cv(train_data, v = 5, strata = author)

# Рецепт предобработки
stylo_recipe <- recipe(author ~ text, data = train_data) |> 
  step_mutate(
    char_count = nchar(as.character(text)),
    word_count = stringr::str_count(as.character(text), "\\w+"),
    avg_word_length = char_count / word_count
  ) |> 
  step_rm(char_count, word_count) |> 
  step_tokenize(text) |> 
  step_tokenfilter(text, max_tokens = 1000) |> 
  step_tf(text, weight_scheme = "raw count") |> 
  step_zv(all_numeric_predictors()) |> 
  step_normalize(all_numeric_predictors())

Разведывательный анализ данных (EDA)

Перед переходом к фазе предиктивного моделирования необходимо оценить внутреннюю структуру исследуемого корпуса, а также проверить репрезентативность выбранного признакового пространства. Базис признаков - 1000 самых частотных слов (Most Frequent Words — MFW), т.к. меньшие значения показали низкую эффективность в задаче классификации текстов особенно авторов с наименьшим количеством текстов.

Частотный профиль функциональных токенов

Посмотрим на топ-5 наиболее частотных слов для каждого автора.

prepped_train <- prep(stylo_recipe) |> bake(new_data = NULL)

prepped_train |> 
  pivot_longer(cols = starts_with("tf_"), names_to = "word", values_to = "freq") |> 
  mutate(word = str_remove(word, "tf_text_")) |> 
  group_by(author, word) |> 
  summarise(mean_freq = mean(freq), .groups = "drop") |> 
  group_by(author) |> 
  slice_max(mean_freq, n = 5) |> 
  ggplot(aes(x = reorder_within(word, mean_freq, author), y = mean_freq, fill = author)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~author, scales = "free_y", ncol = 3) +
  coord_flip() +
  scale_x_reordered() +
  labs(title = "Частотный профиль топ-5 функциональных слов по авторам", 
       x = "Слова", y = "Z-score частоты") +
  theme_minimal()

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

Снижение размерности: метод главных компонент (PCA) С помощью проекции 1000-мерного пространства MFW на двухмерную плоскость оценим разделимость стилей.

pca_recipe <- stylo_recipe |> step_pca(all_numeric_predictors(), num_comp = 2)
pca_data <- prep(pca_recipe) |> bake(new_data = NULL)

ggplot(pca_data, aes(x = PC1, y = PC2, color = author)) +
  geom_point(size = 2.5, alpha = 0.8) +
  labs(title = "Проекция PCA для текстовых сегментов корпуса (1000 MFW)", 
       x = "Первая главная компонента (PC1)", y = "Вторая главная компонента (PC2)") +
  theme_minimal() + 
  theme(legend.position = "right")

При значении 1000 MFW видно достаточно чёткое разделение на классы разных авторов.

Сильно выделяются тексты Ричардсона и Филдинга.

Оценка моделей на кросс-валидации

В качестве конкурирующих алгоритмов выбраны:

1. Мультиномиальная логистическая регрессия с регуляризацией Elastic Net (glmnet).
2. Гибкий дискриминантный анализ (FDA) на базе многомерных адаптивных сплайнов регрессии (earth).

# Спецификации моделей
# lr_spec <- multinom_reg(penalty = 0.05, mixture = 0.4) |>
#   set_engine("glmnet") |>
#   set_mode("classification")
# 
# fda_spec <- discrim_flexible(prod_degree = 1) |>
#   set_engine("earth") |>
#   set_mode("classification")
# 
# # Построение Workflow
# lr_wf  <- workflow() |> add_recipe(stylo_recipe) |> add_model(lr_spec)
# fda_wf <- workflow() |> add_recipe(stylo_recipe) |> add_model(fda_spec)
# 
# metrics_eval <- metric_set(accuracy, roc_auc)
# 
# # Кросс-валидация
# lr_res <- fit_resamples(lr_wf, resamples = folds, metrics = metrics_eval,
#                         control = control_resamples(save_pred = TRUE, pkgs = "stringr"))
# 
# fda_res <- fit_resamples(fda_wf, resamples = folds, metrics = metrics_eval,
#                          control = control_resamples(save_pred = TRUE, pkgs = "stringr"))

# ==============================================================================

# # Спецификация мультиномиальной логистической регрессии с оптимизированным штрафом
# lr_spec <- multinom_reg(penalty = 0.01, mixture = 0.5) |> 
#   set_engine("glmnet") |> 
#   set_mode("classification")
# 
# # Воркфлоу и кросс-валидация остаются прежними
# lr_wf  <- workflow() |> add_recipe(stylo_recipe) |> add_model(lr_spec)
# 
# # Для FDA (если вы ее оставляете для сравнения)
# fda_spec <- discrim_flexible(prod_degree = 1) |> 
#   set_engine("earth") |> 
#   set_mode("classification")
# fda_wf <- workflow() |> add_recipe(stylo_recipe) |> add_model(fda_spec)
# 
# metrics_eval <- metric_set(accuracy, roc_auc)
# 
# lr_res <- fit_resamples(lr_wf, resamples = folds, metrics = metrics_eval,
#                         control = control_resamples(save_pred = TRUE, pkgs = "stringr"))
# 
# fda_res <- fit_resamples(fda_wf, resamples = folds, metrics = metrics_eval,
#                          control = control_resamples(save_pred = TRUE, pkgs = "stringr"))
# 
# # Сбор метрик
# cv_metrics <- bind_rows(
#   collect_metrics(lr_res) |> mutate(model = "Glmnet Multinomial LR"),
#   collect_metrics(fda_res) |> mutate(model = "Flexible Discriminant Analysis")
# )
# 
# knitr::kable(cv_metrics, caption = "Таблица 2: Сравнительные метрики качества моделей на кросс-валидации")


# ==============================================================================

# Мультиномиальная логистическая регрессия
lr_spec <- multinom_reg(penalty = 0.01, mixture = 0.5) |> 
  set_engine("glmnet") |> 
  set_mode("classification")

# Метод опорных векторов Linear SVM
svm_spec <- svm_linear() |> 
  set_engine("kernlab") |> 
  set_mode("classification")

# Метод ближайших соседей 
knn_spec <- nearest_neighbor(neighbors = 3, dist_power = 1) |> 
  set_engine("kknn") |> 
  set_mode("classification")

# модель FDA
fda_spec <- discrim_flexible(prod_degree = 1) |> 
  set_engine("earth") |> 
  set_mode("classification")

# workflow для всех 4 моделей
lr_wf  <- workflow() |> add_recipe(stylo_recipe) |> add_model(lr_spec)
svm_wf <- workflow() |> add_recipe(stylo_recipe) |> add_model(svm_spec)
knn_wf <- workflow() |> add_recipe(stylo_recipe) |> add_model(knn_spec)
fda_wf <- workflow() |> add_recipe(stylo_recipe) |> add_model(fda_spec)

metrics_eval <- metric_set(accuracy, roc_auc)

# Запуск кросс-валидации для всех участников
lr_res  <- fit_resamples(lr_wf,  resamples = folds, metrics = metrics_eval,
                         control = control_resamples(save_pred = TRUE, pkgs = "stringr"))

svm_res <- fit_resamples(svm_wf, resamples = folds, metrics = metrics_eval,
                         control = control_resamples(save_pred = TRUE, pkgs = "stringr"))

knn_res <- fit_resamples(knn_wf, resamples = folds, metrics = metrics_eval,
                         control = control_resamples(save_pred = TRUE, pkgs = "stringr"))

fda_res <- fit_resamples(fda_wf, resamples = folds, metrics = metrics_eval,
                         control = control_resamples(save_pred = TRUE, pkgs = "stringr"))

# Сводный сбор метрик в единую таблицу
cv_metrics <- bind_rows(
  collect_metrics(lr_res)  |> mutate(model = "Glmnet Multinomial LR"),
  collect_metrics(svm_res) |> mutate(model = "Linear SVM"),
  collect_metrics(knn_res) |> mutate(model = "Delta-equivalent KNN"),
  collect_metrics(fda_res) |> mutate(model = "Flexible Discriminant Analysis (FDA)")
)

# Вывод сравнительной таблицы
knitr::kable(
  cv_metrics |> filter(.metric == "accuracy" | .metric == "roc_auc") |> 
    select(model, .metric, mean, std_err) |> 
    arrange(desc(.metric), desc(mean)), 
  caption = "Сравнительные метрики качества моделей на кросс-валидации"
)

Сравнительные метрики качества моделей на кросс-валидации

model	.metric	mean	std_err
Glmnet Multinomial LR	roc_auc	0.9995942	0.0001177
Delta-equivalent KNN	roc_auc	0.9942169	0.0022714
Flexible Discriminant Analysis (FDA)	roc_auc	0.9570320	0.0025218
Linear SVM	roc_auc	0.8618117	0.0054198
Linear SVM	accuracy	0.9983615	0.0007655
Glmnet Multinomial LR	accuracy	0.9815531	0.0028084
Delta-equivalent KNN	accuracy	0.9589936	0.0061357
Flexible Discriminant Analysis (FDA)	accuracy	0.6976990	0.0083743

1. Linear SVM Лучшая по accuracy 0.998, однако хуже остальных моделей по метрике ROC AUC 0.861.
2. Glmnet Multinomial LR даёт accuracy 0.981 и ROC AUC 0.999.
3. Delta-equivalent KNN даёт accuracy 0.959 и ROC AUC 0.994.
4. Flexible Discriminant Analysis (FDA) даёт худшую accuracy 0.697 и ROC AUC 0.957.

На несбалансированном корпусе Glmnet Multinomial LR показывает наиболее стабильный результат.

Валидация на тестовом множестве и визуализация

Выполним финальное обучение (фит) выбранной модели на всем обучающем пуле данных и протестируем её на отложенной выборке.

# best_wf <- lr_wf
# final_fit <- last_fit(best_wf, split = data_split, metrics = metrics_eval)
# predictions <- collect_predictions(final_fit)
# 
# knitr::kable(collect_metrics(final_fit), caption = "Финальные метрики эффективности на тестовой выборке")

best_wf <- lr_wf
final_fit <- last_fit(best_wf, split = data_split, metrics = metrics_eval)
predictions <- collect_predictions(final_fit)

knitr::kable(
  collect_metrics(final_fit), 
  caption = "Финальные метрики эффективности Glmnet LR на тестовой выборке"
)

Финальные метрики эффективности Glmnet LR на тестовой выборке

.metric	.estimator	.estimate	.config
accuracy	multiclass	0.9901840	pre0_mod0_post0
roc_auc	hand_till	0.9999137	pre0_mod0_post0

Матрица ошибок (Confusion Matrix) Хитмап позволяет локализовать ошибки классификатора и понять, какие именно авторские стили модель склонна путать.

# predictions |> 
#   conf_mat(truth = author, estimate = .pred_class) |> 
#   autoplot(type = "heatmap") +
#   scale_fill_gradient(low = "white", high = "darkcyan") +
#   labs(title = "Тепловая матрица ошибок финальной модели") +
#   theme_light()

predictions |> 
  conf_mat(truth = author, estimate = .pred_class) |> 
  autoplot(type = "heatmap") +
  scale_fill_gradient(low = "white", high = "darkcyan") +
  labs(
    title = "Тепловая матрица ошибок финальной модели (Glmnet LR)",
    x = "Истинный автор",
    y = "Предсказанный автор"
  ) +
  theme_light() +
  theme(axis.text.x = element_text(angle = 45, vjust = 1, hjust = 1))

Тестирование финальной модели на независимой выборке показало отличный результат: accuracy = 99.01% и ROC AUC = 99.99%. Из 304 тестовых текстовых сегментов модель допустила всего 3 ошибки на весь корпус.

Благодаря расширению признакового пространства до 1000 MFW стало решение проблемы классификации Эмили Бронте (EBronte). Если на 100 MFW модель демонстрировала нулевую чувствительность к автору, путая её с другими, то теперь точность распознавания Эмили Бронте составила 11 из 11 сегментов.

Мультиклассовые ROC-кривые Построим ансамбль ROC-кривых для каждого конкретного писателя.

predictions |> 
  roc_curve(truth = author, starts_with(".pred_"), -.pred_class) |> 
  autoplot() +
  labs(title = "ROC-кривые идентификации авторов") +
  theme_minimal()

График мультиклассовых ROC-кривых (построенных по принципу «один против всех») наглядно иллюстрирует идеальную предсказательную силу модели. Все 11 кривых, соответствующих 11 авторам корпуса, сливаются в левом верхнем углу, стремясь к идеальной координате (0, 1). Значение метрики AUC = 0.9999 подтверждает отличное распределение вероятностей, рассчитываемое мультиномиальной моделью для разделения классов.

Интерпретация модели

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

fitted_model <- extract_fit_parsnip(final_fit$.workflow[[1]])
model_coefficients <- tidy(fitted_model)

model_coefficients |> 
  filter(term != "(Intercept)", estimate != 0) |> 
  mutate(term = str_remove(term, "tf_text_")) |> 
  group_by(class) |> 
  slice_max(order_by = abs(estimate), n = 5) |> 
  ungroup() |> 
  ggplot(aes(x = reorder_within(term, estimate, class), y = estimate, fill = estimate > 0)) +
  geom_col(alpha = 0.85) +
  scale_x_reordered() +
  facet_wrap(~class, scales = "free", ncol = 3) +
  coord_flip() +
  labs(title = "Наиболее важные признаки для каждого автора", 
       x = "Признак", 
       y = "Коэффициент") +
  scale_fill_manual(values = c("firebrick", "forestgreen"),
                    name = "Эффект влияния") +
  theme_bw() +
  theme(legend.position = "bottom", axis.text.y = element_text(size = 9))

plan(sequential)

Результаты

На основе комплексного стилометрического исследования корпуса британской художественной прозы XVIII–XIX веков с применением современного дата-фреймворка {tidymodels} было обучено несколько моделей для классификации авторов на независимом тестовом множестве (Linear SVM, FDA, KNN, Glmnet) и выбрана с самой высокой точностью.