Purtroppo-British-fiction.R

library(tidyverse)
library(tidymodels)
library(textrecipes)
library(tidytext)
library(stylo)
library(embed)
library(baguette)
library(discrim)
library(ggrepel)
library(learntidymodels)

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)
#perform.culling(culling.level = 20) #почитать про аргумент и подумать добавлять или нет

##приводим к нижнему регистру, убираем ’s

corpus_clean <- map(corpus_samples, function(text) {
  str_to_lower(str_remove_all(text, "[''`]s\\b"))
})

#подумать сотавлять или нет нижний регистр, убирать ли имена потому что имена по идее убирает perform.culling

# 27.2 подготовка датасета

##500 самых частотных слов

mfw <- make.frequency.list(corpus_clean)[1:500]

# частотная матрица
corpus_tf <- stylo::make.table.of.frequencies(corpus_clean, mfw) |>
  as.data.frame.matrix() |>
  rownames_to_column("id") |>
  as_tibble()

# разбираем id вида Author_Book_sampleN на части
corpus_tf <- corpus_tf |>
  separate(id, into = c("author", "book", "sample"), sep = "_",
           extra = "merge", fill = "right", remove = FALSE)

corpus_tf |> 
  select(id, author, book, sample) |>
  head()

## # A tibble: 6 × 4
##   id              author  book  sample
##   <chr>           <chr>   <chr> <chr> 
## 1 ABronte_Agnes_1 ABronte Agnes 1     
## 2 ABronte_Agnes_2 ABronte Agnes 2     
## 3 ABronte_Agnes_3 ABronte Agnes 3     
## 4 ABronte_Agnes_4 ABronte Agnes 4     
## 5 ABronte_Agnes_5 ABronte Agnes 5     
## 6 ABronte_Agnes_6 ABronte Agnes 6

#Особенности корпуса: сколько отрывков на каждого автора. На графике отражен сильный дисбаланс: 
#Richardson представлен  700 сэмплами, а EBronte ттолько 60 — это её единственный роман
# «Грозовой перевал». Из-за дисбаланса модели обучаются на
# немногих фрагментах, поэтому выборки разбиваются со стратификацией по автору, 
# а качество оценивается в том числе по f-мере, устойчивой к неравному числу классов. 
corpus_tf |> 
  count(author) |> 
  ggplot(aes(reorder(author, n), n, fill = author)) +
  geom_col(show.legend = FALSE) +
  xlab(NULL) +
  ylab(NULL) +
  scale_fill_viridis_d() + 
  theme_light() +
  coord_flip()

#Удаляем авторов, у которых не так много отрывков.
corpus_top <- corpus_tf |>
  add_count(author) |>
  filter(n > 100) |>
  select(-n, -id, -book, -sample) |>
  mutate(author = as.factor(author))

#Визуализиуем
corpus_top |> 
  count(author) |> 
  ggplot(aes(reorder(author, n), n, fill = author)) +
  geom_col(show.legend = FALSE) +
  xlab(NULL) +
  ylab(NULL) +
  scale_fill_viridis_d() + 
  theme_light() +
  coord_flip()

#обучающая и тестовые выборки 

set.seed(30052026)
data_split <- corpus_top |>
  initial_split(strata = author)

data_train <- training(data_split)
data_test  <- testing(data_split)

# folds
set.seed(30052026)
folds <- vfold_cv(data_train, strata = author, v = 5)
folds

## #  5-fold cross-validation using stratification 
## # A tibble: 5 × 2
##   splits             id   
##   <list>             <chr>
## 1 <split [1912/481]> Fold1
## 2 <split [1914/479]> Fold2
## 3 <split [1915/478]> Fold3
## 4 <split [1915/478]> Fold4
## 5 <split [1916/477]> Fold5

#при prep и bake подумать над количеством компонент (зависит от количества авторов в корпусе) num_comp =7 /8/10

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

#рецепт, в котором используем главные компоненты в качестве предикторов
pca_rec <- base_rec |> 
  step_pca(all_predictors(), num_comp = 11)
pca_rec


base_trained <- base_rec |>
  prep(data_train) 
base_trained

base_trained |> 
  bake(new_data = NULL)

