1 Корпус A Small Collection of British Fiction.
2 Загрузка данных
3 Обзор метаданных
4 Чтение текстов корпуса
5 Проверка количества текстов и метаданных
6 Простые количественные признаки для EDA
7 Биграммы для разведывательного анализа
8 Деление текстов на отрывки
9 Извлечение признаков
- 9.1 Частоты наиболее частотных слов
- 9.2 Частоты наиболее частотных биграмм
- 9.3 Дополнительные стилометрические признаки
10 Train/test split и кросс-валидация
11 Предобработка
12 PCA для разведывательного анализа
13 Модели
14 Workflow set
15 Обучение и сравнение моделей
16 Финальная модель
17 Confusion matrix
18 ROC-AUC для ridge-модели
19 Интерпретация значимых признаков
20 Итоги

library(tidyverse)
library(tidymodels)
library(tidytext)
library(workflowsets)
library(glmnet)
library(LiblineaR)
library(future)
library(broom)
library(knitr)

set.seed(06042025)
theme_set(theme_light())

1 Корпус A Small Collection of British Fiction.

Модели строятся через {tidymodels}: ridge-регрессия, lasso-регрессия и линейный SVM.

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

zip_url <- "https://github.com/locusclassicus/text_analysis_2024/raw/refs/heads/main/files/british_fiction.zip"
overview_url <- "https://raw.githubusercontent.com/locusclassicus/text_analysis_2024/main/files/overview.tsv"

dir.create("files", showWarnings = FALSE)
dir.create("files/british_fiction_raw", showWarnings = FALSE, recursive = TRUE)
dir.create("files/british_fiction", showWarnings = FALSE, recursive = TRUE)

if (!file.exists("files/british_fiction.zip")) {
  download.file(
    url = zip_url,
    destfile = "files/british_fiction.zip",
    mode = "wb"
  )
}

unzip(
  zipfile = "files/british_fiction.zip",
  exdir = "files/british_fiction_raw"
)

txt_files_raw <- list.files(
  "files/british_fiction_raw",
  pattern = "\\.txt$",
  recursive = TRUE,
  full.names = TRUE
)

file.copy(
  from = txt_files_raw,
  to = file.path("files/british_fiction", basename(txt_files_raw)),
  overwrite = TRUE
)

##  [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
## [16] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE

Исходный файл overview.tsv. Но при обычном чтении через read_tsv() что-то данные сильно поехали по столбцам, потому что внутри полей есть пробелы, а разделение не является надёжным для автоматического чтения.

overview_original_lines <- readLines(
  overview_url,
  warn = FALSE,
  encoding = "UTF-8"
)

original_overview_preview <- tibble(
  line_number = seq_len(min(8, length(overview_original_lines))),
  original_line = overview_original_lines[seq_len(min(8, length(overview_original_lines)))],
  tab_count = str_count(original_line, "\t")
)

original_overview_preview |>
  kable()

line_number	original_line	tab_count
1	textID author authorID title 1stPubl author_gender comment	5
2	1 Austen, Jane JA Emma 1815 1	6
3	2 Austen, Jane JA Pride 1813 1	6
4	3 Austen, Jane JA Sense 1811 1	6
5	4 Bronte, Anne AB Agnes Grey 1847 1	6
6	5 Bronte, Anne AB Tentant of Wildfell Hall 1848 1	6
7	6 Bronte, Charlotte CB Jane Eyre 1847 1	6
8	7 Bronte, Charlotte CB Professor 1845 1 date of publ not exact; published posthumously	6

# Тут видно, что таблица читается неправильно
overview_original_attempt <- tryCatch(
  read_tsv(overview_url, show_col_types = FALSE),
  error = function(e) tibble(error = e$message)
)

overview_original_attempt |>
  head(8) |>
  kable()

textID author	authorID	title	1stPubl	author_gender	comment
1	Austen, Jane	JA	Emma	1815	1
2	Austen, Jane	JA	Pride	1813	1
3	Austen, Jane	JA	Sense	1811	1
4	Bronte, Anne	AB	Agnes Grey	1847	1
5	Bronte, Anne	AB	Tentant of Wildfell Hall	1848	1
6	Bronte, Charlotte	CB	Jane Eyre	1847	1
7	Bronte, Charlotte	CB	Professor	1845	1 date of publ not exact; published posthumously
8	Bronte, Charlotte	CB	Villette	1853	1

names(overview_original_attempt)

## [1] "textID author" "authorID"      "title"         "1stPubl"      
## [5] "author_gender" "comment"

Так как в оригинальном файле данные могут съезжать при обычном чтении, я читаю его построчно и разбираю каждую строку регуляркой, выделяем textID, author, authorID, title, first_publication, author_gender, comment.

