23 Регрессионные модели с tidymodels – Компьютерный анализ текста

23.1 Регрессионные алгоритмы

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

полиномиальная регрессия: расширение линейной регрессии, позволяющее учитывать нелинейные зависимости.
логистическая регрессия: используется для прогнозирования категориальных (бинарных) откликов.
регрессия на опорных векторах (SVM): ищет гиперплоскость, позволяющую минимизировать ошибку в многомерном пространстве.
деревья регрессии: строят иерархическую древовидную модель, последовательно разбивая данные на подгруппы.
случайный лес: комбинирует предсказания множества деревьев для повышения точности и устойчивости.

Кроме того, существуют методы регуляризации линейных моделей, позволяющие существенно улучшить их качество на данных большой размерности (т.е. с большим количеством предкторов). К таким алгоритмам относятся гребневая регрессия и метод лассо. О них мы поговорим в одном из следующих уроков.

О математической стороне дела см. Г. Джеймс, Д. Уиттон, Т. Хасти, Р. Тибришани (2017). В этом уроке мы научимся работать с различными регрессионными алгоритмами, используя библиотеку tidymodels.

23.2 Библиотека `tidymodels`

Библиотека tidymodels позволяет обучать модели и оценивать их эффективность с использованием принципов опрятных данных. Она представляет собой набор пакетов R, которые разработаны для работы с машинным обучением и являются частью более широкой экосистемы tidyverse.

Вот некоторые из ключевых пакетов, входящих в состав tidymodels:

parsnip - универсальный интерфейс для различных моделей машинного обучения, который упрощает переключение между разными типами моделей;
recipes - фреймворк для создания и управления “рецептами” предварительной обработки данных перед тренировкой модели;
rsample - инструменты для разделения данных на обучающую и тестовую выборки, а также для кросс-валидации;
tune - функции для оптимизации гиперпараметров моделей машинного обучения;
yardstick - инструменты для оценки производительности моделей;
workflow позволяет объединить различные компоненты модели в единый объект: препроцессинг данных, модель машинного обучения, настройку гиперпараметров.

Мы также будем использовать пакет textrecipes, который представляет собой аналог recipes для текстовых данных.

library(tidyverse)
library(tidymodels)
library(textrecipes)

23.3 Данные

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

books  <- readxl::read_xlsx("../files/AmazonBooks.xlsx")
books

Данные не очень опрятны, и прежде всего их надо тайдифицировать.

colnames(books) <- tolower(colnames(books))
books <- books |> 
  rename(rating = `user rating`)

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

books |> 
  select_if(is.numeric) |> 
  cor() |> 
  corrplot::corrplot(method = "ellipse")

Мы видим, что количественные предикторы объясняют лишь ничтожную долю дисперсии (чуть более информативен жанр).

summary(lm(price ~ reviews + year + rating + genre, data  = books))


Call:
lm(formula = price ~ reviews + year + rating + genre, data = books)

Residuals:
    Min      1Q  Median      3Q     Max 
-16.472  -5.050  -1.841   2.307  89.686 

Coefficients:
                   Estimate Std. Error t value Pr(>|t|)    
(Intercept)       8.987e+02  2.734e+02   3.287  0.00107 ** 
reviews           7.779e-07  3.181e-05   0.024  0.98050    
year             -4.324e-01  1.370e-01  -3.156  0.00168 ** 
rating           -3.655e+00  1.933e+00  -1.891  0.05909 .  
genreNon Fiction  3.920e+00  8.669e-01   4.522 7.41e-06 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 10.16 on 595 degrees of freedom
Multiple R-squared:  0.06903,   Adjusted R-squared:  0.06277 
F-statistic: 11.03 on 4 and 595 DF,  p-value: 1.235e-08

Посмотрим, можно ли как-то улучшить этот результат. Но сначала оценим визуально связь между ценой, с одной стороны, и годом и жанром, с другой.

g1 <- books |> 
  ggplot(aes(year, price, color = genre, group = genre)) + 
  geom_jitter(show.legend = FALSE, alpha = 0.7) + 
  geom_smooth(method = "lm", se = FALSE) +
  theme_minimal()

g2 <- books |> 
  ggplot(aes(genre, price, color = genre)) + 
  geom_boxplot() + 
  theme_minimal()