## # A tibble: 2,393 × 500
##        the     and      to       of       i      a    `in`    that      he
##      <dbl>   <dbl>   <dbl>    <dbl>   <dbl>  <dbl>   <dbl>   <dbl>   <dbl>
##  1  0.0968  2.03   -0.154   0.807   -0.0322  1.01  -0.0774 -1.61   -1.24  
##  2 -1.33   -0.143   0.761  -2.22     2.33   -0.635 -2.27   -0.693   1.48  
##  3 -0.975  -0.0153  0.339  -0.745    0.0406 -0.828 -0.335  -0.287   0.551 
##  4 -0.499   1.84    0.550  -0.0801   0.877   0.620 -1.11    0.119  -1.51  
##  5 -0.0620  0.561  -0.0132  0.142    2.01   -0.152 -2.01   -0.896   1.21  
##  6  1.37    3.50   -1.21    0.216   -0.796   1.78  -0.851  -1.61   -0.910 
##  7  0.256   1.01    2.17   -0.302    0.332  -0.828 -1.11    0.423  -0.578 
##  8 -0.975   0.625  -0.576  -1.26     1.46   -0.924 -0.980  -0.592  -0.246 
##  9 -0.657   0.497  -0.0836 -1.26     1.86   -1.70  -0.464  -0.693  -1.44  
## 10 -0.896   1.52    0.339  -0.00618  0.695  -1.21  -0.722  -0.0843 -0.0472
## # ℹ 2,383 more rows
## # ℹ 491 more variables: it <dbl>, 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>, mr <dbl>, would <dbl>, `if` <dbl>,
## #   from <dbl>, will <dbl>, what <dbl>, your <dbl>, no <dbl>, or <dbl>, …

#методы снижения размерности
pca_trained <- pca_rec |>
  prep(data_train)

pca_trained |>
  juice()

## # A tibble: 2,393 × 12
##    author    PC01   PC02   PC03   PC04   PC05  PC06   PC07    PC08   PC09   PC10
##    <fct>    <dbl>  <dbl>  <dbl>  <dbl>  <dbl> <dbl>  <dbl>   <dbl>  <dbl>  <dbl>
##  1 ABron… -0.589   2.64   0.824 -4.58   0.215  1.68 -3.27   0.748   1.28  -1.28 
##  2 ABron… -0.131  -8.21  -1.54   1.76   1.56   1.63 -1.41  -4.37    1.63  -1.84 
##  3 ABron…  0.499  -1.29   3.34  -2.04  -1.31   2.26 -2.80  -0.123   2.40  -1.19 
##  4 ABron… -0.0798 -0.246 -0.665 -2.52  -3.29   3.39 -2.45   0.856   0.632 -1.52 
##  5 ABron… -1.54   -4.47   1.27  -1.28  -1.67   2.55  2.08  -0.729   2.94  -1.44 
##  6 ABron… -5.44    5.43  -3.54  -2.82   1.71   1.11 -0.915  2.08    1.27  -3.79 
##  7 ABron…  4.04   -1.13   0.813  1.20   2.90   2.12 -1.20   0.605   0.933 -0.974
##  8 ABron…  0.634  -7.52  -0.844 -0.482 -0.850  1.95  1.18   1.59   -2.49  -1.09 
##  9 ABron… -0.0939 -6.90  -2.15  -7.67   0.208  1.26  3.16   1.91   -0.765 -2.69 
## 10 ABron…  2.52   -1.71   1.80  -1.14  -0.112  3.17  0.132 -0.0150  0.773 -3.26 
## # ℹ 2,383 more rows
## # ℹ 1 more variable: PC11 <dbl>

pca_trained |> juice() |> names()

##  [1] "author" "PC01"   "PC02"   "PC03"   "PC04"   "PC05"   "PC06"   "PC07"  
##  [9] "PC08"   "PC09"   "PC10"   "PC11"

#визуализация
pca_trained |>
  juice() |>
  ggplot(aes(PC01, PC02, color = author)) +
  geom_point(alpha = 0.7, size = 2) +
  scale_color_brewer(palette = "Paired") +   
  theme_light()

#Вывод. 
pca_trained |>
  juice() |>
  group_by(author) |>
  summarise(PC01 = mean(PC01)) |>
  arrange(PC01)

