British Fiction

Предисловие

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

Часть 1. Ошибки.

1. Подготовка

Загружаем библиотеки, только необходимые и достаточные :)

library(tidyverse)
library(tidytext)
library(stopwords)
library(textstem)
library(ggplot2)
library(ggrepel)
library(tidymodels) 
library(patchwork)
library(udpipe)
library(themis)
library(vip)

Переходим к сборке корпуса. Читаем .tsv-файл. Мне пришлось эксплицитно указывать названия столбцов, так как при чтении “textID” и “author” сливались в один.

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

Немного неприятная часть - указание соответствия между строкой таблицы и txt-файлом из папки (вручную). Почему вручную? Потому что текстов всего 27 штук, а перестановки с первого взгляда были неочевидны.

corpus_raw$text[1] <- "british_fiction/Austen_Emma.txt"
corpus_raw$text[2] <- "british_fiction/Austen_Pride.txt"
corpus_raw$text[3] <- "british_fiction/Austen_Sense.txt"
corpus_raw$text[4] <- "british_fiction/ABronte_Agnes.txt"
corpus_raw$text[5] <- "british_fiction/ABronte_Tenant.txt"
corpus_raw$text[6] <- "british_fiction/CBronte_Jane.txt"
corpus_raw$text[7] <- "british_fiction/CBronte_Professor.txt"
corpus_raw$text[8] <- "british_fiction/CBronte_Villette.txt"
corpus_raw$text[9] <- "british_fiction/EBronte_Wuthering.txt"
corpus_raw$text[10] <- "british_fiction/Dickens_Bleak.txt"
corpus_raw$text[11] <- "british_fiction/Dickens_David.txt"
corpus_raw$text[12] <- "british_fiction/Dickens_Hard.txt"
corpus_raw$text[13] <- "british_fiction/Eliot_Adam.txt"
corpus_raw$text[14] <- "british_fiction/Eliot_Middlemarch.txt"
corpus_raw$text[15] <- "british_fiction/Eliot_Mill.txt"
corpus_raw$text[16] <- "british_fiction/Fielding_Joseph.txt"
corpus_raw$text[17] <- "british_fiction/Fielding_Tom.txt"
corpus_raw$text[18] <- "british_fiction/Richardson_Clarissa.txt"
corpus_raw$text[19] <- "british_fiction/Richardson_Pamela.txt"
corpus_raw$text[20] <- "british_fiction/Sterne_Tristram.txt"
corpus_raw$text[21] <- "british_fiction/Sterne_Sentimental.txt"
corpus_raw$text[22] <- "british_fiction/Trollope_Prime.txt"
corpus_raw$text[23] <- "british_fiction/Trollope_Barchester.txt"
corpus_raw$text[24] <- "british_fiction/Trollope_Phineas.txt"
corpus_raw$text[25] <- "british_fiction/Thackeray_Vanity.txt"
corpus_raw$text[26] <- "british_fiction/Thackeray_Pendennis.txt"
corpus_raw$text[27] <- "british_fiction/Thackeray_Barry.txt"

Подгружаем нужный текст по своему пути в нашу таблицу-корпус

corpus_raw <- corpus_raw |> 
  mutate(
    text_content = map_chr(text, read_file)
  )

2. Предварительная обработка текста

#токенизируем
corpus_tokens <- corpus_raw |>
  mutate(doc_id = row_number()) |> 
  unnest_tokens(word, text_content, 
                token = "words", 
                strip_punct = TRUE,
                to_lower = TRUE)

#убираем стоп-слова
en_stopwords <- stopwords(language = "en", source = "stopwords-iso")
corpus_clean <- corpus_tokens |> 
  filter(!word %in% en_stopwords)

#лемматизируем
corpus_lemmatized <- corpus_clean |> 
  mutate(
    lemma = lemmatize_words(word),
  )

corpus_lemmatized_text <- corpus_lemmatized |>
  group_by(textID, author, authorID, title, `1stPubl`, author_gender) |>
  summarise(
    lemma_text = paste(lemma, collapse = " "),
    .groups = "drop"
  )