gridExtra::grid.arrange(g1, g2, nrow = 1)

23.4 Обучающая и контрольная выборка

Вы уже знаете, при обучении модели мы стремимся к минимизации среднеквадратичной ошибки (MSE), однако в большинстве случаев нас интересует не то, как метод работает на обучающих данных, а то, как он покажет себя на контрольных данных. Чтобы избежать переобучения, очень важно в самом начале разделить доступные наблюдения на две группы.

books_split <- books |> 
  initial_split()

books_train <- training(books_split)
books_test <- testing(books_split)

23.5 Определение модели

Определение модели включает следующие шаги:

указывается тип модели на основе ее математической структуры (например, линейная регрессия, случайный лес, KNN и т. д.);
указывается механизм для подгонки модели – чаще всего это программный пакет, который должен быть использован, например glmnet. Это самостоятельные модели, и parsnip обеспечивает согласованные интерфейсы, используя их в качестве движков для моделирования.
при необходимости объявляется режим модели. Режим отражает тип прогнозируемого результата. Для числовых результатов режимом является регрессия, для качественных - классификация. Если алгоритм модели может работать только с одним типом результатов прогнозирования, например, линейной регрессией, режим уже задан.

23.6 Регрессия на опорных векторах

Support Vector Regression — это метод машинного обучения, основанный на идеях метода опорных векторов (SVM), но адаптированный к задаче регрессии, а не классификации (о чем см. следующий урок).

Вместо поиска разделяющей гиперплоскости между классами (как в классификации), SVR старается найти функцию, которая:

игнорирует небольшие отклонения внутри некоторого допустимого порога ε (эпсилон),
акцентирует внимание на точках, которые лежат вне этой “трубы”, — это и есть опорные векторы.

В этом заключается отличие от обычной регрессии, которая старается проложить прямую, наиболее близкую ко всем точкам и “наказывает” любое отклонение.

SVR тоже строит линию (или кривую в случае нелинейного ядра), но с другим подходом. Она “довольна”, если предсказание находится в пределах допустимой ошибки ε (эпсилон) от настоящего значения.

SVR концентрируется только на тех точках, что выходят за эту “зону безразличия” или лежат на ее границе — они называются опорными векторами. Именно они определяют форму и положение модели. Остальные точки (в пределах ε) никак не влияют на модель.

23.7 SVR в `tidymodels`

Функция translate() позволяет понять, как parsnip переводит пользовательский код на язык пакета.

svm_spec <- svm_linear() |>
  set_engine("LiblineaR") |> 
  set_mode("regression")

svm_spec |> 
  translate()

Linear Support Vector Machine Model Specification (regression)

Computational engine: LiblineaR 

Model fit template:
LiblineaR::LiblineaR(x = missing_arg(), y = missing_arg(), type = 11, 
    svr_eps = 0.1)

Пока это просто спецификация модели без данных и без формулы. Добавим ее к воркфлоу.

svm_wflow <- workflow() |> 
  add_model(svm_spec)

svm_wflow

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: None
Model: svm_linear()

── Model ───────────────────────────────────────────────────────────────────────
Linear Support Vector Machine Model Specification (regression)

Computational engine: LiblineaR

23.8 Дизайн переменных

Теперь нам нужен препроцессор. За него отвечает пакет recipes. Если вы не уверены, какие шаги необходимы на этом этапе, можно заглянуть в шпаргалку. В случае с линейной регрессией это может быть логарифмическая трансформация, нормализация, отсев переменных с нулевой дисперсией (zero variance), добавление (impute) недостающих значений или удаление переменных, которые коррелируют с другими переменными.

Вот так выглядит наш первый рецепт. Обратите внимание, что формула записывается так же, как мы это делали ранее внутри функции lm().

books_rec <- recipe(price ~ year + genre + name, 
                    data = books_train) |> 
  step_dummy(genre)  |> 
  step_normalize(year) |> 
  step_tokenize(name)  |> 
  step_tokenfilter(name, max_tokens = 1000)  |> 
  step_tfidf(name)

При желании можно посмотреть на результат предобработки.

prep(books_rec, books_train) |> 
  bake(new_data = NULL) |> 
  head(5) |> 
  gt::gt()

