Введение

Данная работа посвящена решению задачи многоклассовой классификации с помощью методов машинного обучения. В качестве тренировочного датасета был взят корпус A Small Collection of British Fiction (28 произведений британской прозы конца XVIII — XIX веков). Наша цель - проанализировать стилистические особенности авторов и классифицировать тексты по авторам.

В ходе решения задачи мне понадобились (в той или иной мере) следующие библиотеки:

library(tidyverse)
library(tidytext)
library(tidymodels)
library(textrecipes)
library(textstem)
library(discrim)
library(stylo)
library(baguette)
library(udpipe)
library(workflowsets)
library(ranger)
library(earth)
library(vip)
library(gridExtra)
library(viridis)

Подготовка датасета

Так как датасет достаточно маленький (всего 28 произведений), мною было принято решение разбить тексты на отрывки по 2000 слов и классифицировать уже их.

Таким образом, предобработка включает в себя: чтение файлов из папки (куда был помещен разархивированный архив) токенизацию и лемматизацию

# Разхархивирование архива в отдельную папку

unzip("british_fiction.zip", exdir = "british_fiction")

# Чтение файлов из директории, создание "сырого" корпуса "автор - книга - текст"

raw_corpus <- tibble(file_path = list.files("british_fiction/british_fiction", full.names = TRUE)) |>
  mutate(
    filename = basename(file_path),
    text = map_chr(file_path, ~read_file(.x))
  ) |>
  mutate(filename = str_remove(filename, "\\.txt$")) |>
  separate(filename, into = c("author", "title"), sep = "_") |>
  mutate(author = as.factor(author)) |>
  select (text, author, title)

# Создание корпуса отрывков, включающее в себя разбиение текста, его токенизацию и лемматизацию

chunked_corpus <- raw_corpus |>
  group_by(author, title) |>
  unnest_tokens(word, text, to_lower = TRUE) |>
  mutate(word = lemmatize_words(word)) |>
  mutate(chunk_id = (row_number() - 1) %/% 2000) |>
  group_by(author, title, chunk_id) |>
  summarise(text = str_c(word, collapse = " "), .groups = "drop") |>
  mutate(segment_id = str_c(author, title, chunk_id, sep = "_"))

chunked_corpus

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

  1. средняя длина слова

  2. частотность стоп-слов (общая)

  3. частотность стоп-слов (отдельная, по словам, взят топ-100 из списка)

  4. частотность прилагательных, существительных и глаголов

  5. tf-idf (взят топ-300 по всем текстам)

ud_model <- udpipe_download_model(language = "english")
ud_model <- udpipe_load_model(ud_model$file_model)

# разбиваем метрики на три вида - базовые (без применения udpipe), аннотированные (с применением udpipe) и частотные (tf-idf и частотности отдельных стоп-слов)

words_extracted <- chunked_corpus |>
  unnest_tokens(word, text, to_lower = TRUE, drop = FALSE)

basic_metrics <- words_extracted |>
  mutate(is_stop = if_else(word %in% stop_words$word, 1, 0)) |>
  group_by(segment_id) |>
  summarise(
    avg_word_length = mean(nchar(word), na.rm = TRUE),
    stop_word_freq  = sum(is_stop) / n(),
    .groups = "drop"
  )

pos_annotated <- udpipe_annotate(ud_model, x = chunked_corpus$text, doc_id = chunked_corpus$segment_id) |>
  as.data.frame()

pos_metrics <- pos_annotated |>
  filter(upos %in% c("NOUN", "VERB", "ADJ")) |>
  count(doc_id, upos) |>
  group_by(doc_id) |>
  mutate(freq = n / sum(n)) |>
  ungroup() |>
  pivot_wider(id_cols = doc_id, names_from = upos, values_from = freq, values_fill = 0) |>
  rename(
    segment_id = doc_id,
    noun_freq = NOUN,
    verb_freq = VERB,
    adj_freq  = ADJ
  )

top_100_stopwords <- words_extracted |>
  inner_join(stop_words, by = "word") |>
  count(word, sort = TRUE) |>
  head(100) |>
  pull(word)

stopword_counts <- words_extracted |>
  filter(word %in% top_100_stopwords) |>
  count(segment_id, word) |>
  group_by(segment_id) |>
  mutate(freq = n / sum(n)) |>
  ungroup() |>
  pivot_wider(id_cols = segment_id, names_from = word, values_from = freq, values_fill = 0, names_prefix = "sw_")