read_overview_fixed <- function(url) {
  overview_raw <- readLines(url, warn = FALSE, encoding = "UTF-8")
  overview_raw <- paste(overview_raw, collapse = "\n")
  overview_raw <- str_replace_all(overview_raw, "\r", "\n")

  overview_lines <- str_split(overview_raw, "\n")[[1]]
  overview_lines <- str_squish(overview_lines)
  overview_lines <- overview_lines[overview_lines != ""]

  if (length(overview_lines) == 1) {
    overview_lines <- str_split(
      overview_lines,
      "(?=\\s+[0-9]+\\s+[A-Z][A-Za-z]+,)"
    )[[1]]

    overview_lines <- str_squish(overview_lines)
    overview_lines <- overview_lines[overview_lines != ""]
  }

  overview_data <- overview_lines[-1]

  parsed <- str_match(
    overview_data,
    "^([0-9]+)\\s+(.+?)\\s+([A-Z]{2})\\s+(.+?)\\s+([0-9]{4})\\s+([0-9]+)(?:\\s+(.*))?$"
  )

  bad_lines <- overview_data[is.na(parsed[, 1])]

  if (length(bad_lines) > 0) {
    print(bad_lines)
    stop("ошибка")
  }

  overview <- tibble(
    textID = as.integer(parsed[, 2]),
    author = parsed[, 3],
    authorID = parsed[, 4],
    title = parsed[, 5],
    first_publication = as.integer(parsed[, 6]),
    author_gender = as.integer(parsed[, 7]),
    comment = parsed[, 8]
  ) |>
    mutate(
      comment = if_else(is.na(comment), "", comment)
    )

  return(overview)
}

overview <- read_overview_fixed(overview_url)

overview |>
  head(10) |>
  kable()

textID	author	authorID	title	first_publication	author_gender	comment
1	Austen, Jane	JA	Emma	1815	1
2	Austen, Jane	JA	Pride	1813	1
3	Austen, Jane	JA	Sense	1811	1
4	Bronte, Anne	AB	Agnes Grey	1847	1
5	Bronte, Anne	AB	Tentant of Wildfell Hall	1848	1
6	Bronte, Charlotte	CB	Jane Eyre	1847	1
7	Bronte, Charlotte	CB	Professor	1845	1	date of publ not exact; published posthumously
8	Bronte, Charlotte	CB	Villette	1853	1
9	Bronte, Emily	EB	Wuthering Heights	1847	1
10	Dickens, Charles	CD	Bleak House	1852	2	serial

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

names(overview)

## [1] "textID"            "author"            "authorID"         
## [4] "title"             "first_publication" "author_gender"    
## [7] "comment"

Проверяем, перед дельнейшими действиями author, title и first_publication.

3 Обзор метаданных

overview_author_counts <- overview |>
  count(author, sort = TRUE)

overview_author_counts |>
  kable()

author	n
Austen, Jane	3
Bronte, Charlotte	3
Dickens, Charles	3
Eliot, George	3
Thackeray, William Makepeace	3
Trollope, Antony	3
Bronte, Anne	2
Fielding, Henry	2
Richardson, Samuel	2
Sterne, Laurence	2
Bronte, Emily	1

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

overview |>
  count(author) |>
  ggplot(aes(reorder(author, n), n, fill = author)) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  xlab(NULL) +
  ylab("Количество произведений") +
  ggtitle("Количество произведений по авторам")

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

overview |>
  ggplot(aes(first_publication)) +
  geom_histogram(bins = 15) +
  xlab("Год первой публикации") +
  ylab("Количество произведений") +
  ggtitle("Распределение произведений по годам первой публикации")

Большая часть произведений корпуса относится к XIX веку, особенно к середине века. При этом в корпусе есть и более ранние тексты XVIII века, поэтому классификация может учитывать не только индивидуальный стиль автора, но и различия между литературными периодами.

4 Чтение текстов корпуса

Автор определяется по имени файла. Это надёжнее, чем соединять файлы с overview напрямую, потому что в именах файлов используются префиксы Austen, Dickens, ABronte и т.д., а в метаданных авторы обозначены через authorID.

stop_words_en <- stop_words |>
  filter(lexicon == "snowball") |>
  pull(word)

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

raw_texts <- tibble(path = txt_files) |>
  mutate(
    file = basename(path),
    text_id = str_remove(file, "\\.txt$"),
    author_prefix = str_extract(text_id, "^[^_]+"),
    title_short = str_remove(text_id, "^[^_]+_"),
    author = recode(
      author_prefix,
      "ABronte" = "Bronte, Anne",
      "Austen" = "Austen, Jane",
      "CBronte" = "Bronte, Charlotte",
      "Dickens" = "Dickens, Charles",
      "EBronte" = "Bronte, Emily",
      "Eliot" = "Eliot, George",
      "Fielding" = "Fielding, Henry",
      "Richardson" = "Richardson, Samuel",
      "Sterne" = "Sterne, Laurence",
      "Thackeray" = "Thackeray, William Makepeace",
      "Trollope" = "Trollope, Antony",
      .default = NA_character_
    ),
    text = map_chr(path, read_file)
  )

