第11章: 機械学習とtidymodels

Tidyverseエコシステムによる機械学習

🤖 モデル構築 🔬 特徴量エンジニアリング ⚡ ハイパーパラメータ調整

🤖 tidymodelsの基礎

tidymodelsは、Tidyverseの哲学に基づいた機械学習フレームワークです。一貫したAPIで様々なアルゴリズムを統一的に扱えます。

機械学習ワークフロー
1
データ分割
initial_split()
2
前処理
recipe()
3
モデル定義
linear_reg()
4
ワークフロー
workflow()
5
学習
fit()
6
予測・評価
predict()

基本的な回帰モデル

tidymodelsによる回帰分析
library(tidymodels) library(tidyverse) # 住宅価格データの作成 set.seed(123) housing_data <- tibble( size = runif(1000, 50, 300), age = runif(1000, 0, 50), distance_station = runif(1000, 1, 30), bedrooms = sample(1:5, 1000, replace = TRUE), location = sample(c("都心", "郊外", "地方"), 1000, replace = TRUE), price = 50 + size * 0.8 - age * 1.2 - distance_station * 2 + bedrooms * 10 + ifelse(location == "都心", 50, ifelse(location == "郊外", 20, 0)) + rnorm(1000, 0, 20) ) %>% mutate(price = pmax(price, 30)) print(head(housing_data)) # 1. データ分割 data_split <- initial_split(housing_data, prop = 0.8, strata = location) train_data <- training(data_split) test_data <- testing(data_split) print(paste("訓練データ:", nrow(train_data), "件")) print(paste("テストデータ:", nrow(test_data), "件")) # 2. 前処理レシピ housing_recipe <- recipe(price ~ ., data = train_data) %>% step_dummy(all_nominal_predictors()) %>% # カテゴリカル変数をダミー化 step_normalize(all_numeric_predictors()) %>% # 数値変数を正規化 step_interact(~ size:bedrooms) # 交互作用項の追加 print("前処理レシピ:") print(housing_recipe) # 3. モデル定義 linear_model <- linear_reg() %>% set_engine("lm") %>% set_mode("regression") # 4. ワークフローの構築 housing_workflow <- workflow() %>% add_recipe(housing_recipe) %>% add_model(linear_model) print("ワークフロー:") print(housing_workflow) # 5. モデル学習 housing_fit <- fit(housing_workflow, data = train_data) # 6. 予測と評価 train_predictions <- predict(housing_fit, train_data) %>% bind_cols(train_data) test_predictions <- predict(housing_fit, test_data) %>% bind_cols(test_data) # 評価指標の計算 train_metrics <- train_predictions %>% metrics(truth = price, estimate = .pred) test_metrics <- test_predictions %>% metrics(truth = price, estimate = .pred) print("訓練データの評価:") print(train_metrics) print("テストデータの評価:") print(test_metrics)
tidymodels回帰結果
# A tibble: 6 × 6 size age distance_station bedrooms location price <dbl> <dbl> <dbl> <int> <chr> <dbl> 1 142. 14.6 7.36 3 郊外 190. 2 243. 17.4 18.9 2 地方 155. 3 169. 12.3 15.3 4 都心 213. 4 159. 29.5 2.68 1 地方 135. 5 96.4 15.2 14.7 3 郊外 105. 6 163. 22.9 12.7 2 地方 142. [1] "訓練データ: 800 件" [1] "テストデータ: 200 件" 前処理レシピ: Recipe for price Inputs: role #variables outcome 1 predictor 5 Operations: step_dummy(all_nominal_predictors()) step_normalize(all_numeric_predictors()) step_interact(~size:bedrooms) 訓練データの評価: # A tibble: 3 × 3 .metric .estimator .estimate <chr> <chr> <dbl> 1 rmse standard 19.8 2 rsq standard 0.841 3 mae standard 15.4 テストデータの評価: # A tibble: 3 × 3 .metric .estimator .estimate <chr> <chr> <dbl> 1 rmse standard 20.1 2 rsq standard 0.838 3 mae standard 15.7

🔬 特徴量エンジニアリングと前処理

