Стилометрический анализ корпуса британской прозы XVIII–XIX вв.

.quarto-title-block {
  background-image: linear-gradient(rgba(0,0,0,0.5), rgba(0,0,0,0.6)),
    url('https://images.unsplash.com/photo-1481627834876-b7833e8f5570?w=1400');
  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;
}

1 Подготовка библиотек

library(tidyverse)
library(stylo)
library(tidymodels)
library(tidytext)
library(ggrepel)
library(patchwork)
library(baguette)
library(discrim)
library(embed)
library(future)

2 Загруза корпуса

1. Читаем метаданные
2. Токенизируем корпус
3. Нарезаем на сэмплы

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 авторам: Jane Austen, Anne, Charlotte и Emily Brontë, Charles Dickens, George Eliot, Henry Fielding, Samuel Richardson, Laurence Sterne, William Thackeray и Anthony Trollope. Токенизация выполнена с помощью пакета stylo. Каждый текст разбит на сэмплы по 2000 слов — итого 3253 сэмпла.

3 Предварительная обработка сэмплов

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 наиболее частотных функциональных словах (местоимения, предлоги, союзы), которые в английском языке практически не изменяются по форме. Применение стемминга к таким словам может исказить результаты.

4 Извлечение признаков

# Матрица относительных частот 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

5 Разведывательный анализ

# Сколько сэмплов на автора
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()

Корпус несбалансирован: Richardson представлен 709 сэмплами (три объемных романа), тогда как Bronte_E — лишь 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

Авторы заметно различаются по структурным признакам. Richardson и Fielding используют более длинные слова — характерная черта прозы XVIII века с латинизированной лексикой. TTR выше у авторов с меньшим объемом текста (Bronte_E, Sterne), что ожидаемо: лексическое разнообразие снижается с ростом объема.

# Топ-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()

# 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_viridis_d() +
  labs(title = "PCA: первые две главные компоненты",
       color = NULL) +
  theme_light()

На плоскости первых двух главных компонент авторы образуют частично различимые кластеры. Richardson и Fielding отчетливо отделены от остальных — вероятно, в силу хронологической дистанции (XVIII век). Три Бронте перекрываются, что отражает близость их стилей.

# Объясненная дисперсия
tibble(
  pc    = 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()

6 Модель классификации в tidymodels

# Сплит и фолды
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")

rda_spec <- discrim_regularized(
  frac_common_cov = tune(),
  frac_identity   = tune()
) |>
  set_engine("klaR")

# Workflow set: 3 рецепта × 4 модели = 12 комбинаций
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)

# Финализация лучшей модели
best_results <- train_res |>
  rank_results(select_best = TRUE) |>
  filter(.metric == "accuracy") |>
  slice_head(n = 1)

best_wflow_id <- best_results$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))

# смотрим результаты
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

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))

collect_metrics(final_fit)

# A tibble: 2 × 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

# матрица ошибок
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. Единственная ошибка: один сэмпл Anne Bronte классифицирован как George Eliot, что объяснимо — обе авторки пишут в реалистической манере от первого лица. Снижение размерности (PCA, PLS) ухудшило результат, что типично для стилометрии: частоты функциональных слов уже являются информативными признаками и не нуждаются в дополнительном сжатии.

# важные признаки
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()

Warning: package 'glmnet' was built under R version 4.5.2

Attaching package: 'Matrix'

The following objects are masked from 'package:tidyr':

    expand, pack, unpack

Loaded glmnet 5.0

Анализ коэффициентов модели подтверждает, что классификация основана на реальных стилистических особенностях. У Richardson характерны архаичные формы (thou, harlowe, lovelace) и формульные обращения (dear, upon) — черты эпистолярного романа. Dickens выделяется нарративными маркерами (mr, returned, head). Austen — модальными и оценочными словами (every, very, could). Eliot — психологической лексикой (feeling, felt, maggie). Среди ограничений: в признаки попали артефакты очистки (s, ll) — остатки сокращений, а также структурные признаки ttr и n_unique, интерпретация которых для отдельных авторов неочевидна.