raw_texts |>
  count(author, sort = TRUE) |>
  kable()

author	n
Austen, Jane	3
Bronte, Charlotte	3
Dickens, Charles	3
Eliot, George	3
Thackeray, William Makepeace	3
Trollope, Antony	3
Bronte, Anne	2
Fielding, Henry	2
Richardson, Samuel	2
Sterne, Laurence	2
Bronte, Emily	1

Читаем сами тексты, а автор определяется по префиксу имени файла, потому что это надёжнее после проблемы с исходными метаданными.

unknown_authors <- raw_texts |>
  filter(is.na(author)) |>
  select(file, author_prefix)

unknown_authors |>
  kable()

file	author_prefix

if (any(is.na(raw_texts$author))) {
  stop("Есть файлы с неизвестным префиксом автора. Нужно добавить префикс в recode().")
}

Здесь проверяется, все ли файловые префиксы авторов были успешно распознаны и перекодированы в полные имена.

5 Проверка количества текстов и метаданных

tibble(
  source = c("Текстовые файлы корпуса", "Строки в исправленном overview"),
  n = c(length(txt_files), nrow(overview))
) |>
  kable()

source	n
Текстовые файлы корпуса	27
Строки в исправленном overview	27

Этот блок нужен для контроля данных: если число строк в overview и число текстовых файлов различается, модель всё равно строится по реально загруженным текстам корпуса.

6 Простые количественные признаки для EDA

text_stats <- raw_texts |>
  mutate(
    words = str_extract_all(str_to_lower(text), "[a-z']+"),
    word_count = map_int(words, length),
    unique_words = map_int(words, n_distinct),
    type_token_ratio = unique_words / word_count,
    avg_word_length = map_dbl(words, ~ mean(str_length(.x))),
    stopword_rate = map_dbl(words, ~ mean(.x %in% stop_words_en)),
    sentence_count = str_count(text, "[.!?]+"),
    avg_sentence_length = word_count / sentence_count
  ) |>
  select(
    file, text_id, author, title_short,
    word_count, unique_words, type_token_ratio,
    avg_word_length, stopword_rate,
    sentence_count, avg_sentence_length
  )

text_stats |>
  head(10) |>
  kable()

file	text_id	author	title_short	word_count	unique_words	type_token_ratio	avg_word_length	stopword_rate	sentence_count	avg_sentence_length
ABronte_Agnes.txt	ABronte_Agnes	Bronte, Anne	Agnes	69486	6981	0.1004663	4.211453	0.5328124	2655	26.17175
ABronte_Tenant.txt	ABronte_Tenant	Bronte, Anne	Tenant	171166	10598	0.0619165	4.181882	0.5323370	7908	21.64466
Austen_Emma.txt	Austen_Emma	Austen, Jane	Emma	161096	7279	0.0451842	4.255549	0.5473072	10566	15.24664
Austen_Pride.txt	Austen_Pride	Austen, Jane	Pride	122062	6380	0.0522685	4.397839	0.5506300	7132	17.11469
Austen_Sense.txt	Austen_Sense	Austen, Jane	Sense	119946	6408	0.0534240	4.385824	0.5516566	5920	20.26115
CBronte_Jane.txt	CBronte_Jane	Bronte, Charlotte	Jane	188302	12841	0.0681936	4.189239	0.5283003	10825	17.39510
CBronte_Professor.txt	CBronte_Professor	Bronte, Charlotte	Professor	89422	9768	0.1092349	4.372492	0.5132518	3725	24.00591
CBronte_Villette.txt	CBronte_Villette	Bronte, Charlotte	Villette	195755	14747	0.0753340	4.329565	0.5064903	10933	17.90497
Dickens_Bleak.txt	Dickens_Bleak	Dickens, Charles	Bleak	357638	15452	0.0432057	4.193204	0.5325469	24399	14.65790
Dickens_David.txt	Dickens_David	Dickens, Charles	David	366254	15093	0.0412091	4.093457	0.5216571	22855	16.02511

В этом блоке для каждого произведения считаются базовые стилометрические признаки: длина текста, лексическое разнообразие, средняя длина слова, доля стоп-слов и средняя длина предложения.

text_stats |>
  ggplot(aes(reorder(author, word_count, median), word_count, fill = author)) +
  geom_boxplot(show.legend = FALSE) +
  coord_flip() +
  xlab(NULL) +
  ylab("Количество слов") +
  ggtitle("Длина произведений по авторам")

