knitr::opts_chunk$set(
  echo = TRUE,
  message = FALSE,
  warning = FALSE,
  fig.width = 9,
  fig.height = 6
)

1 Задача

В работе используется корпус A Small Collection of British Fiction. Мне нужно подготовить тексты, описать их через количественные признаки и обучить модель, которая предсказывает автора фрагмента. Это многоклассовая классификация, потому что в корпусе больше двух авторов.

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

library(tidyverse)
library(textrecipes)
library(tidymodels)
library(tidytext)
library(stylo)
library(future)

2 Корпус и метаданные

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

books <- read_tsv(
  "../data/overview.tsv",
  col_names = c(
    "textID", "author", "authorID", "title",
    "first_published", "author_gender", "comment"
  ),
  skip = 1
)

books
## # A tibble: 27 × 7
##    textID author            authorID title first_published author_gender comment
##     <dbl> <chr>             <chr>    <chr>           <dbl>         <dbl> <chr>  
##  1      1 Austen, Jane      JA       Emma             1815             1 <NA>   
##  2      2 Austen, Jane      JA       Pride            1813             1 <NA>   
##  3      3 Austen, Jane      JA       Sense            1811             1 <NA>   
##  4      4 Bronte, Anne      AB       Agne…            1847             1 <NA>   
##  5      5 Bronte, Anne      AB       Tent…            1848             1 <NA>   
##  6      6 Bronte, Charlotte CB       Jane…            1847             1 <NA>   
##  7      7 Bronte, Charlotte CB       Prof…            1845             1 date o…
##  8      8 Bronte, Charlotte CB       Vill…            1853             1 <NA>   
##  9      9 Bronte, Emily     EB       Wuth…            1847             1 <NA>   
## 10     10 Dickens, Charles  CD       Blea…            1852             2 serial 
## # ℹ 17 more rows

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

books |>
  count(author, sort = TRUE)
## # A tibble: 11 × 2
##    author                           n
##    <chr>                        <int>
##  1 Austen, Jane                     3
##  2 Bronte, Charlotte                3
##  3 Dickens, Charles                 3
##  4 Eliot, George                    3
##  5 Thackeray, William Makepeace     3
##  6 Trollope, Antony                 3
##  7 Bronte, Anne                     2
##  8 Fielding, Henry                  2
##  9 Richardson, Samuel               2
## 10 Sterne, Laurence                 2
## 11 Bronte, Emily                    1
books |>
  count(author) |>
  ggplot(aes(n, reorder(author, n), fill = author)) +
  geom_col(show.legend = FALSE) +
  xlab("Number of novels") +
  ylab(NULL) +
  scale_fill_viridis_d(option = "C") +
  theme_light()

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

Посмотрим на годы первой публикации.

books |>
  ggplot(aes(first_published, author, color = author_gender)) +
  geom_point(size = 3, alpha = 0.8) +
  xlab("Year of first publication") +
  ylab(NULL) +
  labs(color = "Gender code") +
  theme_light()

Корпус соединяет тексты XVIII и XIX веков. Это нужно помнить при интерпретации: модель может ловить не только индивидуальный стиль, но и исторические различия между группами текстов.

3 Подготовка частотной таблицы

Загружаю тексты из папки с корпусом. Затем делю каждый текст на фрагменты по 3000 слов. Я беру фрагменты длиннее, чем в примере из урока, чтобы в каждом наблюдении было немного больше контекста.

novels <- load.corpus.and.parse(corpus.dir = "../data/british_fiction/british_fiction")

novel_parts <- make.samples(
  novels,
  sample.size = 3000,
  sampling = "normal.sampling",
  sample.overlap = 0,
  sampling.with.replacement = FALSE
)

В качестве признаков беру 400 самых частотных слов. Это не все слова корпуса, а компактный набор частотных признаков.

common_words <- make.frequency.list(novel_parts)[1:400]

freq_table <- stylo::make.table.of.frequencies(novel_parts, common_words) |>
  as.data.frame.matrix() |>
  rownames_to_column("id") |>
  as_tibble()

freq_table <- freq_table |>
  separate(id, into = c("author", "title", NA), sep = "_")