year	price	genre_Non.Fiction	tfidf_name_12	tfidf_name_a	tfidf_name_almost	tfidf_name_an	tfidf_name_and	tfidf_name_antidote	tfidf_name_are	tfidf_name_awesome	tfidf_name_badass	tfidf_name_chaos	tfidf_name_doubting	tfidf_name_everything	tfidf_name_faith	tfidf_name_flap	tfidf_name_food	tfidf_name_for	tfidf_name_god	tfidf_name_greatness	tfidf_name_have	tfidf_name_how	tfidf_name_is	tfidf_name_life	tfidf_name_lift	tfidf_name_little	tfidf_name_living	tfidf_name_p	tfidf_name_path	tfidf_name_potty	tfidf_name_rules	tfidf_name_sesame	tfidf_name_start	tfidf_name_stop	tfidf_name_story	tfidf_name_street	tfidf_name_the	tfidf_name_to	tfidf_name_true	tfidf_name_unexpected	tfidf_name_women	tfidf_name_you	tfidf_name_your
1.0031296	5	1	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.000000	0.0000000	0.5012066	0.0000000	0.2687051	0.0000000	0.0000000	0.0000000	0.0000000	0.4643081	0.000000	0.5012066	0.0000000	0.0000000	0.5574755	0.0000000	0.6022817	0.0000000	0.6022817	0.0000000	0.0000000	0.0000000	0.6022817	0.1124394	0.0000000	0.0000000	0.0000000	0.000000	0.0000000	0.0000000
0.7141358	8	1	0.0000000	0.1065468	0.0000000	0.2146242	0.1119850	0.0000000	0.2529642	0.2819287	0.2957377	0.0000000	0.2957377	0.000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.2957377	0.0000000	0.2146242	0.0000000	0.194396	0.0000000	0.0000000	0.2457391	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.2819287	0.2457391	0.0000000	0.0000000	0.0000000	0.1188463	0.0000000	0.0000000	0.000000	0.1840274	0.2070697
-1.3088208	11	1	0.0000000	0.0000000	0.6111467	0.3433987	0.1791759	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.501728	0.0000000	0.0000000	0.3931826	0.0000000	0.5420535	0.0000000	0.0000000	0.0000000	0.0000000	0.000000	0.0000000	0.0000000	0.0000000	0.0000000	0.4731803	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.1901541	0.0000000	0.5420535	0.501728	0.0000000	0.0000000
1.0031296	15	1	0.7639334	0.0000000	0.0000000	0.4292484	0.0000000	0.7639334	0.0000000	0.0000000	0.0000000	0.7639334	0.0000000	0.000000	0.0000000	0.0000000	0.0000000	0.3022932	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.388792	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.6775669	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.2376926	0.0000000	0.0000000	0.000000	0.0000000	0.0000000
-1.5978146	4	1	0.0000000	0.4870709	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.000000	0.8730668	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.8730668	0.0000000	0.0000000	0.000000	0.0000000	0.5469488	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000	0.5616894	0.0000000	0.0000000	0.0000000	0.7167543	0.0000000	0.000000	0.0000000	0.0000000

Добавляем препроцессор в воркфлоу.

svm_wflow <- svm_wflow |> 
  add_recipe(books_rec)

svm_wflow

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: svm_linear()

── Preprocessor ────────────────────────────────────────────────────────────────
5 Recipe Steps

• step_dummy()
• step_normalize()
• step_tokenize()
• step_tokenfilter()
• step_tfidf()

── Model ───────────────────────────────────────────────────────────────────────
Linear Support Vector Machine Model Specification (regression)

Computational engine: LiblineaR

23.9 Подгонка модели

Подгоним модель на обучающих данных.

svm_fit <- svm_wflow |>
  fit(data = books_train)

Пакет broom позволяет тайдифицировать модель. Посмотрим на слова, которые приводят к “удорожанию” книг. Видно, что в начале списка – слова, связанные с научными публикациями, что не лишено смысла.

svm_fit |> 
  tidy() |> 
  arrange(-estimate) |> 
  head(6) |> 
  gt::gt()

