Эта учебная работа, цель которой: на основе корпуса A Small Collection of British Fiction (28 произведений британской прозы конца XVIII — XIX веков) проанализировать стилистические особенности авторов и классифицировать тексты по авторам.

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

overview <- read_tsv("overview.txt", 
                     col_names = c("textID", "author", "authorID", "title", "year", "author_gender", "comment"),
                     skip = 1)

# Таблица с именами файлов
files_df <- tibble(
  filename = list.files("british_fiction", pattern = "\\.txt$")
) |>
  mutate(
    author_last = str_extract(filename, "^[^_]+"),
    title_short = str_extract(filename, "(?<=_)[^.]+"),
    title_short_lower = str_to_lower(title_short)
  )

# Подготовка overview для соединения
overview <- overview |>
  mutate(
    title_lower = str_to_lower(title),
    title_short_overview = str_remove(title_lower, "^(the |a |an |the )"),
    title_short_overview = str_extract(title_short_overview, "^[^\\s]+")
  )

# Соединение файлов с метаданными
texts_metadata <- files_df |>
  left_join(overview, by = c("title_short_lower" = "title_short_overview")) |>
  mutate(
    textID = case_when(
      filename == "ABronte_Tenant.txt" ~ 5,
      filename == "Richardson_Clarissa.txt" ~ 18,
      filename == "Sterne_Tristram.txt" ~ 20,
      filename == "Thackeray_Barry.txt" ~ 27,
      filename == "Thackeray_Pendennis.txt" ~ 26,
      TRUE ~ textID
    )
  ) |>
  left_join(overview, by = "textID", suffix = c("", ".y")) |>
  mutate(
    author = ifelse(is.na(author), author.y, author),
    authorID = ifelse(is.na(authorID), authorID.y, authorID),
    title = ifelse(is.na(title), title.y, title),
    year = ifelse(is.na(year), year.y, year),
    author_gender = ifelse(is.na(author_gender), author_gender.y, author_gender)
  ) |>
  select(-ends_with(".y"))

# Чтение текстов
texts_metadata <- texts_metadata |>
  mutate(text = map_chr(filename, ~ read_file(file.path("british_fiction", .x))))

# Итоговый датафрейм
final_data <- texts_metadata |>
  select(textID, author, authorID, title, year, author_gender, text)

# Визуализация: распределение текстов по годам
final_data |> 
  ggplot(aes(x = year)) +
  geom_histogram(bins = 20, fill = "steelblue", color = "white") +
  labs(title = "Распределение текстов по годам публикации") +
  theme_light()

# Визуализация: длина текстов по авторам
final_data |>
  mutate(text_length = str_length(text)) |>
  ggplot(aes(x = author, y = text_length, fill = author)) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  labs(title = "Длина текстов по авторам") +
  theme_light()

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

2. Очистка текста

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

# Функция для очистки (сохраняем абзацы и пунктуацию)
clean_text <- function(text) {
  text |>
    str_to_lower() |>
    # Удаляем спецсимволы, но не точки, запятые, восклицания и переносы строк
    str_replace_all("[“”\"'‘’`()\\[\\]{}<>/|\\\\@#$%^&*]", " ") |>
    # Убираем лишние пробелы, сохраняя переносы строк
    str_replace_all("[ \t]+", " ") |>
    str_replace_all(" \n", "\n") |>
    str_replace_all("\n ", "\n")
}

# Применяем очистку
final_data_clean <- final_data |>
  mutate(
    text_clean = map_chr(text, clean_text),
    original_length = str_length(text),
    cleaned_length = str_length(text_clean)
  )

# Сохраняем очищенные данные
saveRDS(final_data_clean, "final_data_clean.rds")

3. Разбиение на сегменты

Т.к. текстов у нас совсем немного - 27, я решила, что будет полезно разбить тексты на сегменты по 5000 слов, чтобы результатов было достаточно для обучения моделей (в первой пробе я этого не делала, и результаты предсказаний были на уровне 1 из 10).

# Функция для разбиения текста на сегменты по 5000 слов
split_text_into_segments <- function(text, segment_size = 5000) {
  words <- str_split(text, "\\s+")[[1]]
  words <- words[words != ""]
  n_segments <- floor(length(words) / segment_size)
  if (n_segments == 0) return(NULL)
  
  segments <- list()
  for (i in 1:n_segments) {
    start <- (i - 1) * segment_size + 1
    end <- i * segment_size
    segments[[i]] <- paste(words[start:end], collapse = " ")
  }
  return(segments)
}