freq_table
## # A tibble: 2,164 × 402
##    author  title   the   and    to    of     i     a  `in`  that    he    it
##    <chr>   <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
##  1 ABronte Agnes  4.37  4.6   3.87  2.67  1.77  1.73  1.47 0.967 0.833 0.833
##  2 ABronte Agnes  4.5   4.13  3.4   1.93  3.53  2.4   1.2  0.767 0.267 0.967
##  3 ABronte Agnes  3.37  4.23  4     2.13  3.33  1.97  1.47 1.1   1.53  1.57 
##  4 ABronte Agnes  3.77  3.87  4.07  2.43  3.9   1.57  1.5  0.933 0.367 0.933
##  5 ABronte Agnes  4.47  4.17  2.8   2.5   3.03  1.97  1.87 1.1   0.767 1.03 
##  6 ABronte Agnes  2.87  3.67  3.53  2.2   3.47  1.4   1.3  1.07  0.933 1.07 
##  7 ABronte Agnes  4.43  4.57  3.1   3     2.87  2.97  1.6  0.933 0.233 0.767
##  8 ABronte Agnes  4.03  4.3   3.6   2.7   2.13  1.77  1.6  0.533 0.6   1.07 
##  9 ABronte Agnes  3.07  4     3.27  1.93  3.3   2.03  1.13 1.1   0.533 1.33 
## 10 ABronte Agnes  4.47  3.73  2.93  2.83  2.63  1.6   1.3  0.733 1.3   0.433
## # ℹ 2,154 more rows
## # ℹ 390 more variables: you <dbl>, was <dbl>, her <dbl>, his <dbl>, as <dbl>,
## #   my <dbl>, `for` <dbl>, not <dbl>, she <dbl>, with <dbl>, had <dbl>,
## #   be <dbl>, but <dbl>, have <dbl>, me <dbl>, is <dbl>, at <dbl>, s <dbl>,
## #   him <dbl>, so <dbl>, on <dbl>, said <dbl>, this <dbl>, which <dbl>,
## #   by <dbl>, all <dbl>, would <dbl>, mr <dbl>, `if` <dbl>, will <dbl>,
## #   from <dbl>, what <dbl>, your <dbl>, no <dbl>, or <dbl>, when <dbl>, …

4 Разведка данных

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

freq_table |>
  count(author) |>
  arrange(n)
## # A tibble: 11 × 2
##    author         n
##    <chr>      <int>
##  1 EBronte       39
##  2 Sterne        76
##  3 ABronte       79
##  4 Austen       133
##  5 CBronte      157
##  6 Fielding     162
##  7 Trollope     250
##  8 Eliot        252
##  9 Thackeray    267
## 10 Dickens      276
## 11 Richardson   473
freq_table |>
  count(author) |>
  ggplot(aes(reorder(author, n), n, fill = author)) +
  geom_col(show.legend = FALSE) +
  xlab(NULL) +
  ylab("Number of 3000-word parts") +
  scale_fill_viridis_d(option = "D") +
  coord_flip() +
  theme_light()

После нарезки самая большая группа остается у Ричардсона. Это связано с длиной его романов. Самая маленькая группа у Эмили Бронте, потому что в корпусе есть только Wuthering Heights.

Еще один простой способ посмотреть на данные - сравнить среднюю частотность частых слов по авторам. Здесь каждая точка - средняя частотность слова у автора.

freq_table |>
  select(-title) |>
  pivot_longer(-author, names_to = "word", values_to = "freq") |>
  group_by(author, word) |>
  summarise(mean_freq = mean(freq), .groups = "drop") |>
  group_by(author) |>
  slice_max(mean_freq, n = 15) |>
  ungroup() |>
  ggplot(aes(mean_freq, reorder(word, mean_freq), color = author)) +
  geom_point(alpha = 0.7) +
  facet_wrap(~ author, scales = "free_y") +
  xlab("Mean frequency") +
  ylab(NULL) +
  theme_light() +
  theme(legend.position = "none")

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

5 PCA

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

model_data <- freq_table |>
  select(-title) |>
  mutate(author = as.factor(author))

set.seed(31052026)

data_split <- initial_split(model_data, strata = author)

train_data <- training(data_split)
test_data <- testing(data_split)

set.seed(31052026)

folds <- vfold_cv(train_data, strata = author, v = 5)