term	estimate
tfidf_name_5th	22.13462
tfidf_name_diagnostic	22.13462
tfidf_name_disorders	22.13462
tfidf_name_dsm	22.13462
tfidf_name_mental	22.13462
tfidf_name_statistical	22.13462

Оценим модель на контрольных данных.

pred_data <- tibble(truth = books_test$price,
                    estimate = predict(svm_fit, books_test)$.pred)

books_metrics <- metric_set(rmse, rsq, mae)

books_metrics(pred_data, truth = truth,  estimate = estimate) |> 
  gt::gt()

.metric	.estimator	.estimate
rmse	standard	8.0599806
rsq	standard	0.2178193
mae	standard	3.9472913

23.10 Повторные выборки

Чтобы не распечатывать каждый раз тестовые данные (в идеале мы их используем один, максимум два раза!), задействуется ряд методов, позволяющих оценить ошибку путем исключения части обучающих наблюдений из процесса подгонки модели и последующего применения этой модели к исключенным наблюдениям.

В пакете rsample из библиотеки tidymodels реализованы, среди прочего, следующие методы повторных выборок для оценки производительности моделей машинного обучения:

Метод проверочной выборки – набор наблюдений делится на обучающую и проверочную, или удержанную, выборку (validation set): для этого используется initial_validation_split().
K-кратная перекрестная проверка – наблюдения разбиваются на k групп примерно одинакового размера, первый блок служит в качестве проверочной выборки, а модель подгоняется по остальным k-1 блокам; процедура повторяется k раз: функция vfold_cv().
Перекрестная проверка Монте-Карло – в отличие от предыдущего метода, создается множество случайных разбиений данных на обучающую и тестовую выборки: функция mc_cv().
Бутстреп – отбор наблюдений выполняется с возвращением, т.е. одно и то же наблюдение может встречаться несколько раз: функция bootstraps().
Перекрестная проверка по отдельным наблюдениям (leave-one-out сross-validation): одно наблюдение используется в качестве контрольного, а остальные составляют обучающую выборку; модель подгоняется по n-1 наблюдениям, что повторяется n раз: функция loo_cv().

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

set.seed(05102024)
books_folds <- vfold_cv(books_train, v = 10) 

set.seed(05102024)
svm_rs <- fit_resamples(
  svm_wflow,
  books_folds,
  control = control_resamples(save_pred = TRUE)
)

Теперь соберем метрики и убедимся, что предыдущая оценка на контрольных данных была слишком оптимистичной. Однако результат не так уж плох: во всяком случае мы смогли добиться заметного улучшения по сравнению с нулевой моделью.

collect_metrics(svm_rs) |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	7.7160268	10	0.69827622	Preprocessor1_Model1
rsq	standard	0.4673747	10	0.09020819	Preprocessor1_Model1

svm_rs |> 
  collect_predictions() |> 
  ggplot(aes(price, .pred, color = id)) +
  geom_jitter(alpha = 0.3) +
  geom_abline(lty = 2, color = "grey80") + 
  theme_minimal() +
  coord_cartesian(xlim = c(0,50), ylim = c(0,50))

23.11 Нулевая модель

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

null_reg <- null_model() |> 
  set_engine("parsnip") |> 
  set_mode("regression")

null_wflow <- workflow() |> 
    add_model(null_reg) |> 
    add_recipe(books_rec)

null_rs <- fit_resamples(
  null_wflow,
  books_folds,
  control = control_resamples(save_pred = TRUE)
  )

→ A | warning: A correlation computation is required, but `estimate` is constant and has 0
               standard deviation, resulting in a divide by 0 error. `NA` will be returned.

There were issues with some computations   A: x1

There were issues with some computations   A: x8

There were issues with some computations   A: x10

collect_metrics(null_rs) |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	10.38916	10	1.161447	Preprocessor1_Model1
rsq	standard	NaN	0	NA	Preprocessor1_Model1

\(R^2\) в таком случае должен быть NaN.

23.12 Деревья решений: понятия

Деревья решений применяются как для задача регрессии, так и для задач классификации.

Регрессионные деревья строят последовательное разбиение пространства признаков таким образом, чтобы минимизировать среднеквадратичную ошибку (MSE) в каждом из подмножеств.