corpus <- corpus_raw |>
  dplyr::select(textID, author, authorID, title, `1stPubl`, author_gender, text_content) |>
  left_join(corpus_lemmatized_text, by = c("textID", "author", "authorID", "title", "1stPubl", "author_gender"))

3. Извлечение количественных лингвистических признаков

Синтаксические признаки. мы обязательно будем считать на “сыром” тексте. А лексические на “чистом”.

quantitative_features <- corpus |> 
  mutate(
    n_chars = str_count(lemma_text, "."),
    n_words = str_count(lemma_text, "\\S+"),
    n_sentences = str_count(text_content, "[.!?;:][\\s\\n]"), #обязательно на сыром тексте
    avg_sent_len = n_words / n_sentences,
    punct_count = str_count(text_content, "[[:punct:]]"), #обязательно на сыром тексте
    punct_ratio = punct_count / n_words,
    exclamation_count = str_count(text_content, "!"), #обязательно на сыром тексте
    question_count = str_count(text_content, "\\?"), #обязательно на сыром тексте
    avg_word_len = n_chars / n_words) |> 
  dplyr::select(textID, author, authorID, title, `1stPubl`, author_gender, n_words, n_sentences,
  avg_sent_len, punct_ratio, exclamation_count, question_count, avg_word_len)

quantitative_features_copy <- quantitative_features #на всякий пожарный

Удивительным и невероятным образом в этой работе мне пришлось делать много указаний “в лоб”; здесь пришлось указать, что select берется именно из dplyr’a, иначе не работало.

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

avg_by_author <- quantitative_features |> 
  group_by(authorID) |> 
  summarise(
    avg_n_words = mean(n_words),
    avg_avg_word_len = mean(avg_word_len),
    avg_n_sentences = mean(n_sentences),
    avg_avg_sent_len = mean(avg_sent_len),
    avg_exclamation = mean(exclamation_count),
    avg_question = mean(question_count),
  ) 

Построим графики для среднего количества слов и средней длины слова:

p_avg_n_words <- ggplot(avg_by_author, aes(x = authorID, y = avg_n_words, fill = authorID)) +
  geom_col(alpha = 0.8) +
  geom_text(aes(label = round(avg_n_words, 0)), vjust = -0.5, size = 3) +
  scale_fill_viridis_d(option = "plasma", guide = "none") +
  theme_minimal() +
  labs(title = "Среднее количество слов",
       x = "authorID", 
       y = "среднее кол-во слов на текст") +
  theme(plot.title = element_text(hjust = 0.5, face = "bold"),
        axis.text.x = element_text(angle = 45, hjust = 1))

p_avg_avg_word_len <- ggplot(avg_by_author, aes(x = authorID, y = avg_avg_word_len, fill = authorID)) +
  geom_col(alpha = 0.8) +
  geom_text(aes(label = round(avg_avg_word_len, 0)), vjust = -0.5, size = 3) +
  scale_fill_viridis_d(option = "plasma", guide = "none") +
  theme_minimal() +
  labs(title = "Средняя длина слова",
       x = "authorID", 
       y = "средняя длина слова") +
  theme(plot.title = element_text(hjust = 0.5, face = "bold"),
        axis.text.x = element_text(angle = 45, hjust = 1))

p_avg_n_words + p_avg_avg_word_len

Невооруженным глазом видно, что Samuel Richardson в прямом смысле многословен - 194404 слова. Мы, конечно, могли это предсказать, посмотрев на размер файлов с текстами в папке, произведение “Clarissa, or, the History of a Young Lady” - самое тяжелое, аж 5 MB.

Anne Bronte - самый “молчаливый” автор. Среднее количество слов в его произведениях - около 34,5 тысяч.

А вот средняя длина слова у всех авторов колеблется на уровне 7-8 символов. P.S.: Если посчитать на сыром корпусе, то значение будет 5-6 симоволо и совпадет с тем, что выдает гугл по запросу “средняя длина слова в английском”. Тут, как в задачах на доказательство на геометрии, - ЧТД, “что и требовалось доказать”.

Графики для среднего количества предложений и средней длины кажутся уже интереснее.