# Применяем разбиение ко всем текстам
all_segments <- list()
for (i in 1:nrow(final_data_clean)) {
  segments <- split_text_into_segments(final_data_clean$text_clean[i], segment_size = 5000)
  if (!is.null(segments)) {
    for (j in 1:length(segments)) {
      all_segments[[length(all_segments) + 1]] <- data.frame(
        author = final_data_clean$author[i],
        title = paste0(final_data_clean$title[i], "_seg", j),
        year = final_data_clean$year[i],
        text_segment = segments[[j]],
        stringsAsFactors = FALSE
      )
    }
  }
}

segments_df <- bind_rows(all_segments)

# Количество полученных сегментов
nrow(segments_df)
## [1] 1277

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

4. Извлечение признаков

Для каждого сегмента были рассчитаны следующие лингвистические признаки:

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

# Извлечение лингвистических признаков из сегментов
segment_features <- segments_df |>
  mutate(
    # Количество слов
    n_words = str_count(text_segment, "\\S+"),
    # Количество предложений
    n_sentences = str_count(text_segment, "[.!?]+"),
    # Средняя длина предложения (в словах)
    mean_sent_len = n_words / n_sentences,
    # Количество уникальных слов
    n_unique_words = map_dbl(text_segment, ~ {
      words <- str_split(.x, "\\s+")[[1]]
      words <- words[words != ""]
      length(unique(words))
    }),
    # Лексическое разнообразие (TTR)
    ttr = n_unique_words / n_words,
    # Средняя длина слова
    mean_word_len = map_dbl(text_segment, ~ {
      words <- str_split(.x, "\\s+")[[1]]
      words <- words[words != ""]
      mean(str_length(words))
    }),
    # Доля знаков препинания
    punct_ratio = str_count(text_segment, "[.,!?;:]") / n_words,
    # Доля восклицаний
    exclamation_ratio = str_count(text_segment, "!") / n_words,
    # Доля вопросов
    question_ratio = str_count(text_segment, "\\?") / n_words
  ) |>
  select(author, mean_sent_len, ttr, mean_word_len, 
         punct_ratio, exclamation_ratio, question_ratio)

# Сохраняем признаки для дальнейшего использования
saveRDS(segment_features, "segment_features.rds")

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

Для визуализации различий между авторами построена “тепловая карта” нормализованных лингвистических признаков. Чем темнее цвет, тем выше значение признака для данного автора. Для наглядности значения были нормальзованы, т.к. различия явно есть, но на графике без нормализации они не очень видны. Это позволяет наглядно сравнить стилистические профили писателей.

# Нормализация признаков (каждый признак приводится к шкале от 0 до 1)
segment_features_normalized <- segment_features |>
  group_by(author) |>
  summarise(across(where(is.numeric), mean)) |>
  mutate(across(where(is.numeric), ~ (.x - min(.x)) / (max(.x) - min(.x))))

# Тепловая карта
segment_features_normalized |>
  pivot_longer(-author, names_to = "feature", values_to = "value") |>
  mutate(feature = recode(feature,
                          mean_sent_len = "Длина предложения",
                          ttr = "Лексическое разнообразие",
                          mean_word_len = "Длина слова",
                          punct_ratio = "Пунктуация",
                          exclamation_ratio = "Восклицания",
                          question_ratio = "Вопросы")) |>
  ggplot(aes(x = author, y = feature, fill = value)) +
  geom_tile() +
  scale_fill_gradient(low = "white", high = "steelblue") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(title = "Лингвистические признаки по авторам",
       subtitle = "Нормализованные средние значения (0-1)",
       x = "Автор", y = "Признак", fill = "Норм. значение")

Следующий график позволяет сравнить средние значения признаков между авторами (также нормализованные для наглядности):

segment_features_normalized |>
  pivot_longer(-author, names_to = "feature", values_to = "value") |>
  mutate(feature = recode(feature,
                          mean_sent_len = "Длина предложения",
                          ttr = "Лексическое разнообразие",
                          mean_word_len = "Длина слова",
                          punct_ratio = "Пунктуация",
                          exclamation_ratio = "Восклицания",
                          question_ratio = "Вопросы")) |>
  ggplot(aes(x = author, y = value, fill = feature)) +
  geom_bar(stat = "identity", position = "dodge") +
  coord_flip() +
  theme_minimal() +
  labs(title = "Средние значения лингвистических признаков по авторам",
       x = "Автор", y = "Нормализованное значение", fill = "Признак") +
  theme(legend.position = "bottom")

Можем также взглянуть на и ндивидуальный профиль автора:

# Профиль автора (пример: Jane Austen - при желании можно выбрать любого другого)
selected_author <- "Austen, Jane"