Для этого данные делятся на группы, в которых отклик (целевое значение) как можно более “однороден”. Каждое разбиение осуществляется на основе признаков (факторов), а в листьях дерева находятся средние значения отклика для соответствующей подгруппы. Вот так, например, может выглядеть предсказание расхода топлива для автомобиля (на основе датасета mtcars).

Деревья легко показать графически, их легко интерпретировать, они хорошо справляются с категориальными предикторами (без создания dummy variables). Они особенно хорошо подходят для тех случаев, когда между откликом и предикторами существует нелинейная и сложная зависимость.

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

Чтобы с этим справиться, используют три основных метода: бэггинг, случайный лес и бустинг.

23.13 Бэггинг, случайный лес, бустинг

Бэггинг — это метод построения ансамбля моделей путем:

повторного случайного выбора подвыборок из обучающего набора данных (бутстрэп);
обучения на каждой из этих подвыборок дерева решений;
объединения (агрегации) результатов предсказаний этих моделей (для регрессии – усреднение предсказаний; для классификации: голосование).

Хотя бэггинг может улучшить предсказания многих методов, он особено полезен для деревьев решений.

Случайный лес – это частный случай бэггинга. Каждое дерево обучается на случайной выборке с возвращением (бутстрэп), но при построении дерева выбираются не все признаки, а случайное подмножество признаков. Это снижает корреляцию между деревьями и повышает качество ансамбля.
Бустинг работает похожим образом, но деревья строятся последовательно: каждое дерево выращивается с использованием информации по ранее выращенным деревьям. Бустинг не задействует бутстрэп, деревья обучаются на всем наборе данных. Из-за того, что деревья обучаются последовательно, его сложнее запараллелить.

Случайный лес и бустинг плохо поддаются интерпретации.

23.14 Случайный лес в `tidymodels`

Уточним, какие движки доступны для случайных лесов.

show_engines("rand_forest")

Создадим спецификацию модели. Деревья используются как в задачах классификации, так и в задачах регрессии, поэтому задействуем функцию set_mode().

rf_spec <- rand_forest(trees = 1000) |> 
  set_engine("ranger") |> 
  set_mode("regression")

rf_wflow <- workflow() |> 
  add_model(rf_spec) |> 
  add_recipe(books_rec)

rf_wflow

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: rand_forest()

── Preprocessor ────────────────────────────────────────────────────────────────
5 Recipe Steps

• step_dummy()
• step_normalize()
• step_tokenize()
• step_tokenfilter()
• step_tfidf()

── Model ───────────────────────────────────────────────────────────────────────
Random Forest Model Specification (regression)

Main Arguments:
  trees = 1000

Computational engine: ranger

Обучение займет чуть больше времени.

rf_rs <- fit_resamples(
  rf_wflow,
  books_folds,
  control = control_resamples(save_pred = TRUE)
)

Мы видим, что среднеквадратическая ошибка уменьшилась, а доля объясненной дисперсии выросла.

collect_metrics(rf_rs)  |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	6.5280907	10	0.49714066	Preprocessor1_Model1
rsq	standard	0.5787228	10	0.06581642	Preprocessor1_Model1

Тем не менее на графике можно заметить нечто странное: наша модель систематически переоценивает низкие значения и недооценивает высокие. Это связано с тем, что случайные леса не очень подходят для работы с разреженными данными (Hvitfeldt и Silge 2022).

rf_rs |> 
  collect_predictions() |> 
  ggplot(aes(price, .pred, color = id)) +
  geom_jitter(alpha = 0.3) +
  geom_abline(lty = 2, color = "grey80") +
  theme_minimal() +
  coord_cartesian(xlim = c(0, 50), ylim = c(0, 50))

23.15 Градиентные бустинговые деревья

Также попробуем построить регрессию с использованием градиентных бустинговых деревьев. В 2023 г. эта техника показала хорошие результаты в эксперименте по датировке греческих документальных папирусов.

xgb_spec <- 
  boost_tree(mtry = 50, trees = 1000)  |> 
  set_engine("xgboost")  |> 
  set_mode("regression")

xgb_wflow <- workflow() |> 
  add_model(xgb_spec) |> 
  add_recipe(books_rec)

xgb_wflow

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: boost_tree()