p_avg_n_sentences <- ggplot(avg_by_author, aes(x = authorID, y = avg_n_sentences, fill = authorID)) +
  geom_col(alpha = 0.8) +
  geom_text(aes(label = round(avg_n_sentences, 0)), vjust = -0.5, size = 3) +
  scale_fill_viridis_d(option = "plasma", guide = "none") +
  theme_minimal() +
  labs(title = "Среднее количество предложений",
       x = "authorID", 
       y = "кол-во предложений на текст") +
  theme(plot.title = element_text(hjust = 0.5, face = "bold"),
        axis.text.x = element_text(angle = 45, hjust = 1))

p_avg_avg_sent_len <- ggplot(avg_by_author, aes(x = authorID, y = avg_avg_sent_len, fill = authorID)) +
  geom_col(alpha = 0.8) +
  geom_text(aes(label = round(avg_avg_sent_len, 1)), vjust = -0.5, size = 3) +
  scale_fill_viridis_d(option = "plasma", guide = "none") +
  theme_minimal() +
  labs(title = "Средняя длина предложения",
       x = "authorID", 
       y = "средняя длина предложения") +
  theme(plot.title = element_text(hjust = 0.5, face = "bold"),
        axis.text.x = element_text(angle = 45, hjust = 1))

p_avg_n_sentences + p_avg_avg_sent_len

Заметное лидерство Samuel Richardson в количестве предложений на текст очевидно вытекает из предыдущего факта о многословности. Здесь интересно, что значения начинают чуть-чуть расходиться (по сравнению с предыдущими графиками). Теперь только 2 автора, у которых параметр “в одной тысяче”: можно спутать Charlotte Bronte и Henry Fielding (среднее значение кол-ва предложений на текст ~ 10750) и Antony Trollope и William Makepeace Thackeray (~13750).

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

И поздравляем Laurence Sterne со званием “сочинятеля самых длинных предложений”. Теперь понятно, почему их мало. Думаю, он просто уставал их такие длинные составлять:)

Последнее сравнение - количество восклицаний и вопрошений.

p_avg_exclamation <- ggplot(avg_by_author, aes(x = authorID, y = avg_exclamation, fill = authorID)) +
  geom_col(alpha = 0.8) +
  geom_text(aes(label = round(avg_exclamation, 0)), vjust = -0.5, size = 3) +
  scale_fill_viridis_d(option = "plasma", guide = "none") +
  theme_minimal() +
  labs(title = "Среднее количество восклицаний",
       x = "authorID", 
       y = "среднее кол-во восклицаний на текст") +
  theme(plot.title = element_text(hjust = 0.5, face = "bold"),
        axis.text.x = element_text(angle = 45, hjust = 1))

p_avg_question <- ggplot(avg_by_author, aes(x = authorID, y = avg_question, fill = authorID)) +
  geom_col(alpha = 0.8) +
  geom_text(aes(label = round(avg_question, 0)), vjust = -0.5, size = 3) +
  scale_fill_viridis_d(option = "plasma", guide = "none") +
  theme_minimal() +
  labs(title = "Среднее количество вопросов",
       x = "authorID", 
       y = "среднее кол-во вопросов на текст") +
  theme(plot.title = element_text(hjust = 0.5, face = "bold"),
        axis.text.x = element_text(angle = 45, hjust = 1))

p_avg_exclamation + p_avg_question

Если восклицать 5507 раз и вопрошать 3479 раз, можно стать Laurence Sterne. Эти два криетерия однозначно полезны для оперделения авторства. Точнее - “стёрности”.

4. Части речи

Посмотрим на частеречный состав текстов авторов. Для ускорения работы будем считать статистику по 500 словам (от 500-го до 1000-го, чтобы не захваатывать самое начало, где название/автор и другой метатекст).

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

get_pos <- function(text, id, author) {
  words <- unlist(strsplit(text, "\\s+"))
  anno <- udpipe_annotate(ud_model, paste(words[500:1000], collapse = " ")) |> 
    as.data.frame()
  anno |> 
    group_by(upos) |> 
    summarise(count = n(), .groups = "drop") |>
    mutate(textID = id, authorID = author, prop = count / sum(count))
}

pos_stats <- pmap_dfr(list(corpus$lemma_text, corpus$textID, corpus$authorID), get_pos)

