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

Цель

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

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

Для стандартизации токенизации используется пакет {stylo}.

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"
  ) |> 
  distinct(author, book_id) |> 
  count(author, name = "Количество произведений")

# в таблиц
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)

Посмотрим внутреннюю структуру исследуемого корпуса.

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

Посмотрим на топ-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 = "частоты") +
  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. Многоклассовая логистическая регрессия
2. Метод опорных векторов (SVM)
3. K-Nearest Neighbors
4. Flexible Discriminant Analysis (FDA)

# Многоклассовая логистическая регрессия
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"),
  collect_metrics(svm_res) |> 
    mutate(model = "Linear SVM"),
  collect_metrics(knn_res) |> 
    mutate(model = "KNN"),
  collect_metrics(fda_res) |> 
    mutate(model = "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	roc_auc	0.9995942	0.0001177
KNN	roc_auc	0.9942169	0.0022714
FDA	roc_auc	0.9570320	0.0025218
Linear SVM	roc_auc	0.8618117	0.0054198
Linear SVM	accuracy	0.9983615	0.0007655
Glmnet	accuracy	0.9815531	0.0028084
KNN	accuracy	0.9589936	0.0061357
FDA	accuracy	0.6976990	0.0083743

1. Linear SVM Лучшая по accuracy 0.998, однако хуже остальных моделей по метрике ROC AUC 0.861.
2. Glmnet даёт 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 = "Финальные метрики эффективности Glmnet на тестовой выборке"
)

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

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

Матрица ошибок

Посмотрим, какие именно авторские стили модель склонна путать.

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

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

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

Мультиклассовые ROC-кривые

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

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

ROC-кривые иллюстрируют хорошую предсказательную силу модели. Все 11 кривых сливаются в левом верхнем углу.

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

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

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"),
                    labels = c("отрицательное","положительное"),
                    name = "Влияние признака") +
  theme_bw() +
  theme(legend.position = "bottom", axis.text.y = element_text(size = 9))

plan(sequential)

Ожидаемо для Остин можем увидеть среди выделенных слов elisabeth, emma, elinor.

Результаты

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