── Preprocessor ────────────────────────────────────────────────────────────────
5 Recipe Steps

• step_dummy()
• step_normalize()
• step_tokenize()
• step_tokenfilter()
• step_tfidf()

── Model ───────────────────────────────────────────────────────────────────────
Boosted Tree Model Specification (regression)

Main Arguments:
  mtry = 50
  trees = 1000

Computational engine: xgboost

Проводим перекрестную проверку.

xgb_rs <- fit_resamples(
  xgb_wflow,
  books_folds,
  control = control_resamples(save_pred = TRUE)
)

collect_metrics(xgb_rs)  |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	7.4865979	10	0.52910597	Preprocessor1_Model1
rsq	standard	0.4834618	10	0.07396304	Preprocessor1_Model1

Метрики неплохие! Но если взглянуть на остатки, можно увидеть что-то вроде буквы S.

rf_rs |> 
  collect_predictions() |> 
  ggplot(aes(price, .pred, color = id)) +
  geom_jitter(alpha = 0.3) +
  geom_abline(lty = 2, color = "grey80") +
  theme_minimal() +
  coord_cartesian(xlim = c(0, 50), ylim = c(0, 50))

23.16 Удаление стопслов

Изменим рецепт приготовления данных.

stopwords_rec <- function(stopwords_name) {
  recipe(price ~ year + genre + name, data = books_train) |> 
  step_dummy(genre)  |> 
  step_normalize(year) |> 
  step_tokenize(name)  |> 
  step_stopwords(name, stopword_source = stopwords_name) |> 
  step_tokenfilter(name, max_tokens = 1000)  |> 
  step_tfidf(name) 
}

Создадим воркфлоу.

svm_wflow <- workflow() |> 
  add_model(svm_spec)

И снова проведем перекрестную проверку, на этот раз с разными списками стоп-слов. На этом шаге команда вернет предупреждения о том, что число слов меньше 1000, это нормально, т.к. после удаления стопслов токенов стало меньше.

set.seed(123)
snowball_rs <- fit_resamples(
  svm_wflow |>  add_recipe(stopwords_rec("snowball")),
  books_folds
)

set.seed(234)
smart_rs <- fit_resamples(
  svm_wflow |> add_recipe(stopwords_rec("smart")),
  books_folds
)

set.seed(345)
stopwords_iso_rs <- fit_resamples(
  svm_wflow |> add_recipe(stopwords_rec("stopwords-iso")),
  books_folds
)

collect_metrics(smart_rs)  |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	7.881703	10	0.39913002	Preprocessor1_Model1
rsq	standard	0.442588	10	0.08075147	Preprocessor1_Model1

collect_metrics(snowball_rs) |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	7.6361664	10	0.41158411	Preprocessor1_Model1
rsq	standard	0.4582287	10	0.08018042	Preprocessor1_Model1

collect_metrics((stopwords_iso_rs)) |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	8.0260370	10	0.35141531	Preprocessor1_Model1
rsq	standard	0.4388275	10	0.07788576	Preprocessor1_Model1

В нашем случае удаление стоп-слов положительного эффекта не имело.

word_counts <- tibble(name = c("snowball", "smart", "stopwords-iso")) %>%
  mutate(words = map_int(name, ~length(stopwords::stopwords(source = .))))

list(snowball = snowball_rs,
     smart = smart_rs,
     `stopwords-iso` = stopwords_iso_rs)  |> 
  map_dfr(show_best, metric = "rmse", .id = "name")  |> 
  left_join(word_counts, by = "name")  |> 
  mutate(name = paste0(name, " (", words, " words)"),
         name = fct_reorder(name, words))  |> 
  ggplot(aes(name, mean, color = name)) +
  geom_crossbar(aes(ymin = mean - std_err, ymax = mean + std_err), alpha = 0.6) +
  geom_point(size = 3, alpha = 0.8) +
  theme(legend.position = "none") + 
  theme_minimal()

23.17 Настройки числа n-grams

ngram_rec <- function(ngram_options) {
  recipe(price ~ year + genre + name, data = books_train) |> 
  step_dummy(genre)  |> 
  step_normalize(year) |> 
  step_tokenize(name, token = "ngrams", options = ngram_options)  |> 
  step_tokenfilter(name, max_tokens = 1000)  |> 
  step_tfidf(name) 
}