## # A tibble: 10 × 2
##    author       PC01
##    <fct>       <dbl>
##  1 Thackeray  -4.76 
##  2 Eliot      -3.85 
##  3 Dickens    -3.28 
##  4 CBronte    -2.88 
##  5 Trollope   -1.21 
##  6 Sterne     -0.145
##  7 ABronte     0.269
##  8 Fielding    1.59 
##  9 Austen      1.59 
## 10 Richardson  7.26

#нагрузки компонент
pca_trained |> 
  plot_top_loadings(component_number <= 4, n = 10) +
  scale_fill_brewer(palette = "Paired") +
  theme_light()

# ### Нагрузки компонент
#

График показывает, какие слова больше всего «весят» в каждой главной компоненте. К сожалению, на графики попал и мусор, но это не мешает увидеть, что во всех четырёх компонентах доминируют служебные слова, а не имена или сюжетная лексика — в какой-то степени это подтверждает, что снижение размерности здесь опирается именно на стилистическую компоненту.

#

PC1 нагружают модальные и вспомогательные глаголы (will, have, be, may, cannot) и местоимение your — это лексика инструкции, обещания, прямого обращения, характерная для эпистолярной прозы; именно она и выделяет Ричардсона — мастера скорее эпистолярного жанра. PC2 строится на of, which, the, you, said, know, do — оппозиция «книжной» синтаксической связности (of, which, the) и устной диалоговой речи (you, said, know). PC3 (that, been, had, course, certainly, himself, would) и PC4 (seemed, could, she, who, her, felt) разграничивают повествовательное время и фокус: PC4 с её she/her/felt тяготеет, возможно, к женским образам и внутренней жизни персонажей. Как когда-то в куртуазном романе для dame стало больше места, чем в эпосе (“Песнь о Роланде”, в которой невесте Роланда Альде посвящены два стиха), так и в романах Ричардсона для женщины расширяется пространство - почти впервые в английской традиции.

# install.packages("BiocManager")
# BiocManager::install("mixOmics")
pls_trained <- base_trained |> 
  step_pls(all_numeric_predictors(), outcome = "author", num_comp = 11) |> 
  prep() 

pls_trained |> 
  juice()

## # A tibble: 2,393 × 12
##    author       PLS01  PLS02   PLS03  PLS04  PLS05   PLS06  PLS07  PLS08  PLS09
##    <fct>        <dbl>  <dbl>   <dbl>  <dbl>  <dbl>   <dbl>  <dbl>  <dbl>  <dbl>
##  1 ABronte  0.255      0.585 -0.320  -3.74  -1.88  -2.07    3.23  0.830   0.442
##  2 ABronte  0.570      2.52  -5.13    0.134  1.46  -0.0164  0.786 0.0879 -6.46 
##  3 ABronte -0.0750     3.79  -0.0875 -1.92  -3.46  -1.28    2.39  0.103  -3.16 
##  4 ABronte -0.0000960 -0.263 -0.858  -2.58  -3.85  -2.21    2.38  0.316  -4.08 
##  5 ABronte  1.99       2.76  -2.17   -1.91  -2.42   2.28    1.16  0.722  -4.73 
##  6 ABronte  4.21      -4.98   0.0952 -3.13  -0.582 -0.628   3.75  3.63   -0.527
##  7 ABronte -3.20       1.56  -0.945  -0.986  1.12  -0.369   1.06  0.111  -4.21 
##  8 ABronte  0.0787     2.23  -4.98   -0.644 -2.15   0.284  -1.45  1.98   -4.51 
##  9 ABronte  0.244      1.96  -6.37   -4.69  -2.97   2.38    1.89  3.59   -4.49 
## 10 ABronte -1.69       2.14  -0.318  -2.24  -1.32  -0.145   0.204 1.27   -3.73 
## # ℹ 2,383 more rows
## # ℹ 2 more variables: PLS10 <dbl>, PLS11 <dbl>

#визуализация
pls_trained |> 
  juice() |> 
  ggplot(aes(PLS01, PLS02, color = author)) +
  geom_point() +
  theme_light()

Снижение размерности: PLS