Для PCA и моделей нужен общий рецепт: удаление признаков с нулевой дисперсией и нормализация числовых признаков.

words_rec <- recipe(author ~ ., data = train_data) |>
  step_zv(all_predictors()) |>
  step_normalize(all_predictors())

pca_view_rec <- words_rec |>
  step_pca(all_predictors(), num_comp = 6)

pca_view <- pca_view_rec |>
  prep(train_data)
pca_view |>
  juice() |>
  ggplot(aes(PC1, PC2, color = author)) +
  geom_point(alpha = 0.65) +
  theme_light()

pca_view |>
  juice() |>
  ggplot(aes(PC3, PC4, color = author)) +
  geom_point(alpha = 0.65) +
  theme_light()

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

6 Сравнение моделей

Я сравниваю три модели: ridge-регрессию, линейный SVM и KNN. Для каждой модели проверяются два варианта предобработки: исходные частотные признаки и PCA-признаки.

pca_rec <- words_rec |>
  step_pca(all_predictors(), num_comp = tune())

ridge_spec <- multinom_reg(penalty = tune(), mixture = 0) |>
  set_mode("classification") |>
  set_engine("glmnet")

svm_spec <- svm_linear(cost = tune()) |>
  set_mode("classification") |>
  set_engine("LiblineaR")

knn_spec <- nearest_neighbor(neighbors = tune()) |>
  set_mode("classification") |>
  set_engine("kknn")

models <- workflow_set(
  preproc = list(
    words = words_rec,
    pca = pca_rec
  ),
  models = list(
    ridge = ridge_spec,
    svm = svm_spec,
    knn = knn_spec
  ),
  cross = TRUE
)

models
## # A workflow set/tibble: 6 × 4
##   wflow_id    info             option    result    
##   <chr>       <list>           <list>    <list>    
## 1 words_ridge <tibble [1 × 4]> <opts[0]> <list [0]>
## 2 words_svm   <tibble [1 × 4]> <opts[0]> <list [0]>
## 3 words_knn   <tibble [1 × 4]> <opts[0]> <list [0]>
## 4 pca_ridge   <tibble [1 × 4]> <opts[0]> <list [0]>
## 5 pca_svm     <tibble [1 × 4]> <opts[0]> <list [0]>
## 6 pca_knn     <tibble [1 × 4]> <opts[0]> <list [0]>
plan(sequential)

set.seed(31052026)

model_res <- models |>
  workflow_map(
    verbose = TRUE,
    seed = 31052026,
    resamples = folds,
    grid = 4,
    metrics = metric_set(accuracy, f_meas),
    control = control_resamples(save_pred = TRUE)
  )
autoplot(model_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))

model_ranking <- rank_results(model_res, rank_metric = "accuracy", select_best = TRUE)

model_ranking |>
  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 words_ridge pre0_mod1_p… accura… 0.998 7.57e-4     5 recipe       mult…     1
##  2 words_ridge pre0_mod1_p… f_meas  0.997 1.52e-3     5 recipe       mult…     1
##  3 words_svm   pre0_mod1_p… accura… 0.996 6.14e-4     5 recipe       svm_…     2
##  4 words_svm   pre0_mod1_p… f_meas  0.995 1.28e-3     5 recipe       svm_…     2
##  5 words_knn   pre0_mod4_p… accura… 0.967 5.04e-3     5 recipe       near…     3
##  6 words_knn   pre0_mod4_p… f_meas  0.938 1.02e-2     5 recipe       near…     3
##  7 pca_knn     pre4_mod2_p… accura… 0.750 1.12e-2     5 recipe       near…     4
##  8 pca_knn     pre4_mod2_p… f_meas  0.666 1.85e-2     5 recipe       near…     4
##  9 pca_svm     pre4_mod2_p… accura… 0.740 7.38e-3     5 recipe       svm_…     5
## 10 pca_svm     pre4_mod2_p… f_meas  0.651 2.09e-3     5 recipe       svm_…     5
## 11 pca_ridge   pre4_mod2_p… accura… 0.715 9.53e-3     5 recipe       mult…     6
## 12 pca_ridge   pre4_mod2_p… f_meas  0.726 1.42e-2     5 recipe       mult…     6

По кросс-валидации можно выбрать модель с максимальной accuracy. Я не задаю ее вручную, а беру первый вариант из ранжирования.