fit_ngram <- function(ngram_options) {
  fit_resamples(
    svm_wflow  |> 
    add_recipe(ngram_rec(ngram_options)),
    books_folds
  )
}

set.seed(123)
unigram_rs <- fit_ngram(list(n = 1))

set.seed(234)
bigram_rs <- fit_ngram(list(n = 2, n_min = 1))

set.seed(345)
trigram_rs <- fit_ngram(list(n = 3, n_min = 1))

collect_metrics(unigram_rs) |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	7.7160268	10	0.69827622	Preprocessor1_Model1
rsq	standard	0.4673747	10	0.09020819	Preprocessor1_Model1

collect_metrics(bigram_rs) |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	7.2108600	10	0.38677343	Preprocessor1_Model1
rsq	standard	0.4771493	10	0.07009008	Preprocessor1_Model1

collect_metrics(trigram_rs) |> 
  gt::gt()

.metric	.estimator	mean	n	std_err	.config
rmse	standard	7.479379	10	0.44739644	Preprocessor1_Model1
rsq	standard	0.467884	10	0.06368306	Preprocessor1_Model1

Таким образом, униграмы дают лучший результат:

list(`1` = unigram_rs,
     `1 and 2` = bigram_rs,
     `1, 2, and 3` = trigram_rs) |> 
  map_dfr(collect_metrics, .id = "name")  |> 
  filter(.metric == "rmse")  |> 
  ggplot(aes(name, mean, color = name)) +
  geom_crossbar(aes(ymin = mean - std_err, ymax = mean + std_err), 
                alpha = 0.6) +
  geom_point(size = 3, alpha = 0.8) +
  theme(legend.position = "none") +
  labs(
    y = "RMSE"
  ) + 
  theme_minimal()

23.18 Лучшая модель и оценка

svm_fit <- svm_wflow |>
  add_recipe(books_rec) |> 
  fit(data = books_test)

Warning: max_tokens was set to 1000, but only 519 was available and selected.

svm_fit

══ Workflow [trained] ══════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: svm_linear()

── Preprocessor ────────────────────────────────────────────────────────────────
5 Recipe Steps

• step_dummy()
• step_normalize()
• step_tokenize()
• step_tokenfilter()
• step_tfidf()

── Model ───────────────────────────────────────────────────────────────────────
$TypeDetail
[1] "L2-regularized L2-loss support vector regression primal (L2R_L2LOSS_SVR)"

$Type
[1] 11

$W
          year genre_Non.Fiction tfidf_name_1 tfidf_name_10 tfidf_name_100
[1,] -1.520238          2.066713    -4.793447     -2.403936      -1.802735
     tfidf_name_11 tfidf_name_14 tfidf_name_15 tfidf_name_1936 tfidf_name_2.0
[1,]      3.607565   -0.01058476    -0.4253752      -0.2957425      0.8642611
     tfidf_name_3 tfidf_name_4 tfidf_name_451 tfidf_name_49 tfidf_name_5
[1,]    -1.996153    -1.894541      -0.349303       1.02874    -1.376993
     tfidf_name_500 tfidf_name_6 tfidf_name_6th tfidf_name_7 tfidf_name_a
[1,]      0.3061039   -0.8640108        7.62841     2.724701    -2.022854
     tfidf_name_about tfidf_name_acid tfidf_name_act tfidf_name_adult
[1,]        0.8368777        1.897636      0.4972617        -1.490207
     tfidf_name_adults tfidf_name_advanced tfidf_name_after
[1,]       -0.09387077           0.3061039       -0.2481804
     tfidf_name_afterlife tfidf_name_ages tfidf_name_agreements tfidf_name_air
[1,]           -0.9194414      -0.5591052              -1.30218      0.5562863
     tfidf_name_alchemist tfidf_name_all tfidf_name_alphabet tfidf_name_am
[1,]             9.643137       1.518092          -0.5591052    0.05458998
     tfidf_name_amazing tfidf_name_america's tfidf_name_american
[1,]          -1.391954            0.0276968            5.288851
     tfidf_name_americans tfidf_name_an tfidf_name_ancient tfidf_name_and