PLS, в отличие от PCA, — метод обучения с учителем: при построении компонент он использует метки авторов и ищет направления, которые именно РАЗДЕЛЯЮТ классы, насколько понимаю, а не просто описывают общую дисперсию. Результат нагляднее PCA: авторы образуют более различимые зоны (хотя это все еще не самый лучший резульат, очевидно). Ричардсон (голубой) уходит плотным облаком влево, снова обособляясь сильнее всех — его эпистолярный стиль выделяется при любом методе. Троллоп (вверху) и Теккерей (внизу справа) занимают противоположные концы по PLS02. Дж.Остин (оранжевый) собирается отдельным сгустком вверху-слева. Показательно положение Филдинга (бирюзовый): он лежит в переходной зоне между Ричардсоном и викторианцами — оба автора относятся к XVIII веку, и PLS, возможно, улавливает эту хронологическую близость.

“Перекрытие” сохраняется в правом центре, где сходятся викторианские романисты (Диккенс, Элио, сёстры Бронте) — их стили наиболее близки. Но в целом границы между авторами здесь видны куда лучше, чем в PCA.

#нагрузки компонент
pls_trained |> 
  plot_top_loadings(component_number <= 4, n = 10, type = "pls") +
  scale_fill_brewer(palette = "Paired") +
  theme_light()

library(embed)
base_trained |> 
  step_umap(all_numeric_predictors(), outcome = "author", num_comp = 4) |> 
  prep() |> 
  juice() |> 
  ggplot(aes(UMAP1, UMAP2, color = author)) +
  geom_point(alpha = 0.5) +
  theme_light()

UMAP разделяет лучше всех.

pls_rec <- base_rec |> 
  step_pls(all_numeric_predictors(), outcome = "author", num_comp = tune())

umap_rec <- base_rec |> 
  step_umap(all_numeric_predictors(),
            outcome = "author",
            num_comp = tune(),
            neighbors = tune(),
            min_dist = tune())

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

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

## Linear Support Vector Machine Model Specification (classification)
## 
## Main Arguments:
##   cost = tune()
## 
## Computational engine: LiblineaR

mlp_spec <- mlp(hidden_units = tune(),
                penalty = tune(),
                epochs = tune()) |> 
  set_engine("nnet") |> 
  set_mode("classification")

bagging_spec <- bag_tree() |> 
  set_engine("rpart") |> 
  set_mode("classification")

fda_spec <- discrim_flexible(prod_degree = tune()) |> 
  set_engine("earth")

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

# devtools::install_github("KlausVigo/kknn")

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

library(baguette) # для бэггинга
library(discrim) # для fda_spec и rda_spec

wflow_set <- workflow_set(
  preproc = list(base = base_rec, pca = pca_rec),
  models  = list(ridge = ridge_spec, lasso = lasso_spec, svm = svm_spec),
  cross = TRUE
)
wflow_set

## # A workflow set/tibble: 6 × 4
##   wflow_id   info             option    result    
##   <chr>      <list>           <list>    <list>    
## 1 base_ridge <tibble [1 × 4]> <opts[0]> <list [0]>
## 2 base_lasso <tibble [1 × 4]> <opts[0]> <list [0]>
## 3 base_svm   <tibble [1 × 4]> <opts[0]> <list [0]>
## 4 pca_ridge  <tibble [1 × 4]> <opts[0]> <list [0]>
## 5 pca_lasso  <tibble [1 × 4]> <opts[0]> <list [0]>
## 6 pca_svm    <tibble [1 × 4]> <opts[0]> <list [0]>

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

library(future)
plan(multisession, workers = 6)

plan(sequential)

train_res <- wflow_set |>
  workflow_map(
    verbose = TRUE,
    seed = 180525,
    resamples = folds,
    grid = 3,
    metrics = metric_set(f_meas, accuracy),
    control = control_resamples(save_pred = TRUE)
  )

plan(sequential)

autoplot(train_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))

rank_results(train_res, select_best = TRUE) |> 
  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 base_ridge pre0_mod1_po… accura… 0.998 6.63e-4     5 recipe       mult…     1
