# Загружаем данные
corpus <- load.corpus.and.parse(corpus.dir = "../Documents/corpus")
# Разделим тексты на отрывки длиной 2000 слов
corpus_samples <- make.samples(corpus,
sample.size = 2000,
sampling = "normal.sampling",
sample.overlap = 0,
sampling.with.replacement = FALSE)
samples_df <- tibble(
sample_id = names(corpus_samples),
text = sapply(corpus_samples, function(x) paste(x, collapse = " "))
)
samples_df <- samples_df |>
separate(sample_id, into = c("author", "title", NA), sep = "_")Британская проза конца XVIII-XIX вв. Определение авторства.
Введение
Для определения авторов по текстам произведений будем использовать многоклассовую классификацию. Для начала немного о данных. Перед нами 11 авторов (Jane Austen, Anne Bronte, Charlotte Bronte, Emile Bronte, Charles Dickens, George Eliot, Henry Fielding,Samuel Richardson, Laurence Sterne, Antony Trollope, William Thackeray) и 27 произведений британской прозы конца XVIII-XIX вв.
Цель - обучение модели многоклассовой классификации, чтобы определить автора.
Задачи: - Провести разведывательный анализ. - Подготовить данные. Разделить на более мелкие части. Лемматизировать. - Отсечь имена собственные из лемматизированных отрывков. Первая идея - извлечь служебные слова, так как они употребляются авторами неосознанно и могут отражать стиль. - Посчитать частотные слова. Выделить 500 самых частотных. - Разделить данные на тренировочную и тестовую выборки. - Снизить размерность данных. - Подготовить рецепты для обучения. - Подготовить модели и настроить параметры. - Сравнить модели по производительности и выбрать наиболее точную для определения автора.
Разведывательный анализ. Часть 1.
Чтобы понимать, что представляют из себя наши данные и выбрать методы дальнейшей их обработки, проведем небольшой разведывательный анализ. Для начала посмотрим, как распределяются, сделанные отрывки по авторам.
# A tibble: 11 × 2
author n
<chr> <int>
1 EBronte 59
2 Sterne 115
3 ABronte 118
4 Austen 201
5 CBronte 236
6 Fielding 244
7 Trollope 377
8 Eliot 379
9 Thackeray 401
10 Dickens 414
11 Richardson 709Как мы можем увидеть. У E. Bronte совсем немного отрывков - 59. Это может вызывать сложности при обучении и тестировании, так как очень мало данных. Модель, скорее всего, не сможет корректно распознавать этого автора. Чего не скажешь о Richardson. Однако, принято решение не исключать из дальнейшей работы авторов, имеющих мало отрывков. Данные распределены неравномерно. У одних авторов меньше произведений или их объем невелик, у других наоборот.
Подготовка признаков
Для того, чтобы выделить и подготовить признаки, которые могла бы понять модель, проведем лемматизацию отрывков, уберем имена собственные (поскольку могут попасться имена героев и географических названий и др.), так как это может повлиять на определение уникальности стиля авторов. Посчитаем частоты слов и выберем 500 самых часто встречающихся для каждого автора.
# 2. Загружаем модель UDPipe для английского языка
#ud_model <- udpipe_download_model(language = "english-ewt")
#ud_model <- udpipe_load_model(ud_model$file_model)
# 3. Аннотируем тексты с помощью UDPipe
#annotated <- udpipe_annotate(ud_model, x = samples_df$text, doc_id = samples_df$author)
#annotated <- as_tibble(annotated)
load("~/annotated.Rdata")
annotated# A tibble: 6,520,015 × 14
doc_id paragraph_id sentence_id sentence token_id token lemma upos xpos
<chr> <int> <int> <chr> <chr> <chr> <chr> <chr> <chr>
1 ABronte_A… 1 1 agnes g… 1 agnes agne ADV RB
2 ABronte_A… 1 1 agnes g… 2 grey grey ADJ JJ
3 ABronte_A… 1 1 agnes g… 3 chap… chap… NOUN NN
4 ABronte_A… 1 1 agnes g… 4 i I PRON PRP
5 ABronte_A… 1 1 agnes g… 5 the the DET DT
6 ABronte_A… 1 1 agnes g… 6 pars… pars… NOUN NN
7 ABronte_A… 1 1 agnes g… 7 all all DET DT
8 ABronte_A… 1 1 agnes g… 8 true true ADJ JJ
9 ABronte_A… 1 1 agnes g… 9 hist… hist… NOUN NNS
10 ABronte_A… 1 1 agnes g… 10 cont… cont… VERB VBP
# ℹ 6,520,005 more rows
# ℹ 5 more variables: feats <chr>, head_token_id <chr>, dep_rel <chr>,
# deps <chr>, misc <chr># Уберем имена собственные из лемматизированных отрывков.
filtered_df <- annotated[annotated$upos != "PROPN", ]
# Выберем doc_id и лемму.
filtered_df <- filtered_df |>
select(doc_id, lemma)Так как процесс лемматизации очень долгий (длился 4 часа), размеченный датасет можно найти здесь: лемматизация в формате Rdata.
Посчитаем частоты.
# Группируем леммы по авторам и подсчитываем их частоту
frequency_df <- filtered_df %>%
group_by(doc_id, lemma) %>%
summarise(freq = n(), .groups = 'drop')
# Отбираем 500 самых частотных лемм
top_lemmas <- frequency_df %>%
arrange(desc(freq)) %>%
distinct(lemma) %>%
slice_head(n = 500) %>%
pull(lemma)
# Создаем матрицу частот
frequency_matrix <- frequency_df %>%
filter(lemma %in% top_lemmas) %>%
pivot_wider(names_from = lemma, values_from = freq, values_fill = list(freq = 0))
# Теперь frequency_matrix содержит матрицу частот
# Преобразуем в tibble для удобства
frequency_matrix <- as_tibble(frequency_matrix)
frequency_matrix <- frequency_matrix |>
separate(doc_id, into = c("author", "title", NA), sep = "_")
frequency_matrix <- frequency_matrix |>
select(-title)
frequency_matrix# A tibble: 4,343 × 500
author `'s` I a agne all and any as at aunt be
<chr> <int> <int> <int> <int> <int> <int> <int> <int> <int> <int> <int>
1 ABronte 13 22 31 1 15 71 2 10 10 1 56
2 ABronte 6 50 36 0 8 52 3 10 7 0 51
3 ABronte 8 57 26 0 5 50 4 11 10 0 41
4 ABronte 2 71 21 0 15 60 4 19 9 1 59
5 ABronte 4 61 31 1 9 68 3 18 10 0 55
6 ABronte 1 56 65 0 9 69 4 15 8 0 32
7 ABronte 5 42 28 0 7 73 2 18 9 0 63
8 ABronte 5 45 31 0 8 56 5 20 13 0 77
9 ABronte 2 48 27 0 9 59 3 15 15 0 71
10 ABronte 3 76 42 0 5 61 1 8 5 0 71
# ℹ 4,333 more rows
# ℹ 488 more variables: but <int>, by <int>, chapter <int>, child <int>,
# come <int>, could <int>, crack <int>, day <int>, dear <int>, do <int>,
# family <int>, father <int>, `for` <int>, friend <int>, from <int>,
# gentleman <int>, get <int>, girl <int>, give <int>, go <int>, good <int>,
# hand <int>, have <int>, he <int>, hear <int>, herself <int>, himself <int>,
# house <int>, how <int>, idea <int>, `if` <int>, `in` <int>, into <int>, …Данные прошли предобработку и готовы к обучению.
Выборки
Разделим наш подготовленный корпус на обучающую и тестовую выборки.
# 5-fold cross-validation using stratification
# A tibble: 5 × 2
splits id
<list> <chr>
1 <split [2603/652]> Fold1
2 <split [2603/652]> Fold2
3 <split [2603/652]> Fold3
4 <split [2605/650]> Fold4
5 <split [2606/649]> Fold5Подготовка рецептов. Снижение размерности. Разведывательный анализ. Часть 2.
# Подготовим первый рецепт
base_rec <- recipe(author ~ ., data = data_train) |>
step_zv(all_predictors()) |>
step_normalize(all_numeric_predictors())
base_rec
# Обучим рецепт на основе обучающей выборки
base_trained <- base_rec |>
prep(data_train)
base_trained
# Применим рецепт к обучающим данным
base_trained |>
bake(new_data = NULL)# A tibble: 3,255 × 498
`'s` I a agne all and any as at aunt
<dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 -0.969 1.02 0.800 -0.104 -0.433 1.02 -0.951 -1.24 -1.07 -0.256
2 -0.969 0.0873 -0.614 3.25 -0.122 1.51 -1.40 -0.875 -1.31 -0.256
3 -1.19 1.96 0.582 -0.104 4.24 -0.112 -0.0567 2.40 0.421 -0.256
4 -0.745 0.677 2.65 -0.104 0.190 0.212 -0.951 1.31 1.66 -0.256
5 -0.0729 0.296 -1.16 -0.104 -0.122 0.780 -0.504 0.580 0.173 -0.256
6 -0.0729 0.886 -0.831 -0.104 -0.122 0.374 -0.504 -0.147 1.16 -0.256
7 -0.745 0.608 0.147 1.01 -0.122 -0.355 -0.951 1.49 -0.818 -0.256
8 -0.521 0.434 1.89 -0.104 -1.37 0.212 -0.504 -0.875 0.916 -0.256
9 -0.745 0.608 -0.940 -0.104 -0.744 0.942 0.390 -0.875 0.173 0.730
10 -0.745 0.330 0.800 -0.104 1.12 1.02 -1.40 -1.24 0.173 0.730
# ℹ 3,245 more rows
# ℹ 488 more variables: be <dbl>, but <dbl>, by <dbl>, chapter <dbl>,
# child <dbl>, come <dbl>, could <dbl>, crack <dbl>, day <dbl>, dear <dbl>,
# do <dbl>, family <dbl>, father <dbl>, `for` <dbl>, friend <dbl>,
# from <dbl>, gentleman <dbl>, get <dbl>, girl <dbl>, give <dbl>, go <dbl>,
# good <dbl>, hand <dbl>, have <dbl>, he <dbl>, hear <dbl>, herself <dbl>,
# himself <dbl>, house <dbl>, how <dbl>, idea <dbl>, `if` <dbl>, …# Также подготовим рецепт с главными компонентами
pca_rec <- base_rec |>
step_pca(all_numeric_predictors(), num_comp = 7)
pca_rec
# Обучим для снижения размерности
pca_trained <- pca_rec |>
prep(data_train)
# Визуализируем результаты снижения размерности.
pca_trained |>
juice() |>
ggplot(aes(PC1, PC2, color = author)) +
geom_point() +
theme_light() +
ggtitle("Снижение размерности методом главных компонент")
# Визуализируем по словам.
library(learntidymodels)
pca_trained |>
plot_top_loadings(component_number <= 4, n = 10) +
scale_fill_brewer(palette = "Paired") +
theme_light()
По первой компоненте хорош отличим Trollope (“not”, “to”, “will”), по второй компоненте Richardson (“which”) и Sterne (“of”).
# Создадим рецепт с PLS и посмотрим на результаты снижения размерности.
pls_trained <- base_trained |>
step_pls(all_numeric_predictors(), outcome = "author", num_comp = 7) |>
prep()
pls_trained |>
juice() # A tibble: 3,255 × 8
author PLS1 PLS2 PLS3 PLS4 PLS5 PLS6 PLS7
<fct> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 ABronte -0.688 -2.40 -2.41 0.493 1.78 0.920 0.149
2 ABronte -0.598 -0.583 -1.67 -1.07 0.325 1.03 0.713
3 ABronte -1.37 -1.98 -2.49 0.255 -0.583 0.436 1.08
4 ABronte 0.166 -0.313 -1.29 -0.724 -0.0430 0.275 0.560
5 ABronte -0.539 -1.80 -1.04 -0.419 0.707 0.240 0.970
6 ABronte -2.07 0.381 -0.791 -0.962 0.253 -0.159 0.785
7 ABronte -2.27 1.81 1.27 -0.979 -1.69 0.642 0.364
8 ABronte 2.70 1.33 -2.97 -0.153 -1.04 1.01 0.845
9 ABronte -1.63 -1.44 0.312 -0.977 0.358 0.993 0.616
10 ABronte 0.328 0.927 -1.43 -1.15 -0.862 1.33 1.22
# ℹ 3,245 more rows# Визуализируем
pls_trained |>
juice() |>
ggplot(aes(PLS1, PLS2, color = author)) +
geom_point() +
theme_light() +
ggtitle("Снижение размерности методом частичных наименьших квадратов")
# Визуализируем нагрузки компонент по словам.
pls_trained |>
plot_top_loadings(component_number <= 4, n = 10, type = "pls") +
scale_fill_brewer(palette = "Paired") +
theme_light()
Здесь мы можем увидеть более четкие классы. Хотя, по прежнему по первым двум компонентам хорошо различимы Richardson, Trollope, Sterne, чуть лучше стала ситуация с Austin.
# Создадим рецепты с PLS и UMAP.
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()
)
# Визуализируем с umap.
base_trained |>
step_umap(all_numeric_predictors(), outcome = "author", num_comp = 4) |>
prep() |>
juice() |>
ggplot(aes(UMAP1, UMAP2, color = author)) +
geom_point(alpha = 0.5) +
theme_light()
Метод снижения размерности UMAP позволяет нам более четко воспринимать классы и границы между ними. По первым двум компонентам, ситуация та же.
Спецификации моделей
Для обучения многоклассовой классификации мы попробуем использовать три спецификации моделей: регуляризационные lasso и ridge, а также опорные векторы.
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")Обучение и выбор лучшей модели
# A workflow set/tibble: 12 × 4
wflow_id info option result
<chr> <list> <list> <list>
1 base_svm <tibble [1 × 4]> <opts[0]> <list [0]>
2 base_lasso <tibble [1 × 4]> <opts[0]> <list [0]>
3 base_ridge <tibble [1 × 4]> <opts[0]> <list [0]>
4 pca_svm <tibble [1 × 4]> <opts[0]> <list [0]>
5 pca_lasso <tibble [1 × 4]> <opts[0]> <list [0]>
6 pca_ridge <tibble [1 × 4]> <opts[0]> <list [0]>
7 pls_svm <tibble [1 × 4]> <opts[0]> <list [0]>
8 pls_lasso <tibble [1 × 4]> <opts[0]> <list [0]>
9 pls_ridge <tibble [1 × 4]> <opts[0]> <list [0]>
10 umap_svm <tibble [1 × 4]> <opts[0]> <list [0]>
11 umap_lasso <tibble [1 × 4]> <opts[0]> <list [0]>
12 umap_ridge <tibble [1 × 4]> <opts[0]> <list [0]>
Методы снижения размерности, как мы видим в результате, не показали хороших результатов. Базовый рецепт оказался наиболее эффективным при обучении. Наиболее хорошие результаты (точность) характерны для методов гребневой регрессии (штрафные коэффициенты) и опорных векторов.
# A tibble: 24 × 9
wflow_id .config .metric mean std_err n preprocessor model rank
<chr> <chr> <chr> <dbl> <dbl> <int> <chr> <chr> <int>
1 base_svm Preprocessor… accura… 0.991 6.09e-4 5 recipe svm_… 1
2 base_svm Preprocessor… f_meas 0.988 8.09e-4 5 recipe svm_… 1
3 base_ridge Preprocessor… accura… 0.991 1.85e-3 5 recipe mult… 2
4 base_ridge Preprocessor… f_meas 0.987 3.15e-3 5 recipe mult… 2
5 base_lasso Preprocessor… accura… 0.990 1.03e-3 5 recipe mult… 3
6 base_lasso Preprocessor… f_meas 0.984 2.87e-3 5 recipe mult… 3
7 umap_lasso Preprocessor… accura… 0.945 3.52e-3 5 recipe mult… 4
8 umap_lasso Preprocessor… f_meas 0.926 4.08e-3 5 recipe mult… 4
9 umap_svm Preprocessor… accura… 0.941 5.05e-3 5 recipe svm_… 5
10 umap_svm Preprocessor… f_meas 0.913 7.53e-3 5 recipe svm_… 5
# ℹ 14 more rowsПосмотрим на параметры лучшей модели. В данном случае это гребневая регрессия.
Первые две модели справляются одинаково хорошо, на третьей происходит переобучение.
Финал. Тестирование.
# A tibble: 1 × 2
penalty .config
<dbl> <chr>
1 1.06e-10 Preprocessor1_Model1После выбора наилучшей модели, предстоит оценить ее на всей обучающей выборке.
# A tibble: 3 × 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <chr>
1 f_meas macro 0.984 Preprocessor1_Model1
2 accuracy multiclass 0.994 Preprocessor1_Model1
3 roc_auc hand_till 1.00 Preprocessor1_Model1Как мы можем увидеть, модель работает довольно неплохо, все показатели довольно близки к единице. Осталось только на них взглянуть)
Мы можем увидеть, что моделб ошибается в определении Emile Bronte, она путает ее с Charlotte Bronte (сестры ведь). Учитывая, что для E. Bronte было довольно мало данных в самом начале, такой результат не является удивительным. Laurence Sterne также определяется с ошибками, модель путает его с C. Bronte и A. Bronte. Очень хорошо определяется Richardson, Dickens, Thackeray, Trollope, Austen и Fildeing. Это может объясняться достаточным количеством данных. Выше мы наблюдали, что для них характерно большое количество отрывков. С одной ошибкой - Eliot и C. Bronte.
collect_predictions(ridge_res) |>
roc_curve(truth = author, .pred_ABronte:.pred_Trollope) |>
ggplot(aes(1 - specificity, sensitivity, color = .level)) +
geom_abline(slope = 1, color = "gray50", lty = 2, alpha = 0.8) +
geom_path(linewidth = 1.5, alpha = 0.7) +
labs(color = NULL) +
theme_light()
Судя по расположению кривой, модель работает достаточно эффективно.
Теперь давайте посмотрим, на характерные для каждого автора слова-признаки.
Как мы видим, помимо служебных частей речи и существительных, в качестве весомых признаков встречаются имена героев. Значит при лемматизации имели место ошибки. Например, это характерно для произведений C. Bronte (“roshester”, “jane”) и для J. Austen (“elizabeth”, “darcy”). По частому употреблению служебных частей речи (союзы) среди других очень выделяется A. Bronte (“but”, “or”, “and”). Это делает ее произведения довольно противоречивыми.Частое употребление противительных союзов может говорить о наличии контраста и сопоставления в произведении.
Выводы
- Качество модели очень сильно зависит от количества и репрезентативности данных.
- Важно! Необходимо проверять результаты лемматизации. Возможно, было бы лучше довести до ума первоначальную идею об извлечении служебных частей речи после лемматизации, и последующего подсчета относительных частот (жаль, что не получилось).
- В процессе определения авторства с помощью многоклассовой классификации, можно выделить неожиданные стилистические особенности автора, как в случае с Anne Bronte.