pos_wide <- pos_stats |> 
  dplyr::select(textID, authorID, upos, prop) |>
  pivot_wider(names_from = upos, values_from = prop, values_fill = 0, names_prefix = "pos_")

quantitative_features <- quantitative_features |> left_join(pos_wide, by = c("textID", "authorID"))

Построим график по пяти основным частям речи.

pos_stats |>
  filter(upos %in% c("NOUN", "VERB", "ADJ", "ADV", "PRON")) |>
  ggplot(aes(x = authorID, y = prop, fill = upos)) +
  geom_col(position = "fill", alpha = 0.8) +
  scale_fill_viridis_d(name = "Часть речи") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(title = "Распределение частей речи по авторам",
       subtitle = "Слова 500-1000 (лемматизированный текст)",
       x = "Автор", y = "Доля")

George Eliot обладает заметной любовью к использованию местоимений и… на этом видимые отличия частеречного профиля заканчиваются.

5. PCA

Шлифанем наше исследование структурных и лексических признаков визуализацией PCA.

pca_data <- quantitative_features |> 
  dplyr::select(where(is.numeric), authorID) |>  
  na.omit()

pca_result <- prcomp(
  pca_data |> 
    dplyr::select(-authorID), 
  scale. = TRUE)

pca_result$x |> 
  as.data.frame() |> 
  bind_cols(authorID = pca_data$authorID) |>  
  ggplot(aes(x = PC1, y = PC2, color = authorID, label = authorID)) +
  geom_point(size = 4, alpha = 0.7) +
  geom_text_repel(show.legend = FALSE) +
  scale_color_viridis_d(option = "plasma") +
  theme_minimal() +
  labs(title = "PCA",
       x = paste0("PC1 (", round(summary(pca_result)$importance[2,1]*100, 1), "%)"),
       y = paste0("PC2 (", round(summary(pca_result)$importance[2,2]*100, 1), "%)"))

Нет слов, одни эмоции. Будет тяжело. Наши признаки имеют низкую дискриминативную способность.

Да, язык всех произведений - английский, год первой публикации - в промежутке с середины XVIII до середины XIX века, текстов всего 27 штук. Тексты действительно могут быть друг на друга похожи. Но не надо сдаваться. Попробуем построить модель.

6. Построение модели

Первым делом убираем из данных нечисловые параметры и textID.

model_data <- quantitative_features |>
  select(-author, -title, -`1stPubl`, -author_gender, -textID)

Самое время обратить внимание на количество текстов.

author_counts <- table(model_data$authorID)
author_counts

AB AT CB CD EB GE HF JA LS SR WT 
 2  3  3  3  1  3  2  3  2  2  3 

Эмпирическим путем было выяснено, что нам надо объединить авторов с количеством текстов <3. В противном случае в фолде может не оказаться некоторого класса и мы поймаем ошибку. Поэтому объединим “редких” авторов в rare_authors.

rare_authors <- names(author_counts)[author_counts < 3]
model_data$authorID <- as.character(model_data$authorID)
model_data$authorID[model_data$authorID %in% rare_authors] <- "Other"
model_data$authorID <- as.factor(model_data$authorID)

model_data <- na.omit(model_data)

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

set.seed(22052026)
data_split <- initial_split(model_data, prop = 0.8, strata = authorID)
train_data <- training(data_split)
test_data <- testing(data_split)

set.seed(22052026)
folds <- vfold_cv(train_data, v = 5, strata = authorID)

Составляем рецепт и выбираем модели. Я выбрала Лассо, Ридж и метод опорных векторов (тоже на основе эмпирических данных, по-другому просто не работало).

base_rec <- recipe(authorID ~ ., data = train_data) |>
  step_normalize(all_numeric_predictors()) |>
  step_zv(all_predictors())

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

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

svm_spec <- svm_linear(cost = tune()) |>
  set_engine("LiblineaR") |>
  set_mode("classification")

Составляем несколько воркфлоу и проводим кросс-валидацию.

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

set.seed(22052026)
train_res <- wflow_set |>
  workflow_map(
    resamples = folds,
    grid = 5,
    metrics = metric_set(accuracy, f_meas),
    control = control_grid(verbose = FALSE)
  )

Сравним модели по производительности.

comparison <- rank_results(train_res, rank_metric = "f_meas", select_best = TRUE)
comparison