top_words_overall <- words_extracted |>
  count(word, sort = TRUE) |>
  head(300) |>
  pull(word)

tfidf_features <- words_extracted |>
  filter(word %in% top_words_overall) |>
  count(segment_id, word) |>
  bind_tf_idf(word, segment_id, n) |>
  pivot_wider(id_cols = segment_id, names_from = word, values_from = tf_idf, values_fill = 0, names_prefix = "tfidf_")


stylometric_features <- chunked_corpus |>
  select(segment_id, author, title) |>
  inner_join(basic_metrics, by = "segment_id") |>
  inner_join(pos_metrics, by = "segment_id") |>
  inner_join(stopword_counts, by = "segment_id") |>
  inner_join(tfidf_features, by = "segment_id")

Итого мой датасет - это таблица (3247, 408) (то есть 3247 объектов, каждый характеризуется 405 признаками).

Фича на будущее - сохраняйте этот датасет в формате .csv/.tsv, чтобы каждый раз его не пересчитывать (потому что иногда это занимает ну ооооочень много времени, часа 3-4)

Анализ данных

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

Распределение признаков по авторам

ggplot(stylometric_features, aes(x = author, y = avg_word_length, fill = author)) +
  geom_boxplot(alpha = 0.7) +
  theme_minimal() +
  labs(title = "Распределение средней длины слов у авторов", x = "Автор", y = "Средняя длина слова") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none")

ggplot(stylometric_features, aes(x = author, y = stop_word_freq, fill = author)) +
  geom_boxplot(alpha = 0.7) +
  theme_minimal() +
  labs(title = "Частотность стоп-слов у авторов", x = "Автор", y = "Частотность") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none")

ggplot(stylometric_features, aes(x = author, y = adj_freq, fill = author)) +
  geom_boxplot(alpha = 0.7) +
  theme_minimal() +
  labs(title = "Частотность прилагательных у авторов", x = "Автор", y = "Частотность") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none")

ggplot(stylometric_features, aes(x = author, y = noun_freq, fill = author)) +
  geom_boxplot(alpha = 0.7) +
  theme_minimal() +
  labs(title = "Частотность существительных у авторов", x = "Автор", y = "Частотность") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none")

ggplot(stylometric_features, aes(x = author, y = verb_freq, fill = author)) +
  geom_boxplot(alpha = 0.7) +
  theme_minimal() +
  labs(title = "Частотность глаголов у авторов", x = "Автор", y = "Частотность") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1), legend.position = "none")

В этом разделе я посмотрела на 5 признаков (те, что упомянуты в пунктах 1, 2 и 4), получила следующие визуализации:

По итогу из полученных boxplots можно заметить следующее:

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

  2. с точки зрения признака stop_words_freq у нас наблюдается достаточно сильный разброс, однако, к сожалению, вряд ли с помощью этого признака мы сможем определять конкретного автора, так как у нас есть совпадения: например, среднее у CBronte и у Thackeray совпадает (как и у Eliot с Fielding).

  3. с точки зрения признака adj_freq практически все авторы не отличимы, кроме, разве что, EBronte. Её показали оказались сильно ниже средних у других авторов, так что, возможно, этот признак окажется значимым для определения именно этого автора. Но для остальных - вряд ли.

  4. с точки зрения признака noun_freq ярко выделяются такие авторы как Sterne и Thackeray, потому что их “ящик с усами” расположен выше остальных “ящиков” (то есть тут выделение даже не среднего, а всей выборки). Вполне возможно, этот признак окажет значительное влияние на наше решение задачи.

  5. с точки зрения признака verb_freq можно предположить, что он будет значимым у EBronte (у которой этот показатель значительно выше, чем у других), Sterne и Thackeray (у них наоборот, этот показатель сильно ниже, чем у остальных). Однако для остальных авторов предположение о вкладе этого признака в модель сделать нельзя - у них распределено все более-менее в одном диапазоне 0.3-0.35

Исходя из всего этого, мне кажется, что наиболее результативными будут частотные признаки по отдельным стоп-словам и tf-idf, а не базовые и не аннотированные признаки

PCA

Теперь посмотрим на результаты PCA:

set.seed(43)


data_split <- initial_split(stylometric_features, prop = 0.80, strata = author)
train_data <- training(data_split)
test_data  <- testing(data_split)

