corpus_df <- list.files("corpus", pattern = "\\.txt$", full.names = TRUE) |>
map_dfr(function(path) {
parts <- str_split_fixed(tools::file_path_sans_ext(basename(path)), "_", n = 2)
tibble(
author = parts[1],
title = parts[2],
text = paste(readLines(path, warn = FALSE, encoding = "UTF-8"), collapse = "\n")
)
})Многомерная классификация текстов английских писателей
Здесь строится многомерная классификация текстов авторов английских романов с помощью моделей tidymodels.
Загрузка и обработка корпуса
cat("Загружено", nrow(corpus_df), "файлов\n")Загружено 27 файловunique(corpus_df$author) [1] "ABronte" "Austen" "CBronte" "Dickens" "EBronte"
[6] "Eliot" "Fielding" "Richardson" "Sterne" "Thackeray"
[11] "Trollope" # Вспомогательные функции для извлечения признаков
get_sentences <- function(text) str_split(text, "(?<=[.!?])\\s+")[[1]]
# Исправленная версия:
get_words_fixed <- function(text) {
words <- text |>
str_to_lower() |>
str_replace_all("[^a-z\\s]", " ") |>
str_squish() |>
str_split("\\s+")
# Извлекаем первый элемент и фильтруем пустые строки
words_vector <- words[[1]]
words_vector[nchar(words_vector) > 0]
}
stop_set <- tolower(stop_words$word)
surface_features <- function(text) {
words <- get_words_fixed(text) # используем исправленную версию
sents <- get_sentences(text)
sent_lengths <- map_int(sents, ~ length(get_words_fixed(.x))) # и здесь
tibble(
n_chars = nchar(text),
n_tokens = length(words),
n_types = n_distinct(words),
n_sentences = length(sents),
ttr = n_distinct(words) / length(words),
avg_word_len = mean(nchar(words)),
avg_sent_len = mean(sent_lengths),
sd_sent_len = sd(sent_lengths),
max_sent_len = max(sent_lengths)
)
}
stopword_features <- function(text) {
words <- get_words_fixed(text) # используем исправленную версию
sw_n <- sum(words %in% stop_set)
tibble(n_stopwords = sw_n, prop_stopwords = sw_n / length(words))
}
punct_features <- function(text) tibble(
n_commas = str_count(text, ","),
n_semicolons = str_count(text, ";"),
n_exclamation = str_count(text, "!"),
n_question = str_count(text, "\\?"),
n_quotes = str_count(text, '"'),
n_ellipsis = str_count(text, "\\.{3}|…")
)
ngram_features <- function(text, top_n = 10) {
words <- get_words_fixed(text)
n <- length(words)
bigrams <- paste(words[-n], words[-1])
trigrams <- paste(words[-c(n-1,n)], words[-c(1,n)], words[-c(1,2)])
top <- function(x) paste(names(sort(table(x), decreasing = TRUE)[1:top_n]), collapse = "|")
tibble(top_unigrams = top(words), top_bigrams = top(bigrams), top_trigrams = top(trigrams))
}Построение матрицы признаков
features_df <- corpus_df %>%
mutate(
surf = map(text, surface_features),
sw = map(text, stopword_features),
punc = map(text, punct_features),
ngrams = map(text, ngram_features)
) %>%
unnest(c(surf, sw, punc, ngrams)) %>%
select(-text)
glimpse(features_df)Rows: 27
Columns: 22
$ author <chr> "ABronte", "ABronte", "Austen", "Austen", "Austen", "CB…
$ title <chr> "Agnes", "Tenant", "Emma", "Pride", "Sense", "Jane", "P…
$ n_chars <int> 372797, 914997, 880425, 681486, 668091, 1022237, 498292…
$ n_tokens <int> 69283, 169798, 161973, 122726, 120736, 189219, 89942, 1…
$ n_types <int> 6665, 10081, 7095, 6258, 6278, 12545, 9580, 14418, 1495…
$ n_sentences <int> 1956, 5662, 7657, 5773, 4423, 7827, 2793, 8731, 19109, …
$ ttr <dbl> 0.09619964, 0.05937055, 0.04380360, 0.05099164, 0.05199…
$ avg_word_len <dbl> 4.184980, 4.167222, 4.224939, 4.367958, 4.349482, 4.162…
$ avg_sent_len <dbl> 35.42076, 29.98905, 21.15358, 21.25862, 27.29731, 24.17…
$ sd_sent_len <dbl> 29.76354, 28.50564, 20.76648, 17.81923, 23.79520, 20.73…
$ max_sent_len <int> 242, 362, 250, 155, 397, 198, 247, 259, 211, 233, 184, …
$ n_stopwords <int> 47990, 117938, 115514, 85943, 84451, 124805, 57405, 125…
$ prop_stopwords <dbl> 0.6926663, 0.6945783, 0.7131682, 0.7002836, 0.6994683, …
$ n_commas <int> 6163, 15438, 12018, 9117, 9900, 14524, 7828, 17268, 295…
$ n_semicolons <int> 1174, 2278, 2353, 1538, 1572, 3473, 2195, 3321, 1385, 3…
$ n_exclamation <int> 310, 908, 1063, 499, 560, 929, 288, 885, 2605, 2809, 63…
$ n_question <int> 259, 1012, 621, 462, 452, 1490, 470, 1231, 2084, 1802, …
$ n_quotes <int> 134, 380, 4187, 3508, 3084, 7349, 2483, 6018, 15540, 40…
$ n_ellipsis <int> 0, 0, 0, 0, 5, 0, 0, 19, 0, 0, 0, 0, 130, 0, 9, 0, 1, 0…
$ top_unigrams <chr> "and|the|to|i|of|a|was|in|my|it", "and|i|the|to|of|you|…
$ top_bigrams <chr> "of the|in the|i was|to be|i had|and i|it was|to the|an…
$ top_trigrams <chr> "i could not|i don t|i did not|as well as|i was not|i s…Стилометрический анализ
corpus <- load.corpus.and.parse(corpus.dir = "corpus")
authors <- str_split_fixed(names(corpus), "_", 2)[, 1]
author_tokens <- tapply(corpus, authors, function(x) unlist(lapply(x, as.character)))
corpus_samples <- make.samples(author_tokens,
sample.size = 2000,
sampling = "normal.sampling",
sample.overlap = 0,
sampling.with.replacement = FALSE)
mfw <- make.frequency.list(corpus_samples)[1:500]
corpus_tf <- make.table.of.frequencies(corpus_samples, mfw) |>
as.data.frame.matrix() |>
rownames_to_column("id") |>
as_tibble() |>
mutate(author = as.factor(str_split_fixed(id, "_", 2)[, 1]))Разделение данных на обучающую и тестовую выборки
set.seed(31052026)
data_split <- initial_split(corpus_tf, strata = author)
data_train <- training(data_split)
data_test <- testing(data_split)
folds <- vfold_cv(data_train, strata = author, v = 5)
cat("Размер обучающей выборки:", nrow(data_train), "\n")Размер обучающей выборки: 2442 cat("Размер тестовой выборки:", nrow(data_test), "\n")Размер тестовой выборки: 817 Рецепты предобработки
base_rec <- recipe(author ~ ., data = data_train) |>
step_rm(id) |>
step_zv(all_predictors()) |>
step_normalize(all_predictors())
pca_rec <- base_rec |>
step_pca(all_predictors(), num_comp = 7)
base_trained <- base_rec |> prep(data_train)
pca_trained <- pca_rec |>
prep(data_train)
pls_trained <- base_trained |>
step_pls(all_numeric_predictors(), outcome = "author", num_comp = 7) |>
prep()
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")Создание пайплайнов и обучение
Warning in checkNumberOfLocalWorkers(workers): Careful, you are setting up 5
localhost parallel workers with only 4 CPU cores available for this R process
(per 'system'), which could result in a 125% load. The soft limit is set to
100%. Overusing the CPUs has negative impact on the current R process, but also
on all other processes of yours and others running on the same machine. See
help("parallelly.maxWorkers.localhost", package = "parallelly") for further
explanations and how to override the soft limit that triggered this warningWarning: пакет 'future' был собран под R версии 4.5.3Warning: пакет 'tune' был собран под R версии 4.5.3Warning: пакет 'future' был собран под R версии 4.5.3Warning: пакет 'tune' был собран под R версии 4.5.3Warning: пакет 'future' был собран под R версии 4.5.3Warning: пакет 'tune' был собран под R версии 4.5.3Warning: пакет 'future' был собран под R версии 4.5.3Warning: пакет 'tune' был собран под R версии 4.5.3Warning: пакет 'future' был собран под R версии 4.5.3Warning: пакет 'tune' был собран под R версии 4.5.3Визуализация точности моделей
autoplot(train_res, metric = "accuracy") +
theme_light() +
theme(legend.position = "none") +
geom_text(aes(y = (mean - 2*std_err), label = wflow_id),
angle = 90, hjust = 1.5) +
coord_cartesian(ylim = c(-0.3, NA))
Таблица результатов моделей
rank_results(train_res, select_best = TRUE) |>
print()# 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_ridge pre0_mod1_po… accura… 0.998 6.48e-4 5 recipe mult… 1
2 base_ridge pre0_mod1_po… f_meas 0.995 1.68e-3 5 recipe mult… 1
3 base_svm pre0_mod1_po… accura… 0.993 4.99e-4 5 recipe svm_… 2
4 base_svm pre0_mod1_po… f_meas 0.988 2.28e-3 5 recipe svm_… 2
5 base_lasso pre0_mod1_po… accura… 0.989 2.21e-3 5 recipe mult… 3
6 base_lasso pre0_mod1_po… f_meas 0.983 4.19e-3 5 recipe mult… 3
7 umap_ridge pre1_mod1_po… accura… 0.876 8.23e-3 5 recipe mult… 4
8 umap_ridge pre1_mod1_po… f_meas 0.905 8.49e-3 5 recipe mult… 4
9 umap_svm pre1_mod1_po… accura… 0.910 5.23e-3 5 recipe svm_… 5
10 umap_svm pre1_mod1_po… f_meas 0.890 1.05e-2 5 recipe svm_… 5
# ℹ 14 more rows## извлечение лучшего результата
best_results <-
train_res |>
extract_workflow_set_result("base_ridge") |>
select_best(metric = "accuracy")
ridge_res <- train_res |>
extract_workflow("base_ridge") |>
finalize_workflow(best_results) |>
last_fit(split = data_split, metrics = metric_set(f_meas, accuracy, roc_auc))
## Визуализация результатов предсказания
collect_predictions(ridge_res) |>
conf_mat(truth = author, estimate = .pred_class) |>
autoplot(type = "heatmap") +
scale_fill_gradient(low = "white", high = "#233857") +
theme(panel.grid.major = element_line(colour = "#233857"),
axis.text = element_text(color = "#233857"),
axis.title = element_text(color = "#233857"),
plot.title = element_text(color = "#233857"),
axis.text.x = element_text(angle = 90))
final_model <- extract_fit_parsnip(ridge_res)Собираем самые важные токены
top_terms <- tidy(final_model) |>
filter(term != "(Intercept)") |>
group_by(class) |>
slice_max(abs(estimate), n = 10) |>
ungroup() |>
mutate(term = fct_reorder(term, abs(estimate)))Warning: пакет 'glmnet' был собран под R версии 4.5.3Cамые важные токены для каждого автора
top_terms |>
ggplot(aes(x = estimate, y = term, fill = class)) +
geom_col(show.legend = FALSE, alpha = 0.85) +
facet_wrap(~ class, scales = "free_y", nrow = 4) +
scale_fill_brewer(palette = "Dark2") +
labs(
title = "Наиболее важные признаки для каждого автора",
x = "Коэффициент",
y = "Признак"
) +
theme_minimal() Warning in RColorBrewer::brewer.pal(n, pal): n too large, allowed maximum for palette Dark2 is 8
Returning the palette you asked for with that many colors
final_modelparsnip model object
Call: glmnet::glmnet(x = maybe_matrix(x), y = y, family = "multinomial", alpha = ~0)
Df %Dev Lambda
1 500 0.00 248.500
2 500 1.40 226.400
3 500 1.52 206.300
4 500 1.67 188.000
5 500 1.83 171.300
6 500 2.00 156.000
7 500 2.19 142.200
8 500 2.40 129.600
9 500 2.63 118.000
10 500 2.87 107.600
11 500 3.14 98.000
12 500 3.44 89.300
13 500 3.76 81.360
14 500 4.10 74.140
15 500 4.48 67.550
16 500 4.89 61.550
17 500 5.34 56.080
18 500 5.81 51.100
19 500 6.33 46.560
20 500 6.89 42.420
21 500 7.50 38.650
22 500 8.16 35.220
23 500 8.87 32.090
24 500 9.63 29.240
25 500 10.44 26.640
26 500 11.32 24.280
27 500 12.25 22.120
28 500 13.25 20.150
29 500 14.31 18.360
30 500 15.44 16.730
31 500 16.64 15.250
32 500 17.91 13.890
33 500 19.25 12.660
34 500 20.66 11.530
35 500 22.14 10.510
36 500 23.69 9.575
37 500 25.31 8.724
38 500 27.00 7.949
39 500 28.76 7.243
40 500 30.58 6.600
41 500 32.45 6.013
42 500 34.38 5.479
43 500 36.36 4.992
44 500 38.38 4.549
45 500 40.43 4.145
46 500 42.51 3.777
47 500 44.61 3.441
48 500 46.72 3.135
49 500 48.84 2.857
50 500 50.94 2.603
51 500 53.04 2.372
52 500 55.11 2.161
53 500 57.15 1.969
54 500 59.16 1.794
55 500 61.12 1.635
56 500 63.04 1.490
57 500 64.91 1.357
58 500 66.72 1.237
59 500 68.47 1.127
60 500 70.17 1.027
61 500 71.80 0.935
62 500 73.37 0.852
63 500 74.88 0.777
64 500 76.32 0.708
65 500 77.70 0.645
66 500 79.02 0.588
67 500 80.27 0.535
68 500 81.46 0.488
69 500 82.60 0.444
70 500 83.67 0.405
71 500 84.69 0.369
72 500 85.65 0.336
73 500 86.56 0.306
74 500 87.42 0.279
75 500 88.23 0.254
76 500 88.99 0.232
77 500 89.71 0.211
78 500 90.39 0.192
79 500 91.02 0.175
80 500 91.62 0.160
81 500 92.18 0.146
82 500 92.70 0.133
83 500 93.19 0.121
84 500 93.65 0.110
85 500 94.09 0.100
86 500 94.49 0.091
87 500 94.87 0.083
88 500 95.22 0.076
89 500 95.55 0.069
90 500 95.86 0.063
91 500 96.15 0.057
92 500 96.42 0.052
93 500 96.67 0.048
94 500 96.90 0.043
95 500 97.12 0.040
96 500 97.32 0.036
97 500 97.51 0.033
98 500 97.69 0.030
99 500 97.86 0.027
100 500 98.01 0.025Выводы
Матрица ошибок демонстрирует высокую точность классификации: большинство текстов были правильно отнесены к своим авторам.
В ходе исследования были протестированы три типа моделей (LASSO, Ridge и SVM) в сочетании с четырьмя методами предобработки данных (базовая нормализация, PCA, PLS и UMAP). Наилучшие результаты показала модель Ridge-регрессии без дополнительного снижения размерности (base_ridge).