# A tibble: 6 × 9
  wflow_id   .config        .metric  mean std_err     n preprocessor model  rank
  <chr>      <chr>          <chr>   <dbl>   <dbl> <int> <chr>        <chr> <int>
1 base_ridge pre0_mod1_pos… accura… 0.667   0.333     3 recipe       mult…     1
2 base_ridge pre0_mod1_pos… f_meas  1       0         2 recipe       mult…     1
3 base_lasso pre0_mod1_pos… accura… 0.667   0.333     3 recipe       mult…     2
4 base_lasso pre0_mod1_pos… f_meas  1       0         2 recipe       mult…     2
5 base_svm   pre0_mod1_pos… accura… 0.25    0.190     5 recipe       svm_…     3
6 base_svm   pre0_mod1_pos… f_meas  0.403   0.299     3 recipe       svm_…     3

autoplot(train_res, metric = "f_meas") +
  theme_light() +
  labs(title = "Сравнение по F-мере") + #смотрим по f-мере, а не по accuracy, потому что так точнее на маленьких данных
  scale_y_continuous(limits = c(0, 1))

Лучше всего справились Ridge и Lasso. Возьмем Rigle, раз она номинально первая. Обратившись к источнику Машинное обучение и Data Science (Часть 10): Гребневая регрессия, я осознала, что этот результат объясним:

• Мои признаки коррелируют друг с другом

• Признаков больше, чем наблюдений (после объединения авторов, их осталось 7), и они все принимаются во внимание

Значит будем пользоваться Ridge. Сохраняем информацию о ней в отдельные переменные.

best_model_id <- comparison |>
  filter(rank == 1) |>
  pull(wflow_id) |>
  first()

best_results <- train_res |>
  extract_workflow_set_result(best_model_id) |>
  select_best(metric = "f_meas")

7. Оценка результатов

Посмотрим, как модель отработает на тестовых данных

final_workflow <- train_res |>
  extract_workflow(best_model_id) |>
  finalize_workflow(best_results)

final_fit <- final_workflow |>
  last_fit(
    split = data_split,
    metrics = metric_set(accuracy, f_meas, precision, recall)
  )

test_metrics <- collect_metrics(final_fit)
print(test_metrics)

# A tibble: 4 × 4
  .metric   .estimator .estimate .config        
  <chr>     <chr>          <dbl> <chr>          
1 accuracy  multiclass     0.25  pre0_mod0_post0
2 f_meas    macro          0.4   pre0_mod0_post0
3 precision macro          0.25  pre0_mod0_post0
4 recall    macro          0.143 pre0_mod0_post0

Ну что же, accuracy = 25% говорит о том, что наша модель все-таки лучше угадывания! При 7 группах (авторах) шанс угадать - около 14%…

Построим матрицу ошибок классификации.

test_predictions <- collect_predictions(final_fit)

autoplot(
  conf_mat(test_predictions, truth = authorID, estimate = .pred_class),
  type = "heatmap"
) +
  scale_fill_gradientn(
    colors = c("#440154", "#414487", "#2A788E", "#22A884", "#7AD151", "#FDE725"),
    name = "Количество"
  )+
  labs(title = "Матрица ошибок классификации авторов")

Нерадужно. Модель всё валит в Other. Ну а что поделать?

• Там целых 4 автора, получается 9 текстов против 3 у каждого отдельного автора.

• Думаю, это также может быть связано, что Laurence Sterne попал в Other, а несколько признаков целятся в него однозначно.

Так, конечно, не пойдет.

Часть 2. Прозрение.

Ну если текстов мало. Наверное, тогда их надо сделать больше? Разделим текст на фрагменты по 10 тысяч знаков и создадим для нх отдельный корпус corpus_fragments

1. Подготовка корпуса

corpus_fragments <- map_dfr(1:nrow(corpus_raw), function(i) {
  text_content <- corpus_raw$text_content[i]
  text_length <- nchar(text_content)
  n_fragments <- ceiling(text_length / 10000)
  
  map_dfr(1:n_fragments, function(j) {
    start_pos <- (j - 1) * 10000 + 1
    end_pos <- min(j * 10000, text_length)
    
    tibble(
      textID = corpus_raw$textID[i],
      authorID = corpus_raw$authorID[i],
      fragmentID = j,
      text_content = substr(text_content, start_pos, end_pos)
    )
  })
})