Длина произведений заметно различается между авторами: самые объёмные тексты в корпусе связаны с Ричардсоном, Диккенсом и Теккереем. Это влияет на количество полученных отрывков: чем длиннее произведение, тем больше 2000-словных фрагментов оно даёт для модели.

text_stats |>
  ggplot(aes(reorder(author, avg_word_length, median), avg_word_length, fill = author)) +
  geom_boxplot(show.legend = FALSE) +
  coord_flip() +
  xlab(NULL) +
  ylab("Средняя длина слова") +
  ggtitle("Средняя длина слова по авторам")

Средняя длина слова различается не очень резко, но некоторые авторы всё же выделяются. Например, у Остин и Филдинга средняя длина слова выше, а у Ричардсона и Стерна ниже, поэтому этот признак может немного помогать классификации.

text_stats |>
  ggplot(aes(reorder(author, stopword_rate, median), stopword_rate, fill = author)) +
  geom_boxplot(show.legend = FALSE) +
  coord_flip() +
  xlab(NULL) +
  ylab("Доля стоп-слов") +
  ggtitle("Доля стоп-слов по авторам")

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

text_stats |>
  ggplot(aes(reorder(author, avg_sentence_length, median), avg_sentence_length, fill = author)) +
  geom_boxplot(show.legend = FALSE) +
  coord_flip() +
  xlab(NULL) +
  ylab("Средняя длина предложения") +
  ggtitle("Средняя длина предложения по авторам")

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

7 Биграммы для разведывательного анализа

bigrams <- raw_texts |>
  select(text_id, author, text) |>
  unnest_tokens(bigram, text, token = "ngrams", n = 2) |>
  separate(bigram, into = c("word1", "word2"), sep = " ") |>
  filter(!is.na(word1), !is.na(word2)) |>
  filter(!word1 %in% stop_words_en) |>
  filter(!word2 %in% stop_words_en) |>
  filter(!str_detect(word1, "[^a-z']")) |>
  filter(!str_detect(word2, "[^a-z']")) |>
  unite(bigram, word1, word2, sep = " ")

top_bigrams <- bigrams |>
  count(author, bigram, sort = TRUE) |>
  group_by(author) |>
  slice_max(n, n = 10) |>
  ungroup()

top_bigrams |>
  head(20) |>
  kable()

author	bigram	n
Austen, Jane	mr knightley	269
Austen, Jane	mr darcy	243
Austen, Jane	mrs weston	229
Austen, Jane	every thing	221
Austen, Jane	mrs jennings	199
Austen, Jane	mr elton	190
Austen, Jane	miss woodhouse	162
Austen, Jane	mr weston	143
Austen, Jane	mrs bennet	140
Austen, Jane	young man	138
Bronte, Anne	mr huntingdon	94
Bronte, Anne	mrs graham	91
Bronte, Anne	miss grey	75
Bronte, Anne	mrs huntingdon	67
Bronte, Anne	mr weston	62
Bronte, Anne	mr hargrave	61
Bronte, Anne	miss murray	56
Bronte, Anne	lord lowborough	50
Bronte, Anne	mr markham	46
Bronte, Anne	mr lawrence	40

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

top_bigrams |>
  mutate(bigram = reorder_within(bigram, n, author)) |>
  ggplot(aes(bigram, n, fill = author)) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  facet_wrap(~ author, scales = "free_y") +
  scale_x_reordered() +
  xlab(NULL) +
  ylab("Частота") +
  ggtitle("Самые частые содержательные биграммы по авторам")

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

8 Деление текстов на отрывки

Длинные произведения делятся на отрывки по 2000 слов. Неполные последние отрывки удаляются.

sample_size <- 2000

text_samples <- raw_texts |>
  select(text_id, author, title_short, text) |>
  mutate(words = str_extract_all(str_to_lower(text), "[a-z']+")) |>
  select(-text) |>
  unnest_longer(words, values_to = "word") |>
  group_by(text_id, author, title_short) |>
  mutate(
    word_number = row_number(),
    sample_number = ceiling(word_number / sample_size)
  ) |>
  ungroup() |>
  group_by(text_id, author, title_short, sample_number) |>
  summarise(
    sample_text = paste(word, collapse = " "),
    word_count = n(),
    .groups = "drop"
  ) |>
  filter(word_count >= sample_size)

sample_counts <- text_samples |>
  count(author, sort = TRUE)

sample_counts |>
  kable()

author	n
Richardson, Samuel	705
Dickens, Charles	414
Thackeray, William Makepeace	396
Trollope, Antony	374
Eliot, George	372
Fielding, Henry	242
Bronte, Charlotte	235
Austen, Jane	200
Bronte, Anne	119
Sterne, Laurence	114
Bronte, Emily	59

sample_counts |>
  ggplot(aes(reorder(author, n), n, fill = author)) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  xlab(NULL) +
  ylab("Количество отрывков") +
  ggtitle("Количество отрывков по авторам")