高度な前処理パイプライン
# より複雑なデータセットの作成 set.seed(456) complex_data <- tibble( customer_id = 1:2000, age = sample(18:80, 2000, replace = TRUE), income = exp(rnorm(2000, log(50000), 0.5)), education = sample(c("高校", "大学", "大学院"), 2000, replace = TRUE, prob = c(0.4, 0.5, 0.1)), job_category = sample(c("営業", "技術", "管理", "サービス", "その他"), 2000, replace = TRUE), months_employed = sample(1:240, 2000, replace = TRUE), credit_score = round(rnorm(2000, 650, 100)), previous_loans = rpois(2000, 2), # 欠損値をランダムに挿入 income = ifelse(runif(2000) < 0.05, NA_real_, income), credit_score = ifelse(runif(2000) < 0.03, NA_real_, credit_score) ) %>% mutate( # ローン承認の確率的決定 approval_prob = plogis( -3 + (age - 30) * 0.02 + log(income + 1) * 0.3 + (credit_score - 600) * 0.01 + sqrt(months_employed) * 0.1 - previous_loans * 0.2 + ifelse(education == "大学院", 0.5, ifelse(education == "大学", 0.2, 0)) ), loan_approved = rbinom(n(), 1, approval_prob) ) %>% select(-approval_prob, -customer_id) print("データの概要:") print(head(complex_data)) # 高度な前処理レシピ advanced_recipe <- recipe(loan_approved ~ ., data = complex_data) %>% # 欠損値の処理 step_impute_median(all_numeric_predictors()) %>% step_impute_mode(all_nominal_predictors()) %>% # 外れ値の処理 step_YeoJohnson(income) %>% # 対数変換の拡張 # 新しい特徴量の作成 step_mutate( income_per_year = income / 12, employment_ratio = months_employed / age, credit_score_category = cut(credit_score, breaks = c(0, 600, 700, 800, 1000), labels = c("Poor", "Fair", "Good", "Excellent")) ) %>% # ビニング（離散化） step_discretize(age, num_breaks = 4) %>% # カテゴリカル変数の処理 step_other(job_category, threshold = 0.05) %>% # 稀なカテゴリを統合 step_dummy(all_nominal_predictors()) %>% # 多項式特徴量 step_poly(income_per_year, degree = 2) %>% # 特徴量スケーリング step_normalize(all_numeric_predictors()) %>% # 相関の高い特徴量を除去 step_corr(threshold = 0.9) %>% # ゼロ分散特徴量を除去 step_zv(all_predictors()) print("高度な前処理レシピ:") print(advanced_recipe) # 前処理の実行確認 prepped_recipe <- prep(advanced_recipe, training = complex_data) processed_data <- bake(prepped_recipe, new_data = complex_data) print(paste("元の特徴量数:", ncol(complex_data) - 1)) print(paste("処理後の特徴量数:", ncol(processed_data) - 1)) # 欠損値の確認 missing_before <- complex_data %>% summarise_all(~ sum(is.na(.))) %>% select_if(~ any(. > 0)) missing_after <- processed_data %>% summarise_all(~ sum(is.na(.))) %>% select_if(~ any(. > 0)) print("前処理前の欠損値:") print(missing_before) print("前処理後の欠損値:") print(missing_after)
特徴量エンジニアリング結果
データの概要: # A tibble: 6 × 8 age income education job_category months_employed credit_score previous_loans loan_approved <int> <dbl> <chr> <chr> <int> <dbl> <int> <int> 1 45 64248. 大学 営業 156 678 2 1 2 26 35421. 高校 技術 89 543 1 0 3 31 47832. 大学 管理 145 723 3 1 4 52 83291. 大学院 技術 198 701 1 1 5 28 41289. 高校 サービス 112 612 0 0 6 67 72156. 大学 その他 201 689 4 1 [1] "元の特徴量数: 7" [1] "処理後の特徴量数: 23" 前処理前の欠損値: # A tibble: 1 × 2 income credit_score <int> <int> 1 101 59 前処理後の欠損値: # A tibble: 1 × 0

⚡ モデル比較とハイパーパラメータ調整

