A Small Collection of British Fiction - 2

Компьютерный анализ текстов, модуль 4

library(baguette)
library(discrim)
library(embed)
library(future)
library(ggplot2)
library(readtext)
library(stopwords)
library(stylo)
library(textrecipes)
library(tidymodels)
library(tidytext)
library(tidyverse)
library(udpipe)

γ’. Модель

γ’.1. Загрузка корпуса

Загружаю корпус:

corpus <- load.corpus.and.parse(corpus.dir = './british_fiction_lemmatised')

Делю тексты на отрывки длинною 2000 слов (все тексты в коллекции большие):

corpus_samples <- make.samples(corpus, 
                               sample.size = 2000, 
                               sampling = 'normal.sampling',
                               sample.overlap = 0)

Подготовка матрицы с частотностями (ориентируюсь на вариант первых 1000 токенов, чтобы попали не только служебные слова):

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

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

Сохраняю информацию об авторе:

corpus_tf <- corpus_tf |> 
  separate(id, into = c('author', 'book', NA, NA, NA), sep = '_')

# удалить информацию о книге
corpus_tf <- corpus_tf |> select(-book)

Получается следующая картина по авторам:

corpus_tf |> 
  count(author) |> 
  ggplot(aes(reorder(author, n), n, fill = author)) +
  geom_col(show.legend = FALSE) +
  xlab(NULL) +
  ylab(NULL) +
  scale_fill_viridis_d() + 
  theme_light() +
  coord_flip()

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

γ’.2. Тренировочная и тестовая выборки

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

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

Фолды:

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

γ’.3. Подготовка

base_rec <- recipe(author ~ ., data = data_train) |>
  # удалить предикторы, имеющие нулевую дисперсию
  step_zv(all_predictors()) |> 
  # стандартизовать все числовые предикторы
  step_normalize(all_predictors())

Подготавливаю рецепт на основе тренировочной выборки:

base_trained <- base_rec |>
  prep(data_train) 

base_trained

── Recipe ──────────────────────────────────────────────────────────────────────

── Inputs 

Number of variables by role

outcome:     1
predictor: 999

── Training information 

Training data contained 2420 data points and no incomplete rows.

── Operations 

• Zero variance filter removed: <none> | Trained

• Centering and scaling for: the, be, and, to, i, he, of, a, ... | Trained

Использование главных компонент в качестве предикторов (для EDA ниже):

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

pca_trained <- pca_rec |>
  prep(data_train)

γ’.4. EDA через PCA

Рассмотрим серию визуализаций главных компонент.

PC1 & PC2:

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

В случае главных компонент PC1 и PC2 видно, что достаточно хорошо выделяется кластер с Ричардсоном, но при этом есть видимое пересечение с Филдингом.

PC3 & PC4:

pca_trained |> 
  juice() |> 
  ggplot(aes(PC3, PC4, colour = author)) +
  geom_point() + 
  theme_light()

Для главных компонент PC3 и PC4, пожалуй, хочется выделить обособление Троллопа, но при этом, я полагаю, имеет место быть пересечение с Теккереем. Ричардсон же уже смешивается с остальными авторами.

PC1 & PC3

pca_trained |> 
  juice() |> 
  ggplot(aes(PC1, PC3, colour = author)) +
  geom_point() + 
  theme_light()

А вот здесь уже, например, явно выделяется Ричардсон!

PC2 & PC3

pca_trained |> 
  juice() |> 
  ggplot(aes(PC2, PC3, colour = author)) +
  geom_point() + 
  theme_light()

В данном случае, как кажется, тоже имеет место быть выделение Троллопа и Теккерея (не без пересечений с другими).

γ’.5. Продолжаем готовить

Добавляю ещё рецепты предобработки:

pls_rec <- base_rec |> 
  step_pls(all_numeric_predictors(), outcome = 'author', num_comp = tune())

umap_rec <- base_rec |> 
  step_umap(all_numeric_predictors(), 
            outcome = 'author',
            num_comp = tune(),
            neighbors = tune(),
            min_dist = tune()
  )

Список моделей:

# лассо-модель
lasso_spec <- multinom_reg(penalty = tune(), mixture = 1) |> 
  set_mode('classification') |> 
  set_engine('glmnet')

# гребневая регрессия
ridge_spec <- multinom_reg(penalty = tune(), mixture = 0) |> 
  set_mode('classification') |> 
  set_engine('glmnet')

# метод опорных векторов
svm_spec <- svm_linear(cost = tune()) |> 
  set_mode('classification') |> 
  set_engine('LiblineaR')

# однослойная нейронная сеть
mlp_spec <- mlp(hidden_units = tune(),
                penalty = tune(),
                epochs = tune()) |> 
  set_engine('nnet') |> 
  set_mode('classification')

# бэггинг деревьев решений
bagging_spec <- bag_tree() |> 
  set_engine('rpart') |> 
  set_mode('classification')

# FDA
fda_spec <- discrim_flexible(prod_degree = tune()) |> 
  set_engine('earth')

# RDA
rda_spec <- discrim_regularized(frac_common_cov = tune(), 
                                frac_identity = tune())  |> 
  set_engine('klaR')

#метод ближайших соседей
knn_spec <- nearest_neighbor(neighbors = 5) |> 
  set_engine('kknn') |> 
  set_mode('classification')

Создаю workflow:

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

parallel::detectCores()

[1] 8

Запускаю!

plan(multisession, workers = 5)

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

δ’. Оценка и визуализации

(Тут что-то пошло не так…)

rank_results(train_res, select_best = TRUE) |> 
  print()