После деления текстов на фрагменты распределение стало ещё более неравномерным. Больше всего отрывков получилось у Ричардсона, Диккенса, Теккерея, Троллопа и Элиот, потому что их произведения в корпусе самые объёмные.

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

9.1 Частоты наиболее частотных слов

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

mfw <- text_samples |>
  unnest_tokens(word, sample_text) |>
  count(word, sort = TRUE) |>
  slice_head(n = 500) |>
  pull(word)

sample_word_tf <- text_samples |>
  mutate(sample_id = paste(text_id, sample_number, sep = "_")) |>
  select(sample_id, author, title_short, sample_number, sample_text) |>
  unnest_tokens(word, sample_text) |>
  filter(word %in% mfw) |>
  count(sample_id, author, title_short, sample_number, word) |>
  group_by(sample_id) |>
  mutate(freq = n / sum(n)) |>
  ungroup() |>
  select(-n) |>
  pivot_wider(
    names_from = word,
    values_from = freq,
    values_fill = 0,
    names_prefix = "w_"
  )

Здесь создаётся матрица частот 500 наиболее частотных слов: каждая строка соответствует отрывку, а каждый столбец — частотному слову.

9.2 Частоты наиболее частотных биграмм

mfb <- text_samples |>
  unnest_tokens(bigram, sample_text, token = "ngrams", n = 2) |>
  filter(!is.na(bigram)) |>
  count(bigram, sort = TRUE) |>
  slice_head(n = 100) |>
  pull(bigram)

sample_bigram_tf <- text_samples |>
  mutate(sample_id = paste(text_id, sample_number, sep = "_")) |>
  select(sample_id, sample_text) |>
  unnest_tokens(bigram, sample_text, token = "ngrams", n = 2) |>
  filter(bigram %in% mfb) |>
  mutate(bigram = str_replace_all(bigram, "\\s+", "_")) |>
  count(sample_id, bigram) |>
  group_by(sample_id) |>
  mutate(freq = n / sum(n)) |>
  ungroup() |>
  select(-n) |>
  pivot_wider(
    names_from = bigram,
    values_from = freq,
    values_fill = 0,
    names_prefix = "b_"
  )

СОздаем признаки по 100 наиболее частотным биграммам, чтобы добавить в модель устойчивые словосочетания.

9.3 Дополнительные стилометрические признаки

sample_extra <- text_samples |>
  mutate(
    sample_id = paste(text_id, sample_number, sep = "_"),
    words = str_extract_all(sample_text, "[a-z']+"),
    unique_words = map_int(words, n_distinct),
    type_token_ratio = unique_words / word_count,
    avg_word_length = map_dbl(words, ~ mean(str_length(.x))),
    stopword_rate = map_dbl(words, ~ mean(.x %in% stop_words_en))
  ) |>
  select(
    sample_id, unique_words, type_token_ratio,
    avg_word_length, stopword_rate
  )

corpus_model <- sample_word_tf |>
  left_join(sample_bigram_tf, by = "sample_id") |>
  left_join(sample_extra, by = "sample_id") |>
  select(-sample_id, -title_short, -sample_number) |>
  mutate(author = as.factor(author)) |>
  mutate(across(where(is.numeric), ~ replace_na(.x, 0)))

names(corpus_model) <- make.names(names(corpus_model), unique = TRUE)

dim(corpus_model)

## [1] 3230  605

Здесь частотные признаки объединяются с дополнительными количественными признаками, а имена столбцов приводятся к безопасному формату для recipe().

corpus_model |>
  count(author) |>
  kable()

author	n
Austen, Jane	200
Bronte, Anne	119
Bronte, Charlotte	235
Bronte, Emily	59
Dickens, Charles	414
Eliot, George	372
Fielding, Henry	242
Richardson, Samuel	705
Sterne, Laurence	114
Thackeray, William Makepeace	396
Trollope, Antony	374

Сколько обучающих отрывков каждого автора осталось в финальной таблице для моделирования.

10 Train/test split и кросс-валидация

set.seed(06042025)

data_split <- corpus_model |>
  initial_split(strata = author)

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

set.seed(06042025)

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

folds

Делим данные на обучающую и тестовую выборки, а затем создаются 5 фолдов для кросс-валидации с учётом авторов.

11 Предобработка

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

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

12 PCA для разведывательного анализа

pca_eda_rec <- base_rec |>
  step_pca(all_predictors(), num_comp = 4)

pca_trained <- pca_eda_rec |>
  prep(data_train)

pca_trained |>
  juice() |>
  ggplot(aes(PC1, PC2, color = author)) +
  geom_point(alpha = 0.7) +
  ggtitle("PCA: первые две главные компоненты")