best_row <- model_ranking |>
  filter(.metric == "accuracy") |>
  arrange(rank) |>
  slice(1)

best_id <- best_row |>
  pull(wflow_id)

best_id
## [1] "words_ridge"

7 Проверка на тестовой выборке

Финализирую выбранную модель и проверяю ее на тестовой выборке.

best_params <- model_res |>
  extract_workflow_set_result(best_id) |>
  select_best(metric = "accuracy")

final_res <- model_res |>
  extract_workflow(best_id) |>
  finalize_workflow(best_params) |>
  last_fit(
    split = data_split,
    metrics = metric_set(accuracy, f_meas, roc_auc)
  )

collect_metrics(final_res) |>
  print()
## # A tibble: 3 × 4
##   .metric  .estimator .estimate .config        
##   <chr>    <chr>          <dbl> <chr>          
## 1 accuracy multiclass     0.998 pre0_mod0_post0
## 2 f_meas   macro          0.996 pre0_mod0_post0
## 3 roc_auc  hand_till      1     pre0_mod0_post0
collect_predictions(final_res) |>
  conf_mat(truth = author, estimate = .pred_class) |>
  autoplot(type = "heatmap") +
  scale_fill_gradient(low = "white", high = "#315c72") +
  theme(
    axis.text.x = element_text(angle = 90),
    panel.grid.major = element_line(colour = "#315c72")
  )

Матрица ошибок нужна для проверки того, какие авторы чаще путаются между собой. Если большинство значений лежит на диагонали, модель работает хорошо.

collect_predictions(final_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.1, alpha = 0.75) +
  labs(color = NULL) +
  theme_light()

ROC-кривые дают еще один способ посмотреть на качество классификации. В хорошем случае кривые идут выше диагональной линии.

8 Интерпретация признаков

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

ridge_best <- model_res |>
  extract_workflow_set_result("words_ridge") |>
  select_best(metric = "accuracy")

ridge_fit <- model_res |>
  extract_workflow("words_ridge") |>
  finalize_workflow(ridge_best) |>
  fit(data = train_data)

ridge_terms <- ridge_fit |>
  extract_fit_parsnip() |>
  tidy() |>
  filter(term != "(Intercept)") |>
  group_by(class) |>
  slice_max(abs(estimate), n = 8) |>
  ungroup() |>
  mutate(term = fct_reorder(term, abs(estimate)))

ridge_terms |>
  print()
## # A tibble: 88 × 4
##    class   term    estimate  penalty
##    <chr>   <fct>      <dbl>    <dbl>
##  1 ABronte but       0.216  1.09e-10
##  2 ABronte and       0.132  1.09e-10
##  3 ABronte or        0.125  1.09e-10
##  4 ABronte too       0.118  1.09e-10
##  5 ABronte replied   0.103  1.09e-10
##  6 ABronte in       -0.0981 1.09e-10
##  7 ABronte which    -0.0944 1.09e-10
##  8 ABronte down     -0.0880 1.09e-10
##  9 Austen  every     0.155  1.09e-10
## 10 Austen  soon      0.142  1.09e-10
## # ℹ 78 more rows
ridge_terms |>
  ggplot(aes(estimate, term, fill = class)) +
  geom_col(show.legend = FALSE, alpha = 0.85) +
  facet_wrap(~ class, scales = "free_y") +
  xlab("Coefficient") +
  ylab(NULL) +
  scale_fill_brewer(palette = "Paired") +
  theme_minimal()

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

9 Выводы

В этой работе корпус был преобразован в набор фрагментов по 3000 слов. Для каждого фрагмента были посчитаны частоты 400 самых частотных слов. Такой набор признаков оказался достаточным для классификации авторов.

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

Сравнение моделей проводилось с помощью 5-фолдной кросс-валидации. Я сравнил ridge-регрессию, линейный SVM и KNN, а также проверил варианты с PCA. Лучший вариант был выбран по accuracy, а затем проверен на тестовой выборке.

Интерпретация коэффициентов ridge-регрессии показывает, что для различения авторов важны частотные слова. Это хорошо согласуется с идеей стилометрического анализа: авторский стиль проявляется не только в темах, но и в повторяющихся языковых привычках.