Загрузка данных

path_to_corpus <- "british_fiction"

files <- list.files(
  path_to_corpus,
  pattern = "\\.txt$",
  full.names = TRUE
)

# попробуем вытащить фамилию автора прямо из названия файла, тут вроде регулярка подходит
corpus <- tibble(file = files) |>
  mutate(
    text = map_chr(file, readr::read_file),
    filename = basename(file),
    author = str_extract(filename, "^[^_]+")
  ) |>
  select(author, filename, text)

glimpse(corpus)
## Rows: 27
## Columns: 3
## $ author   <chr> "ABronte", "ABronte", "Austen", "Austen", "Austen", "CBronte"…
## $ filename <chr> "ABronte_Agnes.txt", "ABronte_Tenant.txt", "Austen_Emma.txt",…
## $ text     <chr> "AGNES GREY\r\nCHAPTER I--THE PARSONAGE\r\nAll true histories…

Формирование текстовых фрагментов

tokens <- corpus |>
  unnest_tokens(word, text)

# делим тексты на куски по 1500 слов, иначе данных маловато для нормального обучения
corpus_samples <- tokens |>
  group_by(author, filename) |>
  mutate(
    chunk_id = ceiling(row_number() / 1500)
  ) |>
  group_by(author, filename, chunk_id) |>
  summarise(
    text_chunk = str_c(word, collapse = " "),
    word_count = n(),
    mean_word_length = mean(nchar(word)),
    .groups = "drop"
  ) |>
  filter(word_count >= 1000) # отсекаем короткие хвосты, чтоб не портили статистику

corpus_samples
## # A tibble: 4,303 × 6
##    author  filename          chunk_id text_chunk     word_count mean_word_length
##    <chr>   <chr>                <dbl> <chr>               <int>            <dbl>
##  1 ABronte ABronte_Agnes.txt        1 agnes grey ch…       1500             4.43
##  2 ABronte ABronte_Agnes.txt        2 not lament bu…       1500             4.3 
##  3 ABronte ABronte_Agnes.txt        3 dejection he …       1500             4.26
##  4 ABronte ABronte_Agnes.txt        4 render the da…       1500             4.26
##  5 ABronte ABronte_Agnes.txt        5 possessions a…       1500             4.04
##  6 ABronte ABronte_Agnes.txt        6 i must follow…       1500             4.27
##  7 ABronte ABronte_Agnes.txt        7 for their off…       1500             4.25
##  8 ABronte ABronte_Agnes.txt        8 enough but as…       1500             4.36
##  9 ABronte ABronte_Agnes.txt        9 task meantime…       1500             4.36
## 10 ABronte ABronte_Agnes.txt       10 the forbidden…       1500             4.33
## # ℹ 4,293 more rows

Средняя длина предложений

sentence_stats <- corpus |>
  mutate(
    sentence = str_split(text, "[.!?]")
  ) |>
  unnest(sentence) |>
  mutate(
    sentence_length =
      str_count(sentence, "\\w+")
  ) |>
  group_by(author, filename) |>
  summarise(
    mean_sentence_length =
      mean(sentence_length),
    .groups = "drop"
  )

corpus_samples <- corpus_samples |>
  left_join(
    sentence_stats,
    by = c("author", "filename")
  )

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

Количество фрагментов

# проверим, есть ли сильный дисбаланс по классам
corpus_samples |>
  count(author) |>
  ggplot(
    aes(
      reorder(author, n),
      n,
      fill = author
    )
  ) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  labs(
    title = "Количество текстовых фрагментов",
    x = "Автор",
    y = "Число фрагментов"
  )

Средняя длина слова

author_count <-
  length(unique(corpus_samples$author))

extended_palette <-
  colorRampPalette(my_colors)(
    author_count
  )

corpus_samples |>
  ggplot(
    aes(
      reorder(
        author,
        mean_word_length,
        median
      ),
      mean_word_length,
      fill = author
    )
  ) +
  geom_boxplot(
    show.legend = FALSE,
    alpha = 0.8
  ) +
  scale_fill_manual(
    values = extended_palette
  ) +
  coord_flip() +
  labs(
    title = "Средняя длина слова по авторам",
    x = "Автор",
    y = "Средняя длина слова"
  )

Подготовка выборок

set.seed(123)

data_split <- initial_split(
  corpus_samples,
  strata = author,
  prop = 0.8
)

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

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

Рецепты

# классический tf-idf подход, плюс добавим наши структурные метрики как отдельные переменные
base_rec <- recipe(
  author ~
    text_chunk +
    mean_word_length +
    mean_sentence_length,
  data = data_train
) |>
  step_tokenize(text_chunk) |>
  step_stopwords(text_chunk) |>
  step_tokenfilter(
    text_chunk,
    max_tokens = 500
  ) |>
  step_tfidf(text_chunk) |>
  step_zv(all_predictors()) |>
  step_normalize(
    all_numeric_predictors()
  )

# pca добавим для второго рецепта чисто для сравнения, вдруг выстрелит
pca_rec <- base_rec |>
  step_pca(
    all_numeric_predictors(),
    num_comp = 10
  )

Модели

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

rf_spec <- rand_forest(
  trees = 300,
  mtry = tune(),
  min_n = tune()
) |>
  set_engine("ranger") |>
  set_mode("classification")

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