##  2 base_ridge pre0_mod1_po… f_meas  0.997 1.06e-3     5 recipe       mult…     1
##  3 base_svm   pre0_mod1_po… accura… 0.995 5.17e-4     5 recipe       svm_…     2
##  4 base_svm   pre0_mod1_po… f_meas  0.994 1.04e-3     5 recipe       svm_…     2
##  5 base_lasso pre0_mod1_po… accura… 0.990 2.03e-3     5 recipe       mult…     3
##  6 base_lasso pre0_mod1_po… f_meas  0.988 2.37e-3     5 recipe       mult…     3
##  7 pca_lasso  pre0_mod1_po… accura… 0.957 3.55e-3     5 recipe       mult…     4
##  8 pca_lasso  pre0_mod1_po… f_meas  0.940 4.44e-3     5 recipe       mult…     4
##  9 pca_svm    pre0_mod2_po… accura… 0.950 2.19e-3     5 recipe       svm_…     5
## 10 pca_svm    pre0_mod2_po… f_meas  0.917 6.97e-3     5 recipe       svm_…     5
## 11 pca_ridge  pre0_mod1_po… accura… 0.935 4.54e-3     5 recipe       mult…     6
## 12 pca_ridge  pre0_mod1_po… f_meas  0.903 2.12e-2     5 recipe       mult…     6

autoplot(train_res, id = "base_ridge") +
  theme_light()

best_results <- 
  train_res |> 
  extract_workflow_set_result("base_svm") |> 
  select_best(metric = "accuracy")

print(best_results)

## # A tibble: 1 × 2
##      cost .config        
##     <dbl> <chr>          
## 1 0.00101 pre0_mod1_post0

best_results <- train_res |> 
  extract_workflow_set_result("base_svm") |> 
  select_best(metric = "accuracy")

print(best_results)

## # A tibble: 1 × 2
##      cost .config        
##     <dbl> <chr>          
## 1 0.00101 pre0_mod1_post0

best_results <- train_res |>
  extract_workflow_set_result("base_ridge") |>
  select_best(metric = "accuracy")

ridge_res <- train_res |>
  extract_workflow("base_ridge") |>
  finalize_workflow(best_results) |>
  last_fit(split = data_split, metrics = metric_set(f_meas, accuracy, roc_auc))
collect_metrics(ridge_res) |> 
  print()

## # A tibble: 3 × 4
##   .metric  .estimator .estimate .config        
##   <chr>    <chr>          <dbl> <chr>          
## 1 f_meas   macro              1 pre0_mod0_post0
## 2 accuracy multiclass         1 pre0_mod0_post0
## 3 roc_auc  hand_till          1 pre0_mod0_post0

collect_predictions(ridge_res) |> 
  conf_mat(truth = author, estimate = .pred_class) |> 
  autoplot(type = "heatmap") +
  scale_fill_gradient(low = "white", high = "#233857") +
  theme(panel.grid.major = element_line(colour = "#233857"),
        axis.text = element_text(color = "#233857"),
        axis.title = element_text(color = "#233857"),
        plot.title = element_text(color = "#233857"),
        axis.text.x = element_text(angle = 90))

collect_predictions(ridge_res) |> 
  select(starts_with(".pred_")) |> 
  names() #можно оставить, а можно убрать

##  [1] ".pred_class"      ".pred_ABronte"    ".pred_Austen"     ".pred_CBronte"   
##  [5] ".pred_Dickens"    ".pred_Eliot"      ".pred_Fielding"   ".pred_Richardson"
##  [9] ".pred_Sterne"     ".pred_Thackeray"  ".pred_Trollope"

Оценка на тестовой выборке

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

Матрица практически идеальна: все предсказания лежат на диагонали, вне её — нули. На отложенной выборке модель не ошиблась ни разу, включая близкие пары вроде ABronte / CBronte и стилистически смежных викторианцев. Даже самые малочисленные классы определены верно (Стерн — 27 отрывков, (A)Бронте — 34), тогда как у Ричардсона (174) правильно классифицированы все.

Все это получено при разбиении на train/test по отрывкам, при котором фрагменты одного и того же романа попадают и в обучение, и в тест. Поэтому модель отчасти опознаёт не идиолект, а конкретную книгу — по именам героев и сюжетной лексике (что подтверждается интерпретацией признаков ниже, где у авторов всплывают имена персонажей). Наверное, если бы отрывки одного произведения не делились между выборками, а имена собственные мы бы удалили с помощью culling — тогда точность стала бы скромнее, но честнее отражала бы собственно авторский стиль.