author_profile <- segment_features_normalized |>
  filter(author == selected_author) |>
  summarise(across(where(is.numeric), mean)) |>
  pivot_longer(everything(), names_to = "feature", values_to = "value") |>
  mutate(feature = recode(feature,
                          mean_sent_len = "Длина предложения",
                          ttr = "Лексическое разнообразие",
                          mean_word_len = "Длина слова",
                          punct_ratio = "Пунктуация",
                          exclamation_ratio = "Восклицания",
                          question_ratio = "Вопросы"))

author_profile |>
  ggplot(aes(x = feature, y = value, fill = feature)) +
  geom_col() +
  coord_polar() +
  ylim(0, 1) +
  theme_minimal() +
  labs(title = paste("Стилистический профиль автора:", selected_author),
       x = "", y = "Нормализованное значение")

На радиальной диаграмме видно, что стиль Джейн Остин характеризуется следующими особенностями:

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

Таким образом, стиль Остин можно охарактеризовать как синтаксически сложный (за счёт пунктуации) и лексически «весомый» (за счёт длины слов), но при этом предложения остаются умеренными по длинеа.

6. Моделирование

Для классификации авторов были обучены три модели с настройкой гиперпараметров: - Random Forest - XGBoost(градиентный бустинг) - SVM (метод опорных векторов)

Все модели обучались на 5-кратной кросс-валидации с последующей оценкой на тестовой выборке (20% данных).

# ПОДГОТОВКА ДАННЫХ
model_data <- segment_features |>
  select(author, mean_sent_len, ttr, punct_ratio, exclamation_ratio, question_ratio) |>
  mutate(author = as.factor(author))

# РАЗДЕЛЕНИЕ
set.seed(123)
data_split <- initial_split(model_data, strata = author, prop = 0.8)
data_train <- training(data_split)
data_test <- testing(data_split)

# КРОСС-ВАЛИДАЦИЯ
set.seed(123)
folds <- vfold_cv(data_train, strata = author, v = 5)

# РЕЦЕПТ
base_rec <- recipe(author ~ ., data = data_train) |>
  step_normalize(all_predictors())

# RANDOM FOREST
rf_spec <- rand_forest(trees = tune(), mtry = tune(), min_n = tune()) |>
  set_engine("ranger", importance = "impurity") |>
  set_mode("classification")

rf_grid <- grid_regular(trees(c(100, 300)), mtry(c(2, 4)), min_n(c(2, 8)), levels = 2)

# XGBOOST
xgb_spec <- boost_tree(trees = tune(), tree_depth = tune(), learn_rate = tune(), 
                       mtry = tune(), min_n = tune()) |>
  set_engine("xgboost") |>
  set_mode("classification")

xgb_grid <- grid_regular(trees(c(100, 500)), tree_depth(c(3, 7)), 
                         learn_rate(c(0.01, 0.1)), mtry(c(2, 4)), min_n(c(2, 10)), levels = 2)

# SVM
svm_spec <- svm_rbf(cost = tune(), rbf_sigma = tune()) |>
  set_engine("kernlab") |>
  set_mode("classification")

svm_grid <- grid_regular(cost(c(0.5, 5)), rbf_sigma(c(0.05, 0.5)), levels = 2)

# WORKFLOW
rf_wflow <- workflow() |> add_recipe(base_rec) |> add_model(rf_spec)
xgb_wflow <- workflow() |> add_recipe(base_rec) |> add_model(xgb_spec)
svm_wflow <- workflow() |> add_recipe(base_rec) |> add_model(svm_spec)

# ПАРАЛЛЕЛЬНЫЕ ВЫЧИСЛЕНИЯ
registerDoParallel(cores = 2)

# НАСТРОЙКА
set.seed(123)
rf_tune <- tune_grid(rf_wflow, resamples = folds, grid = rf_grid)
rf_best <- select_best(rf_tune, metric = "accuracy")

xgb_tune <- tune_grid(xgb_wflow, resamples = folds, grid = xgb_grid)
xgb_best <- select_best(xgb_tune, metric = "accuracy")

svm_tune <- tune_grid(svm_wflow, resamples = folds, grid = svm_grid)
svm_best <- select_best(svm_tune, metric = "accuracy")

# ФИНАЛЬНЫЕ МОДЕЛИ
rf_final <- finalize_workflow(rf_wflow, rf_best)
xgb_final <- finalize_workflow(xgb_wflow, xgb_best)
svm_final <- finalize_workflow(svm_wflow, svm_best)

# ОЦЕНКА НА ТЕСТОВОЙ ВЫБОРКЕ
rf_result <- last_fit(rf_final, data_split)
xgb_result <- last_fit(xgb_final, data_split)
svm_result <- last_fit(svm_final, data_split)