[1,]           -0.2957425     0.4403215          0.0276968     -0.9599414
     tfidf_name_angie's tfidf_name_animal tfidf_name_animals tfidf_name_are
[1,]         -0.1783316        -0.2104393          -1.843032      0.4204923
     tfidf_name_art tfidf_name_as tfidf_name_association tfidf_name_astounding
[1,]     0.09081542    -0.3419302                7.62841            -0.4254951
     tfidf_name_at tfidf_name_atomic tfidf_name_back tfidf_name_bad
[1,]     0.0524675       -0.03391317       -3.710758    -0.03391317
     tfidf_name_balance tfidf_name_ball tfidf_name_barefoot tfidf_name_be
[1,]         -0.1783316     -0.01058476            1.437301     0.4204923
     tfidf_name_bear tfidf_name_beasts tfidf_name_beautiful tfidf_name_become
[1,]       -1.160322          1.833383           0.05458998         0.4204923
     tfidf_name_becomes tfidf_name_beginners tfidf_name_believing
[1,]          0.5562863            0.3061039            0.4204923
     tfidf_name_berlin tfidf_name_better tfidf_name_between tfidf_name_big
[1,]          1.278907          1.080442        -0.05331562     -0.5591052
     tfidf_name_bill tfidf_name_birth tfidf_name_blood tfidf_name_boat
[1,]       0.3222009         1.167256       -0.8230085      -0.2957425
     tfidf_name_book tfidf_name_books tfidf_name_boxed tfidf_name_boy's
[1,]       -9.466271        -3.582869         4.565776       -0.4254951
     tfidf_name_boys tfidf_name_brave tfidf_name_brawl tfidf_name_break
[1,]      -0.2957425       0.05458998       -0.8640108      -0.03391317
     tfidf_name_breaking tfidf_name_breath tfidf_name_brigance tfidf_name_brown
[1,]           -3.582468         0.5562863            1.301934        -1.160322
     tfidf_name_build tfidf_name_bundo tfidf_name_burn tfidf_name_by

...
and 238 more lines.

Взглянем на остатки. Для этого пригодится уже знакомая функция augment() из пакета broom.

svm_res <- augment(svm_fit, new_data = books_test) |> 
  mutate(res = price - .pred) |> 
  select(price, .pred, res)

svm_res |> 
  head(6) |> 
  gt::gt()

price	.pred	res
8	8.429922	-0.429922461
5	5.602691	-0.602691055
17	16.178382	0.821618312
4	5.445476	-1.445476436
6	6.176515	-0.176515259
6	6.001730	-0.001730247

library(gridExtra)

g1 <- svm_res |> 
  mutate(res = price - .pred) |> 
  ggplot(aes(res)) +
  geom_histogram(fill = "steelblue", color  = "white") +
  theme_minimal()

g2 <- svm_res |> 
  ggplot(aes(price, .pred)) +
  geom_jitter(color = "steelblue", alpha = 0.7) +
  geom_abline(linetype = 2, color = "grey80", linewidth = 2) +
  theme_minimal()

grid.arrange(g1, g2, nrow = 1)

Соберем метрики.

books_metrics <- metric_set(rmse, rsq, mae)
books_metrics(svm_res, truth = price,  estimate = .pred)

Также посмотрим, какие слова больше всего связаны с увеличением и с уменьшением цены.

svm_fit |> 
  tidy() |> 
  filter(term != "year") |> 
  filter(!str_detect(term, "genre")) |> 
  mutate(sign = case_when(estimate > 0 ~ "дороже",
                          .default = "дешевле"),
         estimate = abs(estimate), 
         term = str_remove_all(term, "tfidf_name_")) |> 
  group_by(sign) |> 
  top_n(20, estimate) |> 
  ungroup() |> 
  ggplot(aes(x = estimate, y = fct_reorder(term, estimate),
             fill = sign)) +
  geom_col(show.legend = FALSE) +
  scale_x_continuous(expand = c(0,0)) +
  facet_wrap(~sign, scales = "free") +
  labs(y = NULL, 
       title = "Связь слов с ценой книг") +
  theme_minimal()

Любопытно: судя по нашему датасету, конституция США раздается на Амазоне бесплатно.