collect_predictions(ridge_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.5, alpha = 0.7) +
  scale_color_brewer(palette = "Paired") +
  labs(color = NULL) +
  theme_light()

final_model <- extract_fit_parsnip(ridge_res)

top_terms <- tidy(final_model) |>
  filter(term != "(Intercept)") |>
  group_by(class) |>                           
  slice_max(abs(estimate), n = 10)  |>             
  ungroup()  |> 
  mutate(term = fct_reorder(term, abs(estimate)))

print(top_terms)

## # A tibble: 100 × 4
##    class   term    estimate  penalty
##    <chr>   <fct>      <dbl>    <dbl>
##  1 ABronte but       0.203  1.07e-10
##  2 ABronte and       0.149  1.07e-10
##  3 ABronte which    -0.117  1.07e-10
##  4 ABronte replied   0.113  1.07e-10
##  5 ABronte or        0.106  1.07e-10
##  6 ABronte in       -0.104  1.07e-10
##  7 ABronte out      -0.0913 1.07e-10
##  8 ABronte this     -0.0840 1.07e-10
##  9 ABronte who      -0.0817 1.07e-10
## 10 ABronte alone     0.0784 1.07e-10
## # ℹ 90 more rows

library(tidytext)

top_terms |>
  mutate(term = reorder_within(term, abs(estimate), class)) |>
  ggplot(aes(x = estimate, y = term, fill = class)) +
  geom_col(show.legend = FALSE, alpha = 0.85) +
  facet_wrap(~ class, scales = "free_y", nrow = 4) +
  scale_y_reordered() +
  scale_fill_viridis_d() +
  labs(title = "Наиболее важные признаки для каждого автора",
       x = "Коэффициент", y = "Признак") +
  theme_minimal()

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

Коэффициенты ridge-модели показывают, какие слова сильнее всего «тянут» отрывок к тому или иному автору.

Первый тип — имена героев, но это совсем не интересно. Это утечка содержания: модель отчасти опознаёт книгу, а не стиль, и именно она обеспечивает почти идеальную точность при разбиении по отрывкам. В строгом исследовании имена собственные следовало бы удалить (через culling).

Второй тип — cтилевые признаки, и они интереснее. У Дж.Остин доминируют every, could, very, however, must — оценочно-модальная лексика, которая относится к free indirect discourse) и которая отличает Остин. У Элиота рядом со служебными словами стоят feeling, felt, sense — лексика внутренней жизни: психологизм и проникновение в сознание героя — определяющая черта её прозы и предмет отдельных готовых исследований. У Филдинга — indeed, therefore, which: риторические коннекторы эссеистической, авторски-комментирующей прозы XVIII века.

Интересно слово eye, находящееся в топе у (C)Bronte. Мотив ВЗГЛЯДА (gaze) — устойчивый предмет критики именно у Шарлотты Бронте, ему посвящена, например, работа о функции взгляда в «Профессоре» и «Джейн Эйр» (2004).

Вывод: ridge-модель опирается одновременно на стиль (модальность, психологизм, метанарративность, риторические связки) и на сюжет (имена). Это объясняет высокую точность, но и показывает её цену — часть «успеха» обеспечена утечкой содержания, а не чистым авторским почерком. ## Внутриавторская вариативность: случай Диккенса

# матрица нормализованных частот слов (только 500 слов, без служебных колонок)
word_cols <- setdiff(names(corpus_tf), c("id", "author", "book", "sample"))

feat_mat <- corpus_tf |>
  select(all_of(word_cols)) |>
  scale()

meta_rows <- corpus_tf |> select(author, book)
D <- as.matrix(dist(feat_mat))   # евклидовы расстояния между всеми отрывками

# среднее расстояние между двумя наборами строк
mean_dist <- function(idx1, idx2, same = FALSE) {
  sub <- D[idx1, idx2, drop = FALSE]
  if (same) sub <- sub[upper.tri(sub)]
  mean(sub)
}

dick  <- which(meta_rows$author == "Dickens")
other <- which(meta_rows$author != "Dickens")