Workflow Set

wflow_set <- workflow_set(
  preproc = list(
    base = base_rec,
    pca = pca_rec
  ),
  models = list(
    ridge = ridge_spec,
    rf = rf_spec,
    knn = knn_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_rf    <tibble [1 × 4]> <opts[0]> <list [0]>
## 3 base_knn   <tibble [1 × 4]> <opts[0]> <list [0]>
## 4 pca_ridge  <tibble [1 × 4]> <opts[0]> <list [0]>
## 5 pca_rf     <tibble [1 × 4]> <opts[0]> <list [0]>
## 6 pca_knn    <tibble [1 × 4]> <opts[0]> <list [0]>

Кросс-валидация

set.seed(123)

tune_results <- wflow_set |>
  workflow_map(
    "tune_grid",
    resamples = folds,
    grid = 3,
    metrics =
      metric_set(
        accuracy,
        kap
      )
  )

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

autoplot(
  tune_results,
  metric = "accuracy"
)

rank_results(
  tune_results,
  select_best = TRUE
)
## # 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_rf    pre0_mod2_po… accura… 0.997 0.00107     5 recipe       rand…     1
##  2 base_rf    pre0_mod2_po… kap     0.997 0.00122     5 recipe       rand…     1
##  3 base_ridge pre0_mod1_po… accura… 0.989 0.00135     5 recipe       mult…     2
##  4 base_ridge pre0_mod1_po… kap     0.988 0.00153     5 recipe       mult…     2
##  5 pca_knn    pre0_mod3_po… accura… 0.886 0.00730     5 recipe       near…     3
##  6 pca_knn    pre0_mod3_po… kap     0.870 0.00823     5 recipe       near…     3
##  7 pca_rf     pre0_mod2_po… accura… 0.878 0.00547     5 recipe       rand…     4
##  8 pca_rf     pre0_mod2_po… kap     0.861 0.00615     5 recipe       rand…     4
##  9 pca_ridge  pre0_mod1_po… accura… 0.861 0.00731     5 recipe       mult…     5
## 10 pca_ridge  pre0_mod1_po… kap     0.840 0.00825     5 recipe       mult…     5
## 11 base_knn   pre0_mod3_po… accura… 0.854 0.00611     5 recipe       near…     6
## 12 base_knn   pre0_mod3_po… kap     0.832 0.00693     5 recipe       near…     6

Финальная модель

best_params <- tune_results |>
  extract_workflow_set_result(
    "base_ridge"
  ) |>
  select_best(
    metric = "accuracy"
  )

final_res <- tune_results |>
  extract_workflow(
    "base_ridge"
  ) |>
  finalize_workflow(
    best_params
  ) |>
  last_fit(
    split = data_split,
    metrics =
      metric_set(
        accuracy,
        kap,
        f_meas
      )
  )

collect_metrics(final_res)
## # A tibble: 3 × 4
##   .metric  .estimator .estimate .config        
##   <chr>    <chr>          <dbl> <chr>          
## 1 accuracy multiclass     0.981 pre0_mod0_post0
## 2 kap      multiclass     0.979 pre0_mod0_post0
## 3 f_meas   macro          0.966 pre0_mod0_post0

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

collect_predictions(final_res) |>
  conf_mat(
    truth = author,
    estimate = .pred_class
  ) |>
  autoplot(type = "heatmap") +
  scale_fill_gradient(
    low = "white",
    high = "#00008B"
  ) +
  labs(
    title = "Матрица ошибок"
  )

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

final_model <-
  extract_fit_parsnip(final_res)

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

top_terms |>
  ggplot(
    aes(
      estimate,
      reorder(term, estimate),
      fill = class
    )
  ) +
  geom_col(
    show.legend = FALSE
  ) +
  facet_wrap(
    ~ class,
    scales = "free_y"
  ) +
  labs(
    title =
      "Наиболее важные слова для классификации авторов",
    x = "Коэффициент",
    y = "Слово"
  )

Выводы

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

По поводу самих моделей: на кросс-валидации лучше всего себя показали Ridge регрессия и случайный лес, а вот KNN как-то совсем просел. Видимо метрические алгоритмы плохо переваривают наши разреженные текстовые признаки из-за того, что их слишком много - данные размываются в огромном пространстве, оттого в них плохо находятся закономерности. Еще забавный момент с PCA: казалось бы, снижение размерности должно было помочь убрать лишний шум, но на деле метрики качества только упали. Скорее всего при сжатии мы теряем какие-то редкие, но очень уникальные для автора слова.

Итоговая матрица ошибок на тесте выглядит прям отлично, диагональ четкая, модель почти никого не путает.

Но самое интересное всплыло, когда я вывел график самых важных признаков. Я ожидал увидеть там какие-нибудь хитрые союзы или местоимения, которые определяют авторский стиль. А алгоритм оказался проще и просто выучил имена главных героев! Например, у Бронте главный маркер это heathcliff, у Остин это dashwood, а у Элиот это lydgate. С точки зрения машинного обучения классификатор отработал безупречно и нашел самые верные паттерны в тексте. Но если мы говорим именно про настоящую стилометрию, то в следующий раз нужно будет принудительно вычищать все имена собственные перед обучением, чтобы заставить модель искать именно особенности стиля писателя, а не просто состав персонажей его книг.