corpus_fragments <- corpus_fragments |>
  mutate(
    unique_id = paste(textID, fragmentID, sep = "_"),
    author = map_chr(textID, ~ as.character(corpus_raw$author[corpus_raw$textID == .x])),
    title = map_chr(textID, ~ as.character(corpus_raw$title[corpus_raw$textID == .x])),
    `1stPubl` = map_dbl(textID, ~ corpus_raw$`1stPubl`[corpus_raw$textID == .x]),
    author_gender = map_chr(textID, ~ as.character(corpus_raw$author_gender[corpus_raw$textID == .x]))
  ) |>
  select(unique_id, textID, fragmentID, author, authorID, title, 
         `1stPubl`, author_gender, text_content)

2. Предварительная обработка текста

Теперь нам нужно везде, где мы раньше использовали нефрагментированный корпус, заменить его на corpus_fragments.

corpus_tokens <- corpus_fragments |>
  unnest_tokens(word, text_content, 
                token = "words", 
                strip_punct = TRUE,
                to_lower = TRUE)

en_stopwords <- stopwords(language = "en", source = "stopwords-iso")
corpus_clean <- corpus_tokens |> 
  filter(!word %in% en_stopwords)

corpus_lemmatized <- corpus_clean |> 
  mutate(
    lemma = lemmatize_words(word),
  )

corpus_lemmatized_text <- corpus_lemmatized |>
  group_by(unique_id, textID, fragmentID, author, authorID, title, `1stPubl`, author_gender) |>
  summarise(
    lemma_text = paste(lemma, collapse = " "),
    .groups = "drop"
  )

corpus <- corpus_fragments |>
  select(unique_id, textID, fragmentID, author, authorID, title, `1stPubl`, author_gender, text_content) |>
  left_join(corpus_lemmatized_text, by = c("unique_id", "textID", "fragmentID", "author", "authorID", "title", "1stPubl", "author_gender"))

quantitative_features <- corpus |> 
  mutate(
    n_chars = str_count(lemma_text, "."),
    n_words = str_count(lemma_text, "\\S+"),
    n_sentences = str_count(text_content, "[.!?;:][\\s\\n]"),
    avg_sent_len = n_words / n_sentences,
    punct_count = str_count(text_content, "[[:punct:]]"),
    punct_ratio = punct_count / n_words,
    exclamation_count = str_count(text_content, "!"),
    question_count = str_count(text_content, "\\?"),
    avg_word_len = n_chars / n_words) |> 
  select(unique_id, textID, fragmentID, author, authorID, title, `1stPubl`, author_gender, n_words, n_sentences,
         avg_sent_len, punct_ratio, exclamation_count, question_count, avg_word_len)

quantitative_features_copy <- quantitative_features

avg_by_author <- quantitative_features |> 
  group_by(authorID) |> 
  summarise(
    avg_n_words = mean(n_words),
    avg_avg_word_len = mean(avg_word_len),
    avg_n_sentences = mean(n_sentences),
    avg_avg_sent_len = mean(avg_sent_len),
    avg_exclamation = mean(exclamation_count),
    avg_question = mean(question_count),
  )

3. Структурные и лексические признаки

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

Я считаю, что комментировать эти графики с точки зрения стилистических особенностей авторов было бы неправильно, так как с переходом на corpus_fragments - изменился размер выборки - мы берем разные отрывки текста, могут быть внутритекстовые различия (например, в начале текста чаще встречаются описания, а в середине - диалоги)

Просто отметим, что заметны изменения.

4. Части речи

Далее вычисляем статистику для частей речи, так же с 500 до 1000 слова, но теперь не для 27 текстов, а для 3569 фрагментов :) Код остался без изменений, поэтому его я скрою.

