Исследование стилистических особенностей британских авторов

с применением tidymodels

Так как я прикрепляю только qmd-файл, вот опубликованный проект со всем изображениями по этой ссылке. Чтобы ускорить обработку, все графики не строились здесь, а были заранее сохранены в формате jpeg.

library(quanteda.textstats)
library(udpipe)
library(stopwords)
library(tidyverse)
library(textrecipes)
library(tidymodels)
library(tidytext)
library(stylo)
library(baguette)
library(discrim)
library(future)
library(devtools)
library(learntidymodels)
library(embed)

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

text_folder <- "files/british_corpus"
files <- list.files(path = text_folder, pattern = "\\.txt$", full.names = TRUE)

text_corpus <- tibble(
  filename = basename(files),
  text = map_chr(files, readr::read_file)
)

Подготовка текста: очищаем от пунктуации(оставляет точки и заглавные буквы в начале предложений – это будет необходимо при подсчете средней длины предложений).

corpus_clean <- text_corpus|>
  mutate(
    text = text|>
      #цифры и лишняя пунктуация
      str_remove_all("[0-9]")|>
      str_replace_all("[[:punct:]&&[^.]]", "")|>
      #разбивка на предложения
      str_split("\\.\\s+")|>
      map(~ {
        #первую букву каждого предложения делаем заглавной
        str_sub(.x, 1, 1) <- str_to_upper(str_sub(.x, 1, 1))
        #остальные - строчные
        str_sub(.x, 2) <- str_to_lower(str_sub(.x, 2))
        paste(.x, collapse = ". ")
      })|>
      unlist()|>
      #лишние пробелы
      str_squish()
  )

Для посчета средних значений используем пакет textstat, в который уже вложены нужные формулы.

#СРЕДНЯЯ ДЛИНА ПРЕДЛОЖЕНИЙ И СЛОВ БЕЗ УДАЛЕНИЯ СТОП-СЛОВ

sent <- textstat_readability(corpus_clean$text, "meanSentenceLength")  

sent_length <- mutate(text_corpus, sent$meanSentenceLength)|>
  select(-text)|>
  rename(ASL = `sent$meanSentenceLength`)

ggplot(sent_length, aes(x = filename, y = ASL)) +
  geom_col(fill = "steelblue") +
  coord_cartesian(ylim = c(0, 50)) +
  labs(title = "Средняя длина предложения по текстам",
       x = "Текст",
       y = "Средняя длина предложения") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))




#средняя длина слова в каждом тексте(по кол-ву слогов)
words <- textstat_readability(text_corpus$text, "meanWordSyllables")  

word_length <- mutate(text_corpus, words$meanWordSyllables)|>
  select(-text)|>
  rename(AWL = `words$meanWordSyllables`)


ggplot(word_length, aes(x = filename, y = AWL)) +
  geom_col(fill = "steelblue") +
  coord_cartesian(ylim = c(0, 2)) +
  labs(title = "Средняя длина слова по текстам",
       x = "Текст",
       y = "Средняя длина слова") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

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

#СРЕДНЯЯ ДЛИНА СЛОВА ПОСЛЕ УДАЛЕНИЯ СТОП-СЛОВ

stopwords_en <- c(
  stopwords("en", source = "snowball"),
  stopwords("en", source = "marimo"),
  stopwords("en", source = "nltk"), 
  stopwords("en", source  = "stopwords-iso")
)

stopwords_en <- sort(unique(stopwords_en))


corpus_no_stopwords <- corpus_clean |>
  mutate(
    text = map_chr(text, ~ {
      words <- unlist(str_split(.x, "\\s+"))
      words <- words[!words %in% stopwords_en]
      paste(words, collapse = " ")
    })
  )


words_no_stop <- textstat_readability(corpus_no_stopwords$text, "meanWordSyllables")  

word_length_no_stop <- mutate(corpus_no_stopwords, words_no_stop$meanWordSyllables)|>
  select(-text)|>
  rename(AWL = `words_no_stop$meanWordSyllables`)


ggplot(word_length_no_stop, aes(x = filename, y = AWL)) +
  geom_col(fill = "steelblue") +
  coord_cartesian(ylim = c(0, 3)) +
  labs(title = "Средняя длина слова по текстам (по кол-ву слогов) после удаления стоп-слов",
       x = "Текст",
       y = "Средняя длина слова") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

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

#СТАТИСТИКА ПО СТОП-СЛОВАМ

corpus_with_metrics <- corpus_clean |>
  mutate(
    word_stats = map(text, ~{
      words <- unlist(str_split(.x, "\\s+"))
      total <- length(words)
      stopwords <- sum(words %in% stopwords_en)
      list(
        total_words = total,
        stopword_count = stopwords,
        stopword_ratio = stopwords / total
      )
    })
  )|>
  unnest_wider(word_stats)

ggplot(corpus_with_metrics, aes(x = filename, y = stopword_ratio)) +
  geom_col(fill = "tomato") +
  coord_cartesian(ylim = c(0, 1)) +
  labs(title = "Доля стоп-слов в текстах",
       x = "Текст",
       y = "Кол-во стоп-слов") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