# внутри одного романа (усреднение по трём романам)
within_book <- map_dbl(unique(meta_rows$book[dick]), function(b) {
  idx <- which(meta_rows$author == "Dickens" & meta_rows$book == b)
  mean_dist(idx, idx, same = TRUE)
}) |> mean()

# между разными романами Диккенса
between_books <- {
  bks <- unique(meta_rows$book[dick])
  combn(bks, 2, function(pair) {
    i1 <- which(meta_rows$author == "Dickens" & meta_rows$book == pair[1])
    i2 <- which(meta_rows$author == "Dickens" & meta_rows$book == pair[2])
    mean_dist(i1, i2)
  }) |> mean()
}

# И еще немного о случае Диккенса
between_authors <- mean_dist(dick, other)

tibble(
  тип = c("внутри одного романа (Dickens)",
          "между романами Dickens",
          "Dickens против других авторов"),
  среднее_расстояние = c(within_book, between_books, between_authors)
)

## # A tibble: 3 × 2
##   тип                            среднее_расстояние
##   <chr>                                       <dbl>
## 1 внутри одного романа (Dickens)               29.8
## 2 между романами Dickens                       30.4
## 3 Dickens против других авторов                31.6

Визуализируем три романа Диккенса в пространстве первых двух главных компонент на фоне остальных авторов серым).

# PCA на всех данных (для разведки, с фиксированным числом компонент)
pca_dick <- corpus_tf |>
  select(author, book, all_of(word_cols)) |>
  mutate(author = as.factor(author)) |>
  recipe(author ~ ., data = _) |>
  update_role(book, new_role = "id") |>
  step_zv(all_predictors()) |>
  step_normalize(all_predictors()) |>
  step_pca(all_predictors(), num_comp = 5) |>
  prep() |>
  juice()

pca_dick |>
  mutate(grp = if_else(author == "Dickens", paste0("Dickens: ", book), "другие авторы")) |>
  ggplot(aes(PC1, PC2)) +
  geom_point(data = ~filter(.x, grp == "другие авторы"),
             color = "grey80", size = 1, alpha = 0.5) +
  geom_point(data = ~filter(.x, grp != "другие авторы"),
             aes(color = grp), size = 1.8, alpha = 0.8) +
  stat_ellipse(data = ~filter(.x, grp != "другие авторы"),
               aes(color = grp), level = 0.7) +
  scale_color_brewer(palette = "Set1") +
  labs(title = "Три романа Диккенса в пространстве стиля",
       subtitle = "Сливаются ли они в одно облако или расходятся?",
       color = NULL) +
  theme_light()

Внутриавторская вариативность: случай Диккенса

Отдельный вопрос — насколько стиль одного автора стабилен от романа к роману. Диккенс “удобен” для проверки: в корпусе три его романа (Bleak House, David Copperfield, Hard Times). М сравнили три типа средних стилевых расстояний между отрывками — внутри одного романа, между разными романами Диккенса и между Диккенсом и другими авторами:

• внутри одного романа: 29.8
• между романами Диккенса: 30.4
• Диккенс против остальных: 31.6

Эти числа говорят сразу о двух вещах. Во-первых, стиль Диккенса стабилен: перейти из одного его романа в другой (29.8 → 30.4) почти ничего не меняет, то есть авторский почерк держится от книи к книге, а не распадается на разные манеры. На PCA-графике это видно прямо: эллипсы трёх романов почти полностью накладываются друг на друга, образуют плотный сгусток, отделённый от остальных авторов.

Во-вторых — и это неожиданнее — расстояние додругих авторов (31.6) лишь немного больше, чем внутри самого Диккенса (29.8). Авторская компонента есть, но она, видимо, слабая: в 500-мерном пространстве частот слов все отрывки расположены почти равноудалённо друг от друга. Это проявление «проклятия размерности»? в пространствах высокой размерности расстояния между точками плохо различают классы. Поэтому успех классификации обеспечивают не сами по себе расстояния, а способность регуляризованных моделей (ridge, SVM) найти подходящие веса в этом пространстве — отдельные маркерные слова, а не общую близость. Этот результат и оправдывает выбор линейных моделей с регуляризацией и объясняет, почему снижение размерности (PCA) их ухудшало: оно стирало как раз те тонкие направления, которые модель использует для разделения.