Downloading udpipe model from https://raw.githubusercontent.com/jwijffels/udpipe.models.ud.2.5/master/inst/udpipe-ud-2.5-191206/english-ewt-ud-2.5-191206.udpipe to /Users/kulyatinakatya/Desktop/r/hack/english-ewt-ud-2.5-191206.udpipe

 - This model has been trained on version 2.5 of data from https://universaldependencies.org

 - The model is distributed under the CC-BY-SA-NC license: https://creativecommons.org/licenses/by-nc-sa/4.0

 - Visit https://github.com/jwijffels/udpipe.models.ud.2.5 for model license details.

 - For a list of all models and their licenses (most models you can download with this package have either a CC-BY-SA or a CC-BY-SA-NC license) read the documentation at ?udpipe_download_model. For building your own models: visit the documentation by typing vignette('udpipe-train', package = 'udpipe')

Downloading finished, model stored at '/Users/kulyatinakatya/Desktop/r/hack/english-ewt-ud-2.5-191206.udpipe'

По частям речи тоже есть изменения, но не такие заметные. George Eliot больше не так любит местоимения, его перегнал Samuel Richardson, который в прошлый раз был на 2 месте.

5. PCA

Теперь самое интересное, смотрим на PCA.

pca_data <- quantitative_features |> 
  select(where(is.numeric), authorID) |>  
  na.omit()

pca_result <- prcomp(
  pca_data |> 
    select(-authorID), 
  scale. = TRUE)

pca_result$x |> 
  as.data.frame() |> 
  bind_cols(authorID = pca_data$authorID) |>  
  ggplot(aes(x = PC1, y = PC2, color = authorID, label = authorID)) +
  geom_point(size = 4, alpha = 0.7) +
  geom_text_repel(show.legend = FALSE) +
  scale_color_viridis_d(option = "plasma") +
  theme_minimal() +
  labs(title = "PCA",
       x = paste0("PC1 (", round(summary(pca_result)$importance[2,1]*100, 1), "%)"),
       y = paste0("PC2 (", round(summary(pca_result)$importance[2,2]*100, 1), "%)"))

Warning: ggrepel: 3541 unlabeled data points (too many overlaps). Consider
increasing max.overlaps

Ну мёд! В этот раз все точно будет хорошо!

6. Построение модели

Переходим к построению модели. Опять берем ridge, lasso, svm и в base_rec добавляем апсемплинг.

→ A | warning: While computing multiclass `precision()`, some levels had no predicted events
               (i.e. `true_positive + false_positive = 0`).
               Precision is undefined in this case, and those levels will be removed from the
               averaged result.
               Note that the following number of true events actually occurred for each
               problematic event level:
               'AB': 20, 'AT': 63, 'CB': 39, 'CD': 69, 'EB': 10, 'GE': 62, 'JA': 41, 'LS': 24,
               'SR': 117, 'WT': 67

There were issues with some computations   A: x1

→ B | warning: While computing multiclass `precision()`, some levels had no predicted events
               (i.e. `true_positive + false_positive = 0`).
               Precision is undefined in this case, and those levels will be removed from the
               averaged result.
               Note that the following number of true events actually occurred for each
               problematic event level:
               'AB': 25, 'AT': 61, 'CB': 36, 'CD': 73, 'EB': 8, 'GE': 60, 'HF': 53, 'JA': 35,
               'SR': 119, 'WT': 77

There were issues with some computations   A: x1
→ C | warning: While computing multiclass `precision()`, some levels had no predicted events
               (i.e. `true_positive + false_positive = 0`).
               Precision is undefined in this case, and those levels will be removed from the
               averaged result.
               Note that the following number of true events actually occurred for each
               problematic event level:
               'AB': 15, 'CB': 49, 'CD': 76, 'EB': 14, 'GE': 72, 'HF': 41, 'JA': 30, 'LS': 14,
               'SR': 123, 'WT': 66
There were issues with some computations   A: x1
→ D | warning: While computing multiclass `precision()`, some levels had no predicted events
               (i.e. `true_positive + false_positive = 0`).
               Precision is undefined in this case, and those levels will be removed from the
               averaged result.
               Note that the following number of true events actually occurred for each
               problematic event level:
               'AB': 16, 'AT': 66, 'CB': 48, 'CD': 73, 'EB': 12, 'GE': 76, 'JA': 37, 'LS': 17,
               'SR': 121, 'WT': 75