Переходим к части с классификацией. Поскольку в случае подбора модели нам важны в том числе служебные слова, стоп-слова мы оставляем. Функция load.corpus.and.parse выдает текст очищенным от цифр и пункцуации, приведенным к нижнему регистру. Однако необходимо избавиться от именованных сущностей (пример: если бы мы анализировали корпус русского канона, то одним из самых частых слов там был бы “Пьер” и “князь”, потому что роман Толстого занимал бы много места в общем корпусе).

Для решения этой задачи можно было бы использовать морфологическую разметку, однако корпус слишком большой. В таком случае необходимо вспомнить, что именованные сущности уникальны практически для каждого текста. То есть имя героя романа Диккенса, вряд ли будет так же часто встречаться в романе Остен. Используем для этого “высеивание” – в итоговую выборку попадут только те слова, которые встречаются в 90% текстов. Таким образом мы избежим попадания уникальных имен и топонимов в финальный корпус.

Поскольку количество сэмплов будет слишком неравомерным(если взять всех авторов для анализа), приходится отсеить несколько авторов “с конца”.

corpus <- load.corpus.and.parse(corpus.dir = "british_corpus")

corpus_samples <- make.samples(corpus, 
                               sample.size = 2000, 
                               sampling = "normal.sampling",
                               sample.overlap = 0,
                               sampling.with.replacement = FALSE)

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

corpus_tf <- stylo::make.table.of.frequencies(corpus_samples, mfw) |> 
  as.data.frame.matrix() |> 
  rownames_to_column("id") |> 
  as_tibble(
  )

corpus_tf_new <- perform.culling(corpus_tf, culling.level = 90)

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


corpus_tf_new |> 
  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_new |> 
  add_count(author) |> 
  filter(n >= 200) |> 
  select(-n, -title) 

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

Создаем тренировочные и тестовые данные. Разбиваем тренировочные данные на 5 “фолдов”. Внутри базового рецепта прописываем несколько предикторов:

1. step_zv необходим в случае если какой-то признак имеет дисперсию равную 0. В этом случае этот признак бракуется.

2. step_normalize выполняет стандартизацию числовых данных, приводя их к единому масштабу.

3. step_impute_mean используется для обработки пропущенных значений в данных, заменяя их средним значением (mean) по столбцу. В нем появилась необходимость на моменте обучения, когда начались ошибки при обработке данных.

set.seed(07062025)
data_split <- corpus_top |> 
  mutate(author = as.factor(author)) |> 
  initial_split(strata = author)

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


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


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

Также создадим рецепт, в котором используем главные компоненты в качестве предикторов. Мы отдаем рецепту данные и говорим: тренируйся (= преобразуй эти данные во что-то, на основе чего мы будем осуществлять обучение).

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


base_trained <- base_rec |>
  prep(data_train) 

base_trained

Далее мы передаем полученное функции bake, еще не снижая размерность. Обратим внимание, что группы не слишком разделены.

base_trained |> 
  bake(new_data = NULL)

pca_trained <- pca_rec |>
  prep(data_train) 

pca_trained |> 
  juice()

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

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

pls_trained <- base_trained |> 
  step_pls(all_numeric_predictors(), outcome = "author", num_comp = 7) |> 
  prep() 

pls_trained |> 
  juice() 

pls_trained |> 
  juice() |> 
  ggplot(aes(PLS1, PLS2, color = author)) +
  geom_point() +
  theme_light()

Выведем также нагрузки компонент.

pls_trained |> 
  plot_top_loadings(component_number <= 4, n = 10, type = "pls") +
  scale_fill_brewer(palette = "Paired") +
  theme_light()

Попробуем еще один способ улучшить точность и интерпретируемость модели – используем UMAP.

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

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

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

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


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

Вносим все в workflow_set для удобного перебора разных рецептов с разными моделями.

wflow_set <- workflow_set(  
  preproc = list(base = base_rec,
                 pca = pca_rec,
                 pls = pls_rec,
                 umap = umap_rec),  
  models = list(svm = svm_spec,
                lasso = lasso_spec,
                ridge = ridge_spec,
                mlp = mlp_spec,
                fda = fda_spec,
                knn = knn_mod),  
  cross = TRUE
)

plan(multisession, workers = 5)

Переходим к выбору наиболее точной модели. По графику вижно, что больше всего подходит модель base_mlp, однако на этапе интерпретации результатов и визуализации, я столкнулась с проблемой того, что функция tidy не воспринимает объект класса nnet.formula. В таком случае попробуем интерпретировать результаты модели с рангом 2 – base_ridge. Можно также заметить, что размах без учета выбросов у этой модели меньше, чем у base_mlp.

Визуализируем результаты работы модели.

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

collect_predictions(ridge_res) |>
  roc_curve(truth = author, .pred_Austen:.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) +
  labs(color = NULL) +
  theme_light()

Перейдем к интерпретации модели. Достанем самые отличающие авторов друг от друга слова и визуализируем.

final_model <- extract_fit_parsnip(ridge_res)

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

print(top_terms)

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

Сразу обратим внимание на отсутствие имен (в корпусе по русскому канону в итоговой визуализации встретились и Григорий, и Самгин). Значит в этот раз, при куллинге, мы скорее всего все сделали правильно.

Попробуем посмотреть интерпретировать получившееся. Из всех захотелось выделить только слово “very” у Остен и Элиота. Если первая отличается частым использованием, то у второй – наоборот. Остальные слова могут сказать что-то скорее о синтаксисе предложений, чем о смысловых особенностях.