library(tidyverse)
library(textrecipes)
library(tidymodels)
library(tidytext)
library(stylo)
library(themis)
library(baguette)
library(discrim)
library(future)british_novels
Zusammenfassung
Meow-meow
Начало работы и данные
Для работы используем следующие библиотеки:
Загрузим корпус британской прозы, преобразуем в тиббл для предобработки и разведывательного анализа:
corpus <- load.corpus(corpus.dir = "./british_fiction")
british_tibble <- tibble(
doc_id = names(corpus),
text = map_chr(corpus, paste, collapse = " "))Разделим колонки с фамилией автора и названием книги и уберем лишние точки из текста, поскольку в дальнейшем нам нужно будет посчитать длину предложений:
british_tibble <- british_tibble |>
separate_wider_delim(
doc_id,
delim = '_',
names = c('author', 'book')) |>
mutate(book = gsub('.txt', '', book)) |>
mutate(text = gsub('Mr.', 'Mr', text)) |>
mutate(text = gsub('Mrs.', 'Mrs', text))Разведывательный анализ
Токенизируем текст, затем получим список стоп-слов для английского языка и удалим их:
british_tokens <- british_tibble |>
unnest_tokens(word, text, token='words')
stopwords_en <- get_stopwords(language = "en", source = "snowball")
british_tokens_clean <- british_tokens |>
anti_join(stopwords_en, by = "word")Начнем собирать статистику по каждому произведению:
book_stats <- british_tokens |>
group_by(author, book) |>
summarise(
total_words = n(),
unique_words = n_distinct(word),
lexical_density = unique_words / total_words,
.groups = "drop"
)
book_stats# A tibble: 27 × 5
author book total_words unique_words lexical_density
<chr> <chr> <int> <int> <dbl>
1 ABronte Agnes 68598 6760 0.0985
2 ABronte Tenant 167992 10264 0.0611
3 Austen Emma 160997 7357 0.0457
4 Austen Pride 122108 6421 0.0526
5 Austen Sense 119962 6425 0.0536
6 CBronte Jane 188202 12761 0.0678
7 CBronte Professor 89378 9730 0.109
8 CBronte Villette 195680 14862 0.0760
9 Dickens Bleak 357471 15323 0.0429
10 Dickens David 359112 14348 0.0400
# ℹ 17 more rowsОтдельно посчитаем длину предложений и добавим средние значения в таблицу со статистикой:
british_sentences <- british_tibble |>
unnest_tokens(sentence, text, token = 'sentences', to_lower = FALSE) |>
mutate(sentence_length = str_count(sentence, '\\S+'))
sentence_stats <- british_sentences |>
select(author, book, sentence_length) |>
group_by(author, book) |>
summarise(
sentence_mean = mean(sentence_length),
sentence_sd = sd(sentence_length)
)
book_stats <- book_stats |>
left_join(sentence_stats, by = c("author", "book"))Посмотрим на количество слов суммарно у каждого автора:
Здесь мы сразу видим дисбаланс классов – у С. Ричардсона почти 1,5млн токенов, тогда как у Э. Бронте чуть меньше 250 000. Посмотрим также на лексическое разнообразие:
Здесь мы видим, что в объемных эпистолярных романах Ричардсона лексика оказывается не слишком разнообразной, тогда как, например, в относительно небольших произведениях Л. Стерна доля уникальных слов составляет почти 20%. Посмотрим также на среднюю длину предложений:
Маленькая доля уникальных слов в сочетании с относительно небольшой средней длиной предложений у Ричардсона может указывать на то, что его произведения написаны достаточно простым для восприятия языком. Наконец, посмотрим на долю стоп-слов:
stopword_ratio <- british_tokens |>
mutate(is_stopword = word %in% stopwords_en$word) |>
group_by(author, book) |>
summarise(
stopword_ratio = mean(is_stopword, na.rm = TRUE),
total_words = n(),
.groups = "drop"
) |>
arrange(desc(stopword_ratio))
stopword_ratio# A tibble: 27 × 4
author book stopword_ratio total_words
<chr> <chr> <dbl> <int>
1 Trollope Prime 0.580 284645
2 Trollope Phineas 0.573 264592
3 Richardson Pamela 0.570 440450
4 Richardson Clarissa 0.568 969910
5 ABronte Tenant 0.559 167992
6 Austen Sense 0.555 119962
7 Austen Pride 0.554 122108
8 Trollope Barchester 0.553 196685
9 ABronte Agnes 0.552 68598
10 Austen Emma 0.550 160997
# ℹ 17 more rowsПодготовка данных для обучения моделей
Для дальнейшей работы будем использовать тиббл, который содержит тексты, разбитые на предложения – из этой версии мы не удаляли стоп-слова, поскольку они могут быть важны для классификации произведений. Перед началом обучения удалим из текстов имена собственные (по крайней мере, большую их часть). Для этого найдем и удалим такие слова, которые начинаются с большой буквы, но стоят не на первом месте в предложении:
british_words <- british_sentences |>
mutate(sentence_id = row_number()) |>
unnest_tokens(word, sentence, token = "words", to_lower = FALSE) |>
group_by(sentence_id) |>
mutate(word_position = row_number()) |>
ungroup()
british_words_clean <- british_words |>
mutate(
is_first_word = (word_position == 1),
is_proper = str_detect(word, "^[A-Z][a-z]+") & #наличие второй строчной буквы позволяет не удалять местоимение I, которое всегда пишется с заглавной буквы
!is_first_word |
str_detect(word, "^[A-Z][A-Z]+$")
) |>
filter(!is_proper)
british_words_clean <- british_words_clean |>
select(author, book, word)Тексты без имен собственных разобьем на сэмплы по 2000 слов:
british_samples <- british_words_clean |>
group_by(author) |>
mutate(word_index = row_number()) |>
mutate(sample_id = ceiling(word_index / 2000)) |>
group_by(author, sample_id) |>
summarise(
sample_text = paste(word, collapse = " "),
word_count = n(),
.groups = "drop"
)
british_samples <- british_samples |>
select(author, sample_text)Проверим, что картина с сэмплами соответствует тому, что мы видели со словами:
Теперь ввернемся к формату stylo.corpus, чтобы сделать таблицу частотностей:
british_stylo_corpus <- british_samples |>
mutate(sample_text = tolower(sample_text)) |>
mutate(words_vector = str_split(sample_text, "\\s+")) |>
pull(words_vector) |>
setNames(paste0(british_samples$author, "_sample_",
1:nrow(british_samples)))
class(british_stylo_corpus) <- c("stylo.corpus", "list")Берем 500 самых частотных слов, делаем подсчеты для наших сэмплов и получаем датасет british_tf:
british_mfw <- make.frequency.list(british_stylo_corpus)[1:500]
british_tf <- stylo::make.table.of.frequencies(british_stylo_corpus, british_mfw) |>
as.data.frame.matrix() |>
rownames_to_column("id") |>
as_tibble()
british_tf <- british_tf |>
separate(id, into = c('author', NA), sep = '_')Подготовка к построению модели
Сначала разделим данные на обучающую и тестовую выборки:
set.seed(2222)
data_split <- british_tf |>
mutate(author = as.factor(author)) |>
initial_split(strata = author)
data_train <- training(data_split)
data_test <- testing(data_split)
folds <- vfold_cv(data_train, strata = author, v = 5)Поскольку выше мы увидели, что классы представлены неравномерно, напишем рецепт с балансировкой обучающих данных:
balanced_rec <- recipe(author ~ ., data = data_train) |>
step_upsample(author, over_ratio = 0.4) |> # для маленьких классов
step_downsample(author, under_ratio = 0.85) |> # для С. Ричардсона
step_zv(all_predictors()) |>
step_normalize(all_predictors())
balanced_rec── Recipe ──────────────────────────────────────────────────────────────────────── Inputs Number of variables by roleoutcome: 1
predictor: 500── Operations • Up-sampling based on: author• Down-sampling based on: author• Zero variance filter on: all_predictors()• Centering and scaling for: all_predictors()SVM
Попробуем обучить SVM с балансировкой классов:
svm_spec <- svm_linear(cost = tune()) |>
set_mode("classification") |>
set_engine("LiblineaR")
svm_wflow <- workflow() |>
add_recipe(balanced_rec) |>
add_model(svm_spec)
set.seed(2222)
svm_trained <- svm_wflow |>
fit(data_train)Теперь применим к тестовым данным, посчитаем точность:
predictions <- svm_trained |>
predict(data_test) |>
bind_cols(data_test)
accuracy <- predictions |>
accuracy(truth = author, estimate = .pred_class)
cat("Точность модели:", round(accuracy$.estimate, 4), "\n")Точность модели: 0.9819 Визуализируем confusion matrix:
Для сравнения попробуем теперь обучить SVM без балансировки классов:
base_rec <- recipe(author ~ ., data = data_train) |>
step_zv(all_predictors()) |>
step_normalize(all_predictors())
base_svm_wflow <- workflow() |>
add_recipe(base_rec) |>
add_model(svm_spec)
set.seed(2222)
base_svm_trained <- base_svm_wflow |>
fit(data_train)
base_predictions <- base_svm_trained |>
predict(data_test) |>
bind_cols(data_test)Визуализируем confusion matrix:
Мы видим, что SVM оказалась нечувствительна к дисбалансу классов – accuracy не изменилась, confusion matrix тоже (для некоторых авторов без балансировки классов оказалось даже больше попаданий).
KNN
Попробуем то же самое для метода ближайших соседей:
#devtools::install_github("KlausVigo/kknn")
knn_spec <- nearest_neighbor(neighbors = 5) |>
set_engine("kknn") |>
set_mode("classification")
knn_wflow_unbalanced <- workflow() |>
add_recipe(base_rec) |>
add_model(knn_spec)
knn_wflow_balanced <- workflow() |>
add_recipe(balanced_rec) |>
add_model(knn_spec)Обучаем:
set.seed(2222)
knn_unbalanced <- knn_wflow_unbalanced |>
fit(data_train)
knn_balanced <- knn_wflow_balanced |>
fit(data_train)Проверяем на тестовых данных и сравниваем точность:
pred_knn_unbalanced <- knn_unbalanced |>
predict(data_test) |> bind_cols(data_test)
pred_knn_balanced <- knn_balanced |>
predict(data_test) |> bind_cols(data_test)
acc_knn_unbalanced <- pred_knn_unbalanced |>
accuracy(truth = author, estimate = .pred_class)
acc_knn_balanced <- pred_knn_balanced |>
accuracy(truth = author, estimate = .pred_class)
cat("KNN - без балансировки:", acc_knn_unbalanced$.estimate, "\n")KNN - без балансировки: 0.8645161 cat("KNN - с балансировкой:", acc_knn_balanced$.estimate, "\n")KNN - с балансировкой: 0.796129 Визуализируем:
Warning: пакет 'patchwork' был собран под R версии 4.5.3
Здесь мы видим, что балансировка классов даже ухудшила результат работы модели – это видно как для класса Richardson, который изначально был самым большим, так и для классов ABronte, EBronte и Sterne, которые изначально были слабо представлены. Возможно, стоило подобрать другое соотношение коэффициентов в рецепте balanced_rec.