PCA показывает, что тексты разных авторов частично пересекаются, но некоторые группы всё же образуют заметные области. Это значит, что стилометрические признаки содержат информацию об авторстве, хотя полное разделение авторов только по двум компонентам не получается.

13 Модели

Используются три модели:

lasso;
ridge;
линейный SVM.

Все модели задаются через {tidymodels}.

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

В этом блоке задаются три модели через интерфейс {tidymodels}: lasso, ridge и линейный SVM.

14 Workflow set

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

wflow_set

Здесь рецепты и модели объединяются в общий workflow_set, чтобы дальше сравнивать несколько вариантов одной командой.

15 Обучение и сравнение моделей

plan(sequential)

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

model_ranking <- rank_results(
  train_res,
  rank_metric = "accuracy",
  select_best = TRUE
)

model_ranking |>
  filter(.metric == "accuracy") |>
  select(wflow_id, .metric, mean, std_err, rank) |>
  arrange(rank) |>
  kable()

wflow_id	.metric	mean	std_err	rank
base_ridge	accuracy	0.9966925	0.0008290	1
base_svm	accuracy	0.9921572	0.0016460	2
base_lasso	accuracy	0.9904949	0.0010580	3
pca_lasso	accuracy	0.7157213	0.0125645	4
pca_svm	accuracy	0.6797638	0.0111725	5
pca_ridge	accuracy	0.6736004	0.0118084	6

В этом блоке все workflow обучаются на кросс-валидации и ранжируются по качеству, прежде всего по accuracy.

autoplot(train_res, metric = "accuracy") +
  theme(legend.position = "none") +
  geom_text(
    aes(y = mean - 2 * std_err, label = wflow_id),
    angle = 90,
    hjust = 1.5
  ) +
  ggtitle("Сравнение моделей по accuracy")

По accuracy лучше всего работают модели без PCA, особенно ridge, lasso и SVM на базовых признаках. Модели с PCA показывают качество заметно ниже, потому что при сокращении размерности теряется часть информации, важной для различения авторов.

autoplot(train_res, metric = "f_meas") +
  theme(legend.position = "none") +
  geom_text(
    aes(y = mean - 2 * std_err, label = wflow_id),
    angle = 90,
    hjust = 1.5
  ) +
  ggtitle("Сравнение моделей по F-measure")

График F-measure подтверждает тот же вывод, что и accuracy: лучшие результаты дают модели на исходных нормализованных признаках без PCA. Это особенно важно для многоклассовой классификации, потому что F-measure учитывает качество распознавания разных авторов, а не только общий процент правильных ответов.

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

best_wflow_id <- model_ranking |>
  filter(.metric == "accuracy") |>
  arrange(rank) |>
  slice(1) |>
  pull(wflow_id)

best_wflow_id

## [1] "base_ridge"

Выбираем лучшую модель по рангу accuracy, чтобы затем обучить её на финальном train/test-разбиении.

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

final_res <- train_res |>
  extract_workflow(best_wflow_id) |>
  finalize_workflow(best_results) |>
  last_fit(
    split = data_split,
    metrics = metric_set(accuracy, f_meas)
  )

final_metrics <- collect_metrics(final_res)

final_metrics |>
  kable()

.metric	.estimator	.estimate	.config
accuracy	multiclass	0.9975309	pre0_mod0_post0
f_meas	macro	0.9934176	pre0_mod0_post0

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

17 Confusion matrix

preds <- collect_predictions(final_res)

confusion <- preds |>
  conf_mat(
    truth = author,
    estimate = .pred_class
  )

confusion