# СРАВНЕНИЕ
rf_acc <- collect_metrics(rf_result) |> filter(.metric == "accuracy")
xgb_acc <- collect_metrics(xgb_result) |> filter(.metric == "accuracy")
svm_acc <- collect_metrics(svm_result) |> filter(.metric == "accuracy")

comparison <- tibble(
  Модель = c("Random Forest", "XGBoost", "SVM"),
  Точность = c(rf_acc$.estimate, xgb_acc$.estimate, svm_acc$.estimate)
) |> arrange(desc(Точность))

# ГРАФИК СРАВНЕНИЯ
comparison |>
  ggplot(aes(x = reorder(Модель, Точность), y = Точность, fill = Модель)) +
  geom_col(show.legend = FALSE) +
  coord_flip() + ylim(0, 1) +
  labs(title = "Сравнение точности моделей") +
  theme_minimal()

## Результаты моделирования

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

После настройки гиперпараметров были получены следующие результаты точности на тестовой выборке:

Модель Точность
SVM (метод опорных векторов) 71.3%
Random Forest (случайный лес) 68.6%
XGBoost (градиентный бустинг) 68.2%

Лучшей моделью признан SVM с точностью 71.3%, что существенно выше случайного угадывания (так как авторов 11, случайное угадываение дало бы примерно 9.1% - как в первой неудачной пробе без разбиение текстов на сегменты).

Нормализованная матрица ошибок SVM

На диаграмме ниже показана тепловая карта ошибок: на диагонали — процент правильно классифицированных сегментов для каждого автора, вне диагонали — ошибочные приписывания.

# Правильная нормализованная матрица ошибок (по строкам)
normalized_conf <- collect_predictions(svm_result) |>
  group_by(author) |>
  count(.pred_class) |>
  mutate(percent = n / sum(n) * 100)

# Тепловая карта
normalized_conf |>
  ggplot(aes(x = author, y = .pred_class, fill = percent)) +
  geom_tile() +
  scale_fill_gradient(low = "white", high = "steelblue") +
  geom_text(aes(label = sprintf("%.1f", percent)), size = 3) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(title = "Нормализованная матрица ошибок SVM (%)",
       x = "Истинный автор", y = "Предсказанный автор", fill = "%")

# Только правильные предсказания (диагональ)
normalized_conf |>
  filter(author == .pred_class) |>
  select(Истинный_автор = author, Процент_правильных = percent) |>
  arrange(desc(Процент_правильных)) |>
  knitr::kable(caption = "Точность по авторам (SVM)", digits = 1)
Точность по авторам (SVM)
Истинный_автор Процент_правильных
Trollope, Antony 86.8
Bronte, Charlotte 82.4
Richardson, Samuel 80.0
Bronte, Emily 75.0
Thackeray, William Makepeace 68.6
Eliot, George 67.6
Fielding, Henry 66.7
Dickens, Charles 56.2
Bronte, Anne 50.0
Sterne, Laurence 42.9
Austen, Jane 37.5

```

Анализ ошибок

Наиболее заметные ошибки классификации: - Джейн Остин правильно распознаётся только в 37.5% случаев. В 25% её текст принимается за Диккенса, ещё в 25% — за Элиот, что указывает на стилистическую близость Остин к викторианским авторам.

  • для Анны Бронте у нас меньше всего данных данных (всего 8 сегментов). Половина из них ошибочно приписана Ричардсону, что может объясняться не статистической значимостью, а случайностью из-за малого объёма выборки.

  • “Викторианская троица” (Чарльз Диккенс, Уильям Теккерей и Джордж Элиот) регулярно путается между собой. Это объясняется общими жанровыми и стилистическими чертами викторианской прозы.

  • Ричардсон, напротив, сам никогда не ошибается (100% точность), но его сегменты часто приписываются другим авторам, что говорит об уникальности его стиля, который модель легко узнаёт, но иногда «притягивает» чужие тексты.

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

Наиболее значимым признаком оказалось лексическое разнообразие (ttr): авторы с экстремальными значениями (как Ричардсон) этого показателя распознаются моделью лучше всего..

Вторым по значимости признаком является средняя длина предложения (mean_sent_len). Контрастные стили хорошо разделяются: Филдинг (29.6 слов в предложении) и Диккенс (15.2 слов) оказались на противоположных концах спектра, что позволяет модели уверенно их различать.

Наименее значимыми оказались признаки восклицаний и вопросов (exclamation_ratio, question_ratio). Они лишь дополняют модель, помогая различать эмоционально окрашенные тексты (например, Эмили Бронте с высокой долей восклицаний) от более сдержанных (Остин).