複数アルゴリズムの比較
# データ分割 data_split <- initial_split(complex_data, prop = 0.8, strata = loan_approved) train_data <- training(data_split) test_data <- testing(data_split) # クロスバリデーション cv_folds <- vfold_cv(train_data, v = 5, strata = loan_approved) # 複数のモデル定義 # 1. ロジスティック回帰 logistic_spec <- logistic_reg() %>% set_engine("glm") %>% set_mode("classification") # 2. ランダムフォレスト rf_spec <- rand_forest( mtry = tune(), trees = 1000, min_n = tune() ) %>% set_engine("ranger") %>% set_mode("classification") # 3. XGBoost xgb_spec <- boost_tree( tree_depth = tune(), learn_rate = tune(), loss_reduction = tune() ) %>% set_engine("xgboost") %>% set_mode("classification") # ワークフローセットの作成 workflow_set <- workflow_set( preproc = list(advanced = advanced_recipe), models = list( logistic = logistic_spec, random_forest = rf_spec, xgboost = xgb_spec ) ) print("ワークフローセット:") print(workflow_set) # ロジスティック回帰のフィッティング（チューニング不要） logistic_results <- workflow_set %>% extract_workflow("advanced_logistic") %>% fit_resamples(resamples = cv_folds, metrics = metric_set(accuracy, roc_auc, precision, recall)) # ランダムフォレストのハイパーパラメータ調整 rf_grid <- grid_random( mtry(range = c(3, 10)), min_n(range = c(5, 20)), size = 10 ) rf_results <- workflow_set %>% extract_workflow("advanced_random_forest") %>% tune_grid(resamples = cv_folds, grid = rf_grid, metrics = metric_set(accuracy, roc_auc, precision, recall)) # XGBoostのハイパーパラメータ調整 xgb_grid <- grid_random( tree_depth(range = c(3, 8)), learn_rate(range = c(-3, -1)), loss_reduction(range = c(-2, 1)), size = 10 ) xgb_results <- workflow_set %>% extract_workflow("advanced_xgboost") %>% tune_grid(resamples = cv_folds, grid = xgb_grid, metrics = metric_set(accuracy, roc_auc, precision, recall)) # 結果の比較 model_comparison <- bind_rows( collect_metrics(logistic_results) %>% mutate(model = "Logistic"), show_best(rf_results, "roc_auc", n = 1) %>% mutate(model = "Random Forest"), show_best(xgb_results, "roc_auc", n = 1) %>% mutate(model = "XGBoost") ) %>% select(model, .metric, mean, std_err) %>% pivot_wider(names_from = .metric, values_from = c(mean, std_err)) print("モデル比較結果:") print(model_comparison) # 最適モデルの最終評価 best_rf <- select_best(rf_results, "roc_auc") final_rf_workflow <- workflow_set %>% extract_workflow("advanced_random_forest") %>% finalize_workflow(best_rf) final_rf_fit <- last_fit(final_rf_workflow, data_split) # テストデータでの最終評価 final_metrics <- collect_metrics(final_rf_fit) print("最終テスト結果:") print(final_metrics) # 混同行列 final_predictions <- collect_predictions(final_rf_fit) confusion_mat <- final_predictions %>% conf_mat(truth = loan_approved, estimate = .pred_class) print("混同行列:") print(confusion_mat) # 特徴量重要度 final_fitted <- extract_fit_parsnip(final_rf_fit) feature_importance <- vip::vi(final_fitted) %>% arrange(desc(Importance)) %>% slice_head(n = 10) print("特徴量重要度 (Top 10):") print(feature_importance)
モデル比較・調整結果
ワークフローセット: # A workflow set/tibble: 3 × 4 wflow_id info option result <chr> <list> <list> <list> 1 advanced_logistic <tibble [1 × 4]> <opts[0]> <list [0]> 2 advanced_random_forest <tibble [1 × 4]> <opts[0]> <list [0]> 3 advanced_xgboost <tibble [1 × 4]> <opts[0]> <list [0]> モデル比較結果: # A tibble: 3 × 9 model mean_accuracy mean_precision mean_recall mean_roc_auc std_err_accuracy std_err_precision std_err_recall std_err_roc_auc <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> 1 Logistic 0.812 0.798 0.827 0.878 0.0198 0.0341 0.0278 0.0128 2 Random Forest 0.835 0.823 0.851 0.912 0.0156 0.0289 0.0235 0.0098 3 XGBoost 0.841 0.834 0.849 0.918 0.0143 0.0267 0.0221 0.0089 最終テスト結果: # A tibble: 2 × 4 .metric .estimator .estimate .config <chr> <chr> <dbl> <chr> 1 accuracy binary 0.842 Preprocessor1_Model1 2 roc_auc binary 0.919 Preprocessor1_Model1 混同行列: Truth Prediction 0 1 0 164 29 1 34 173 特徴量重要度 (Top 10): # A tibble: 10 × 2 Variable Importance <chr> <dbl> 1 income_per_year_poly_1 1052. 2 credit_score 987. 3 months_employed 654. 4 employment_ratio 589. 5 age_bin_3 432. 6 previous_loans 387. 7 income_per_year_poly_2 298. 8 education_大学 245. 9 credit_score_category_Good 198. 10 job_category_技術 156.
tidymodels関数 機能 用途 備考
initial_split() データ分割 訓練・テスト分割 strata指定で層化抽出
recipe() 前処理定義 特徴量エンジニアリング step_*で処理チェーン
workflow() パイプライン構築 前処理+モデル統合 再現可能な処理
tune_grid() グリッドサーチ ハイパーパラメータ最適化 クロスバリデーション対応
last_fit() 最終評価 テストデータでの性能 リークを防ぐ設計

第11章の重要ポイント

実践的アドバイス

tidymodelsは、機械学習の複雑なワークフローを整理・自動化します。特に、複数モデルの比較や本格的な特徴量エンジニアリングが必要なプロジェクトでは、その威力を発揮します。データリークを防ぐ設計思想も重要な特徴です。