##                               Truth
## Prediction                     Austen, Jane Bronte, Anne Bronte, Charlotte
##   Austen, Jane                           42            0                 0
##   Bronte, Anne                            0           26                 0
##   Bronte, Charlotte                       0            0                54
##   Bronte, Emily                           0            0                 0
##   Dickens, Charles                        0            0                 0
##   Eliot, George                           0            0                 0
##   Fielding, Henry                         0            0                 0
##   Richardson, Samuel                      0            0                 0
##   Sterne, Laurence                        0            0                 0
##   Thackeray, William Makepeace            0            0                 0
##   Trollope, Antony                        0            0                 0
##                               Truth
## Prediction                     Bronte, Emily Dickens, Charles Eliot, George
##   Austen, Jane                             0                0             0
##   Bronte, Anne                             0                0             0
##   Bronte, Charlotte                        1                0             0
##   Bronte, Emily                            9                0             0
##   Dickens, Charles                         0               98             1
##   Eliot, George                            0                0            90
##   Fielding, Henry                          0                0             0
##   Richardson, Samuel                       0                0             0
##   Sterne, Laurence                         0                0             0
##   Thackeray, William Makepeace             0                0             0
##   Trollope, Antony                         0                0             0
##                               Truth
## Prediction                     Fielding, Henry Richardson, Samuel
##   Austen, Jane                               0                  0
##   Bronte, Anne                               0                  0
##   Bronte, Charlotte                          0                  0
##   Bronte, Emily                              0                  0
##   Dickens, Charles                           0                  0
##   Eliot, George                              0                  0
##   Fielding, Henry                           72                  0
##   Richardson, Samuel                         0                187
##   Sterne, Laurence                           0                  0
##   Thackeray, William Makepeace               0                  0
##   Trollope, Antony                           0                  0
##                               Truth
## Prediction                     Sterne, Laurence Thackeray, William Makepeace
##   Austen, Jane                                0                            0
##   Bronte, Anne                                0                            0
##   Bronte, Charlotte                           0                            0
##   Bronte, Emily                               0                            0
##   Dickens, Charles                            0                            0
##   Eliot, George                               0                            0
##   Fielding, Henry                             0                            0
##   Richardson, Samuel                          0                            0
##   Sterne, Laurence                           34                            0
##   Thackeray, William Makepeace                0                          103
##   Trollope, Antony                            0                            0
##                               Truth
## Prediction                     Trollope, Antony
##   Austen, Jane                                0
##   Bronte, Anne                                0
##   Bronte, Charlotte                           0
##   Bronte, Emily                               0
##   Dickens, Charles                            0
##   Eliot, George                               0
##   Fielding, Henry                             0
##   Richardson, Samuel                          0
##   Sterne, Laurence                            0
##   Thackeray, William Makepeace                0
##   Trollope, Antony                           93

Таблица ошибок классификации.

confusion |>
  autoplot(type = "heatmap") +
  ggtitle("Confusion matrix") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

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

errors <- preds |>
  filter(author != .pred_class) |>
  count(author, .pred_class, sort = TRUE)

errors |>
  kable()

author	.pred_class	n
Bronte, Emily	Bronte, Charlotte	1
Eliot, George	Dickens, Charles	1

В этом блоке отдельно выводятся только ошибочные предсказания, чтобы их было удобнее интерпретировать в тексте отчёта.

18 ROC-AUC для ridge-модели

ROC-AUC считаем отдельно для ridge-модели, потому что SVM в выбранной настройке не всегда отдаёт вероятности классов.

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

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

ridge_metrics <- collect_metrics(ridge_res)

ridge_metrics |>
  kable()

.metric	.estimator	.estimate	.config
accuracy	multiclass	0.9975309	pre0_mod0_post0
f_meas	macro	0.9934176	pre0_mod0_post0
roc_auc	hand_till	1.0000000	pre0_mod0_post0

Здесь отдельно обучается ridge-модель, потому что для неё удобно считать ROC-AUC и затем интерпретировать коэффициенты.

ridge_preds <- collect_predictions(ridge_res)

prob_cols <- ridge_preds |>
  select(starts_with(".pred_"), -.pred_class) |>
  names()

ridge_auc <- ridge_preds |>
  roc_auc(
    truth = author,
    all_of(prob_cols)
  )

ridge_auc |>
  kable()

.metric	.estimator	.estimate
roc_auc	hand_till	1

В этом блоке рассчитывается ROC-AUC для многоклассовой ridge-модели по вероятностям классов.

roc_data <- ridge_preds |>
  roc_curve(
    truth = author,
    all_of(prob_cols)
  )

roc_data |>
  ggplot(aes(1 - specificity, sensitivity, color = .level)) +
  geom_abline(slope = 1, lty = 2, alpha = 0.8) +
  geom_path(linewidth = 1, alpha = 0.7) +
  labs(
    color = NULL,
    title = "ROC-кривые по авторам для ridge-модели"
  )

ROC-кривые для ridge-модели показывают очень высокое качество различения классов. Однако этот результат нужно интерпретировать осторожно, потому что модель обучалась на отрывках, и фрагменты одного произведения могли попасть и в обучение, и в тест.

19 Интерпретация значимых признаков

Для интерпретации признаков используется ridge-модель, потому что у неё можно посмотреть коэффициенты.

ridge_workflow <- extract_workflow(ridge_res)
final_ridge_model <- extract_fit_parsnip(ridge_workflow)

ridge_terms <- tidy(final_ridge_model, penalty = ridge_best$penalty)

top_terms <- ridge_terms |>
  filter(term != "(Intercept)") |>
  group_by(class) |>
  slice_max(abs(estimate), n = 10) |>
  ungroup() |>
  mutate(
    feature_type = case_when(
      str_starts(term, "w_") ~ "word",
      str_starts(term, "b_") ~ "bigram",
      TRUE ~ "numeric"
    ),
    term_clean = term |>
      str_remove("^w_") |>
      str_remove("^b_") |>
      str_replace_all("\\.", "'") |>
      str_replace_all("_", " ")
  )