base_rec <- recipe(author ~ ., data = train_data) |>
  update_role(segment_id, title, new_role = "id") |>
  step_zv(all_predictors()) |>
  step_normalize(all_predictors())

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

pca_trained <- pca_rec |>
  prep(train_data)

pca_trained |>
  juice()

pca_trained_12 <- pca_trained |>
  juice() |>
  ggplot(aes(PC1, PC2, color = author)) +
  geom_point() +
  theme_light()

pca_trained_45 <- pca_trained |>
  juice() |>
  ggplot(aes(PC4, PC5, color = author)) +
  geom_point() +
  theme_light()

По итогу можно заметить следующее: в обеих визуализациях кластеры накладываются друг на друга (то есть их сложно отделить друг от друга), хотя некоторая “кучкованность” заметна - так, например, в первой визуализации четко видны кластеры Thackeray и Trollope, Fielding и Richardson, а во второй отделяются Sterne и CBronte (ну, с натяжкой, конечно, но отделяются). Мне кажется, что это результат

Обучение

Во время обучения я решила сравнить работу следующих шести модели: Lasso, Ridge, MLP, FDA (были упомянуты в уроке о многоклассовой классификации и запустились (остальные такой чети меня не удостоили)), Random Forest и Naive Bayes. В конце концов, никто не говорил ограничиться ТОЛЬКО моделями из tidymodels.

set.seed(43) # это для воспроизводимости результатов

# Теперь поделим все имеющиеся данные на тестовую и обучающую выборки, а потом воспользуемся кросс-валидацией (я сделала 3 фолда, потому что иначе они получаются очень маленкьми и есть риск переобучения или недообучения)

data_split <- initial_split(stylometric_features, prop = 0.80, strata = author)
train_data <- training(data_split)
test_data  <- testing(data_split)

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

# Рецепт - нужно нормализовать все признаки, убрать "дубликаты" (коррелирующие признаки, иначе некоторые алгоритмы начнут работать плохо) и удалить признаки с нулевой дисперсией

stylometry_recipe <- recipe(author ~ ., data = train_data) |>
  update_role(segment_id, title, new_role = "id") |>
  step_zv(all_predictors()) |>
  step_normalize(all_predictors()) |>
  step_corr(all_predictors(), threshold = 0.90)

# Модели - писала выше, какие

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

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

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

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

nb_spec <- naive_Bayes(smoothness = tune(), Laplace = tune()) |>
  set_engine("naivebayes") |>
  set_mode("classification")

# Собираем workflow и тестируем

all_workflows <- workflow_set(
  preproc = list(base = stylometry_recipe),
  models = list(
    Lasso = lasso_spec,
    Ridge = ridge_spec,
    MLP = mlp_spec,
    FDA = fda_spec,
    Random_Forest = rf_spec,
    Naive_Bayes = nb_spec
  )
)

tuned_results <- all_workflows |>
  workflow_map(
    fn = "tune_grid",
    resamples = folds,
    grid = 5,
    metrics = metric_set(accuracy, roc_auc),
    verbose = TRUE
  )
# Сравниваем работу обученных алгоритмов на кросс-валидации

comparison_table <- tuned_results |>
  rank_results(rank_metric = "accuracy", select_best = TRUE) |>
  dplyr::select(wflow_id, .metric, mean, std_err)

metrics_ <- tableGrob(comparison_table, rows = NULL, theme = theme_minimal())
ggsave(
  filename = "compare_methods.png",
  plot = metrics_,
  width = 6,
  height = 4,
  dpi = 300,
  bg = "white"
)

autoplot(tuned_results, rank_metric = "accuracy", metric = "accuracy", select_best = TRUE) +
  theme_minimal() +
  labs(
    title = "Сравнение точности (Accuracy) моделей классификации авторов",
    subtitle = "Результаты на кросс-валидации (лучшие конфигурации)",
    x = "Модели",
    y = "Доля правильных ответов (Mean Accuracy)",
  ) +
  theme(legend.position = "none")

ggsave(
  filename = "compare_methods_img.png",
  width = 6,
  height = 4,
  dpi = 300,
  bg = "white"
)

# Выделяем лучшую модель - в нашем случае это base_Ridge 

best_workflow_id <- tuned_results |>
  rank_results(rank_metric = "accuracy", select_best = TRUE) |>
  slice(1) |>
  pull(wflow_id)


best_results <- tuned_results |>
  extract_workflow_set_result(best_workflow_id)