There were issues with some computations   A: x1
There were issues with some computations   A: x1   B: x1   C: x1   D: x1
→ E | warning: While computing multiclass `precision()`, some levels had no predicted events
               (i.e. `true_positive + false_positive = 0`).
               Precision is undefined in this case, and those levels will be removed from the
               averaged result.
               Note that the following number of true events actually occurred for each
               problematic event level:
               'AB': 29, 'AT': 60, 'CB': 35, 'CD': 74, 'EB': 11, 'GE': 65, 'HF': 45, 'JA': 34,
               'LS': 16, 'SR': 127
There were issues with some computations   A: x1   B: x1   C: x1   D: x1
There were issues with some computations   A: x1   B: x1   C: x1   D: x1   E: x1

# A tibble: 6 × 9
  wflow_id   .config        .metric  mean std_err     n preprocessor model  rank
  <chr>      <chr>          <chr>   <dbl>   <dbl> <int> <chr>        <chr> <int>
1 base_lasso pre0_mod1_pos… accura… 1     0           5 recipe       mult…     1
2 base_lasso pre0_mod1_pos… f_meas  1     0           5 recipe       mult…     1
3 base_svm   pre0_mod1_pos… accura… 1     0           5 recipe       svm_…     2
4 base_svm   pre0_mod1_pos… f_meas  1     0           5 recipe       svm_…     2
5 base_ridge pre0_mod1_pos… accura… 0.993 0.00103     5 recipe       mult…     3
6 base_ridge pre0_mod1_pos… f_meas  0.991 0.00151     5 recipe       mult…     3

Крутяк! И Lasso, и Ridge показывают accuracy = 1 и f_measure = 1, такое нам нравится. По традиции возьмем Ridge

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

Красота! Все по единицам! Посмотрим на матрицу ошибок:

Диагональ! Идеальная диагональ!

Проверяем, что не было утечки данных:

summary(base_rec)

# A tibble: 25 × 4
   variable          type      role      source  
   <chr>             <list>    <chr>     <chr>   
 1 n_words           <chr [2]> predictor original
 2 n_sentences       <chr [2]> predictor original
 3 avg_sent_len      <chr [2]> predictor original
 4 punct_ratio       <chr [2]> predictor original
 5 exclamation_count <chr [2]> predictor original
 6 question_count    <chr [2]> predictor original
 7 avg_word_len      <chr [2]> predictor original
 8 pos_ADJ           <chr [2]> predictor original
 9 pos_ADP           <chr [2]> predictor original
10 pos_ADV           <chr [2]> predictor original
# ℹ 15 more rows

7. Значимость признаков для классификации

vip_data <- final_fit |>
    extract_fit_parsnip() |>
    vi(lambda = best_results$penalty) 
  
  vip_data |>
    slice_max(abs(Importance), n = 20) |>
    ggplot(aes(x = reorder(Variable, abs(Importance)), y = Importance)) +
    geom_col(fill = "#22A884") +
    coord_flip() +
    labs(title = "Важность признака",
         x = "Признаки", y = "Коэффициент") +
    theme_minimal()

Этот график стал для меня самой большой неожиданностью. Когда я исследовала части речи, я обращала внимание только на основные (“NOUN”, “VERB”, “ADJ”, “ADV”, “PRON”). Оказывается, вся ценность заключалась совсем не вних:)

Хотя по графику для “PART”, “X”, “PROPN”, “SYM”, “AUX” я бы не сказала, что они будут играть решающую роль.

pos_stats |>
  filter(upos %in% c("PART", "X", "PROPN", "SYM", "AUX")) |>
  ggplot(aes(x = authorID, y = prop, fill = upos)) +
  geom_col(position = "fill", alpha = 0.8) +
  scale_fill_viridis_d(name = "Часть речи") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(title = "Распределение частей речи по авторам",
       subtitle = "Слова 500-1000 (лемматизированный текст)",
       x = "Автор", y = "Доля")

Немного жалко, что структурные признаки практически не внесли вклад в разделение текстов по авторам, только question_count попал в топ признаков. Но я рада, что 10 минут, которые мой компьютер потратил на разметку частей речи для 3569 фрагментов, не прошли зря!

Заключение

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

Ольга Валерьевна, спасибо за очень интересную домашку! И за Ваш курс.