top_terms |>
  select(class, term_clean, feature_type, estimate) |>
  head(30) |>
  kable()

class	term_clean	feature_type	estimate
Austen, Jane	every	word	0.1349403
Austen, Jane	very	word	0.1278887
Austen, Jane	soon	word	0.1149663
Austen, Jane	could	word	0.1074748
Austen, Jane	really	word	0.0917828
Austen, Jane	replied	word	0.0878148
Austen, Jane	thing	word	0.0808360
Austen, Jane	sister	word	0.0768422
Austen, Jane	don’t	word	-0.0767037
Austen, Jane	herself	word	0.0749420
Bronte, Anne	but	word	0.1966959
Bronte, Anne	but i	bigram	0.1239255
Bronte, Anne	or	word	0.1079242
Bronte, Anne	and	word	0.0968448
Bronte, Anne	too	word	0.0858095
Bronte, Anne	and then	bigram	0.0817228
Bronte, Anne	which	word	-0.0792534
Bronte, Anne	replied	word	0.0765956
Bronte, Anne	out	word	-0.0761877
Bronte, Anne	down	word	-0.0736665
Bronte, Charlotte	eye	word	0.1379043
Bronte, Charlotte	john	word	0.1270096
Bronte, Charlotte	seemed	word	0.1240639
Bronte, Charlotte	now	word	0.1104413
Bronte, Charlotte	unique words	numeric	0.1063370
Bronte, Charlotte	type token ratio	numeric	0.1061605
Bronte, Charlotte	i had	bigram	0.1028969
Bronte, Charlotte	yes	word	0.0967463
Bronte, Charlotte	among	word	-0.0909900
Bronte, Charlotte	i’m	word	-0.0894718

Здесь извлекаются коэффициенты ridge-модели и выбираются самые сильные признаки для каждого автора.

top_terms |>
  ggplot(aes(x = estimate, y = reorder(term_clean, abs(estimate)), fill = class)) +
  geom_col(show.legend = FALSE, alpha = 0.85) +
  facet_wrap(~ class, scales = "free_y") +
  labs(
    title = "Наиболее важные признаки ridge-модели",
    x = "Коэффициент",
    y = "Признак"
  ) +
  theme_minimal()

График показывает признаки, которые сильнее всего влияют на классификацию каждого автора в ridge-модели. Среди них есть частотные слова, биграммы и количественные признаки вроде unique_words и type_token_ratio, то есть модель опирается не только на отдельные слова, но и на более общие стилометрические характеристики текста.

20 Итоги

cat("\nЛучшая модель по accuracy:\n")

## 
## Лучшая модель по accuracy:

print(best_wflow_id)

## [1] "base_ridge"

cat("\nМетрики лучшей модели на тестовой выборке:\n")

## 
## Метрики лучшей модели на тестовой выборке:

print(final_metrics)

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

cat("\nМетрики ridge-модели, включая ROC-AUC:\n")

## 
## Метрики ridge-модели, включая ROC-AUC:

print(ridge_metrics)

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

cat("\nСамые частые ошибки классификации:\n")

## 
## Самые частые ошибки классификации:

print(errors)

## # A tibble: 2 × 3
##   author        .pred_class           n
##   <fct>         <fct>             <int>
## 1 Bronte, Emily Bronte, Charlotte     1
## 2 Eliot, George Dickens, Charles      1

cat("\nСамые важные признаки ridge-модели:\n")

## 
## Самые важные признаки ridge-модели:

print(top_terms |> select(class, term_clean, feature_type, estimate))

## # A tibble: 110 × 4
##    class        term_clean feature_type estimate
##    <chr>        <chr>      <chr>           <dbl>
##  1 Austen, Jane every      word           0.135 
##  2 Austen, Jane very       word           0.128 
##  3 Austen, Jane soon       word           0.115 
##  4 Austen, Jane could      word           0.107 
##  5 Austen, Jane really     word           0.0918
##  6 Austen, Jane replied    word           0.0878
##  7 Austen, Jane thing      word           0.0808
##  8 Austen, Jane sister     word           0.0768
##  9 Austen, Jane don't      word          -0.0767
## 10 Austen, Jane herself    word           0.0749
## # ℹ 100 more rows

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

Confusion matrix показывает, какие авторы чаще всего смешиваются между собой. Если модель ошибается между авторами одного периода или близкой литературной традиции, это можно интерпретировать как признак стилевой близости. При этом результаты сложно интерпретировать однозначно, так как классификация строится по отрывкам, поэтому фрагменты одного произведения могут попасть и в обучающую, и в тестовую выборку. Из-за этого метрики могут быть завышены. Можно сказать, что модель хорошо различает авторов в рамках данного корпуса и выбранного способа разбиения текстов на фрагменты.

Классификация британской прозы

Итыгилова Юмжит