best_params <- select_best(best_results, metric = "accuracy")

# Повторяем для неё процесс обучения "с нуля" (заново) и смотрим на результаты на тестовой выборке

final_fit <- tuned_results |>
  extract_workflow(best_workflow_id) |>
  finalize_workflow(best_params) |>
  last_fit(split = data_split)

test_metrics <- collect_metrics(final_fit)

Как мы видим, лучшей моделью из рассмотренных оказался base_Ridge (обе метрики - и accuracy, и ROC-AUC - в районе 1.0, std_err маленькая, буквально счет на сотые и тысячные), а худшей - base_MLP (в сравнении с остальными моделями - для некоторых задач полученная точность 0.71 и ROC-AUC 0.89 очень даже неплохи). Наравне с base_Ridge прекрасно показали себя base_Lasso и base_Naive_Bayes.С точки зрения точности есть отрыв от них алгоритма base_Random_Forest (с точки зрения ROC-AUC такого разрыва скорее нет), а вот base_FDA уступает всем им по обеим метрикам.

Результаты

Теперь посмотрим, как лучшая из моделей справляется с тестовой выборкой

# Рисуем различные картинки - матрицу ошибок, таблицу с метриками

metrics_summary <- collect_metrics(final_fit)

table_theme <- ttheme_minimal(
  core = list(padding = unit(c(4, 5), "mm")),
  colhead = list(fg_params = list(fontface = "bold"), padding = unit(c(4, 5), "mm"))
)

metrics_grob <- tableGrob(metrics_summary, rows = NULL, theme = table_theme)
ggsave(
  filename = "test_metrics.png",
  plot = metrics_grob,
  width = 6,
  height = 4,
  dpi = 300,
  bg = "white"
)
predictions <- collect_predictions(final_fit)

if(nrow(predictions) > 0) {
  predictions |>
    conf_mat(truth = author, estimate = .pred_class) |>
    autoplot(type = "heatmap") +
    labs(title = "Матрица ошибок классификации авторов",
         subtitle = "Результаты на тестовой выборке") +
    theme_minimal()
}

ggsave(
  filename = "conf_matrix.png",
  width = 12,
  height = 6,
  dpi = 300,
  bg = "white"
)

Неплохо! Не без ошибок (большая часть ошибок связана с тройкой Austen - ABronte - CBronte), но есть и полностью безошибочные авторы (Sterne, Thackeray, Trollope). Значения метрик не отличаются практически от результатов, показанных при проверке на кросс-валидации - точность 0.98, ROC-AUC в районе 1.0. Таким образом, выявленный нами алгоритм действительно хорошо решает задачу (а не переобучился на данной ему при обучении выборке).

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

final_model <- extract_fit_parsnip(final_fit)

vip(final_model, num_features = 15) +
  theme_minimal() +
  labs(title = "Топ-15 самых значимых стилистических признаков",
       subtitle = "Определено алгоритмом base_Ridge по методу перестановок (Permutation)",
       x = "Признаки",
       y = "Важность признака")

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

top_terms  |> 
  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_fill_viridis_d() +
  labs(
    title = "Наиболее важные признаки для каждого автора",
    x = "Коэффициент",
    y = "Признак"
  ) +
  theme_minimal()

Как мы видим, предсказание сбылось - наиболее важными признаками для модели оказались частотные признаки, основанные на стоп-словах и tf-idf. Наибольший вклад вносят признаки sw_but (важность оценена как 0.29), и тройка sw_or, sw_be и sw_and (важность всех из них оценивается в 0.17). Следом идут вперемежку признаки частотности стоп-слов и tf-idf, а в самом конце, на четырнадцатом и пятнадцатом местах - лингвистические признаки частотности прилагательных и существительных. Таким образом, мы еще и подспудно проверили теорию, что стиль автора проще всего вычислить по стоп-словам - в нашем случае это оказалось действительно так!

Если же говорить про авторов конкретно, то у них лингвистический признак оказался важным только у одного автора - у EBronte, - и это оказался признак adj_freq. В остальном пересечений (то есть ситуаций, когда один и тот же признак значительный у двух и более авторов) практически нет - у Trollope и CBronte на первом месте признак sw_that, но с противоположным коэффициентом, похожая ситуация у ABronte и Dickens с признаком sw_but. Из всей картинки можно сделать вывод, что признаки подобраны правильно и мы смогли для каждого автора выявить что-то “свое”