CodeAlong8
Maddie Westbrook
2024-04-18
Goal: to predict attrition, employees who are likely to leave the company.
library(tidyverse)## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ ggplot2 3.5.0 ✔ tibble 3.2.1
## ✔ lubridate 1.9.3 ✔ tidyr 1.3.1
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorslibrary(correlationfunnel)## ══ correlationfunnel Tip #2 ════════════════════════════════════════════════════
## Clean your NA's prior to using `binarize()`.
## Missing values and cleaning data are critical to getting great correlations. :)library(tidymodels)## ── Attaching packages ────────────────────────────────────── tidymodels 1.2.0 ──
## ✔ broom 1.0.5 ✔ rsample 1.2.1
## ✔ dials 1.2.1 ✔ tune 1.2.0
## ✔ infer 1.0.7 ✔ workflows 1.1.4
## ✔ modeldata 1.3.0 ✔ workflowsets 1.1.0
## ✔ parsnip 1.2.1 ✔ yardstick 1.3.1
## ✔ recipes 1.0.10
## ── Conflicts ───────────────────────────────────────── tidymodels_conflicts() ──
## ✖ scales::discard() masks purrr::discard()
## ✖ dplyr::filter() masks stats::filter()
## ✖ recipes::fixed() masks stringr::fixed()
## ✖ dplyr::lag() masks stats::lag()
## ✖ yardstick::spec() masks readr::spec()
## ✖ recipes::step() masks stats::step()
## • Learn how to get started at https://www.tidymodels.org/start/library(vip)##
## Attaching package: 'vip'
##
## The following object is masked from 'package:utils':
##
## vilibrary(usemodels)
data <- read_csv("../00_data/WA_Fn-UseC_-HR-Employee-Attrition.csv")## Rows: 1470 Columns: 35
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (9): Attrition, BusinessTravel, Department, EducationField, Gender, Job...
## dbl (26): Age, DailyRate, DistanceFromHome, Education, EmployeeCount, Employ...
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.Clean data
skimr::skim(data)| Name | data |
| Number of rows | 1470 |
| Number of columns | 35 |
| _______________________ | |
| Column type frequency: | |
| character | 9 |
| numeric | 26 |
| ________________________ | |
| Group variables | None |
Variable type: character
| skim_variable | n_missing | complete_rate | min | max | empty | n_unique | whitespace |
|---|---|---|---|---|---|---|---|
| Attrition | 0 | 1 | 2 | 3 | 0 | 2 | 0 |
| BusinessTravel | 0 | 1 | 10 | 17 | 0 | 3 | 0 |
| Department | 0 | 1 | 5 | 22 | 0 | 3 | 0 |
| EducationField | 0 | 1 | 5 | 16 | 0 | 6 | 0 |
| Gender | 0 | 1 | 4 | 6 | 0 | 2 | 0 |
| JobRole | 0 | 1 | 7 | 25 | 0 | 9 | 0 |
| MaritalStatus | 0 | 1 | 6 | 8 | 0 | 3 | 0 |
| Over18 | 0 | 1 | 1 | 1 | 0 | 1 | 0 |
| OverTime | 0 | 1 | 2 | 3 | 0 | 2 | 0 |
Variable type: numeric
| skim_variable | n_missing | complete_rate | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|
| Age | 0 | 1 | 36.92 | 9.14 | 18 | 30.00 | 36.0 | 43.00 | 60 | ▂▇▇▃▂ |
| DailyRate | 0 | 1 | 802.49 | 403.51 | 102 | 465.00 | 802.0 | 1157.00 | 1499 | ▇▇▇▇▇ |
| DistanceFromHome | 0 | 1 | 9.19 | 8.11 | 1 | 2.00 | 7.0 | 14.00 | 29 | ▇▅▂▂▂ |
| Education | 0 | 1 | 2.91 | 1.02 | 1 | 2.00 | 3.0 | 4.00 | 5 | ▂▃▇▆▁ |
| EmployeeCount | 0 | 1 | 1.00 | 0.00 | 1 | 1.00 | 1.0 | 1.00 | 1 | ▁▁▇▁▁ |
| EmployeeNumber | 0 | 1 | 1024.87 | 602.02 | 1 | 491.25 | 1020.5 | 1555.75 | 2068 | ▇▇▇▇▇ |
| EnvironmentSatisfaction | 0 | 1 | 2.72 | 1.09 | 1 | 2.00 | 3.0 | 4.00 | 4 | ▅▅▁▇▇ |
| HourlyRate | 0 | 1 | 65.89 | 20.33 | 30 | 48.00 | 66.0 | 83.75 | 100 | ▇▇▇▇▇ |
| JobInvolvement | 0 | 1 | 2.73 | 0.71 | 1 | 2.00 | 3.0 | 3.00 | 4 | ▁▃▁▇▁ |
| JobLevel | 0 | 1 | 2.06 | 1.11 | 1 | 1.00 | 2.0 | 3.00 | 5 | ▇▇▃▂▁ |
| JobSatisfaction | 0 | 1 | 2.73 | 1.10 | 1 | 2.00 | 3.0 | 4.00 | 4 | ▅▅▁▇▇ |
| MonthlyIncome | 0 | 1 | 6502.93 | 4707.96 | 1009 | 2911.00 | 4919.0 | 8379.00 | 19999 | ▇▅▂▁▂ |
| MonthlyRate | 0 | 1 | 14313.10 | 7117.79 | 2094 | 8047.00 | 14235.5 | 20461.50 | 26999 | ▇▇▇▇▇ |
| NumCompaniesWorked | 0 | 1 | 2.69 | 2.50 | 0 | 1.00 | 2.0 | 4.00 | 9 | ▇▃▂▂▁ |
| PercentSalaryHike | 0 | 1 | 15.21 | 3.66 | 11 | 12.00 | 14.0 | 18.00 | 25 | ▇▅▃▂▁ |
| PerformanceRating | 0 | 1 | 3.15 | 0.36 | 3 | 3.00 | 3.0 | 3.00 | 4 | ▇▁▁▁▂ |
| RelationshipSatisfaction | 0 | 1 | 2.71 | 1.08 | 1 | 2.00 | 3.0 | 4.00 | 4 | ▅▅▁▇▇ |
| StandardHours | 0 | 1 | 80.00 | 0.00 | 80 | 80.00 | 80.0 | 80.00 | 80 | ▁▁▇▁▁ |
| StockOptionLevel | 0 | 1 | 0.79 | 0.85 | 0 | 0.00 | 1.0 | 1.00 | 3 | ▇▇▁▂▁ |
| TotalWorkingYears | 0 | 1 | 11.28 | 7.78 | 0 | 6.00 | 10.0 | 15.00 | 40 | ▇▇▂▁▁ |
| TrainingTimesLastYear | 0 | 1 | 2.80 | 1.29 | 0 | 2.00 | 3.0 | 3.00 | 6 | ▂▇▇▂▃ |
| WorkLifeBalance | 0 | 1 | 2.76 | 0.71 | 1 | 2.00 | 3.0 | 3.00 | 4 | ▁▃▁▇▂ |
| YearsAtCompany | 0 | 1 | 7.01 | 6.13 | 0 | 3.00 | 5.0 | 9.00 | 40 | ▇▂▁▁▁ |
| YearsInCurrentRole | 0 | 1 | 4.23 | 3.62 | 0 | 2.00 | 3.0 | 7.00 | 18 | ▇▃▂▁▁ |
| YearsSinceLastPromotion | 0 | 1 | 2.19 | 3.22 | 0 | 0.00 | 1.0 | 3.00 | 15 | ▇▁▁▁▁ |
| YearsWithCurrManager | 0 | 1 | 4.12 | 3.57 | 0 | 2.00 | 3.0 | 7.00 | 17 | ▇▂▅▁▁ |
Issues with data * Missing values * Factors or numeric values * Education, EnvironmentSatisfaction, JobInvolvement, JobSatisfaction, PerformanceRating, RelationshipSatisfaction, WorkLifeBalance * Zero variance variables * Over18, EmployCount, StandardHours * Character variables: Convert them to numbers in the recipe step * Unbalanced target variable: Attrition * Id variable: EmployeeNumber
factors_vec <- data %>% select(Education, EnvironmentSatisfaction, JobInvolvement, JobSatisfaction, PerformanceRating, RelationshipSatisfaction, WorkLifeBalance, JobLevel, StockOptionLevel) %>% names()
data_clean <- data %>%
# Address factors imported as numeric
mutate(across(all_of(factors_vec), as.factor)) %>%
# Drop zero-variance variables
select(-c(Over18, EmployeeCount, StandardHours)) %>%
# Recode Attrition
mutate(Attrition = if_else(Attrition == "Yes", "Left", Attrition))Explore data
data_clean %>% count(Attrition)## # A tibble: 2 × 2
## Attrition n
## <chr> <int>
## 1 Left 237
## 2 No 1233data_clean %>%
ggplot(aes(Attrition)) +
geom_bar()
Attrition vs monthly income
data_clean %>%
ggplot(aes(Attrition, MonthlyIncome)) +
geom_boxplot()
Correlation Plot
# Step 1: Binarize
data_binarized <- data_clean %>%
select(-EmployeeNumber) %>%
binarize()
# Step 2: Correlation
data_correlation <- data_binarized %>%
correlate(Attrition__Left)
data_correlation## # A tibble: 120 × 3
## feature bin correlation
## <fct> <chr> <dbl>
## 1 Attrition Left 1
## 2 Attrition No -1
## 3 OverTime No -0.246
## 4 OverTime Yes 0.246
## 5 JobLevel 1 0.213
## 6 MonthlyIncome -Inf_2911 0.207
## 7 StockOptionLevel 0 0.195
## 8 YearsAtCompany -Inf_3 0.183
## 9 MaritalStatus Single 0.175
## 10 TotalWorkingYears -Inf_6 0.169
## # ℹ 110 more rows# Step 3: Plot
data_correlation %>%
correlationfunnel::plot_correlation_funnel()## Warning: ggrepel: 72 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps
Model Building
Split Data
set.seed(1234)
# data_clean <- data_clean %>% sample_n(100)
data_split <- initial_split(data_clean, strata = Attrition)
data_train <- training(data_split)
data_test <- testing(data_split)
data_cv <- rsample::vfold_cv(data_train, strata = Attrition)
data_cv## # 10-fold cross-validation using stratification
## # A tibble: 10 × 2
## splits id
## <list> <chr>
## 1 <split [990/111]> Fold01
## 2 <split [990/111]> Fold02
## 3 <split [990/111]> Fold03
## 4 <split [990/111]> Fold04
## 5 <split [991/110]> Fold05
## 6 <split [991/110]> Fold06
## 7 <split [991/110]> Fold07
## 8 <split [992/109]> Fold08
## 9 <split [992/109]> Fold09
## 10 <split [992/109]> Fold10Preprocess Data
library(themis)
xgboost_recipe <- recipes::recipe(Attrition ~ ., data = data_train) %>%
update_role(EmployeeNumber, new_role = "ID") %>%
step_normalize(all_numeric_predictors()) %>%
step_pca(all_numeric_predictors(), threshold = .3) %>%
step_dummy(all_nominal_predictors()) %>%
step_smote(Attrition)
xgboost_recipe %>% prep() %>% juice() %>% glimpse()## Rows: 1,848
## Columns: 52
## $ EmployeeNumber <dbl> 4, 27, 33, 45, 47, 55, 58, 64, 90, 1…
## $ Attrition <fct> Left, Left, Left, Left, Left, Left, …
## $ PC1 <dbl> -2.1435810, -0.9485209, 0.1608399, -…
## $ PC2 <dbl> 1.53351722, 1.05072213, -1.50986094,…
## $ BusinessTravel_Travel_Frequently <dbl> 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, …
## $ BusinessTravel_Travel_Rarely <dbl> 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, …
## $ Department_Research...Development <dbl> 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 0, …
## $ Department_Sales <dbl> 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, …
## $ Education_X2 <dbl> 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, …
## $ Education_X3 <dbl> 0, 0, 0, 1, 0, 1, 1, 0, 1, 0, 1, 1, …
## $ Education_X4 <dbl> 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, …
## $ Education_X5 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ EducationField_Life.Sciences <dbl> 0, 1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, …
## $ EducationField_Marketing <dbl> 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, …
## $ EducationField_Medical <dbl> 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, …
## $ EducationField_Other <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ EducationField_Technical.Degree <dbl> 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, …
## $ EnvironmentSatisfaction_X2 <dbl> 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, …
## $ EnvironmentSatisfaction_X3 <dbl> 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, …
## $ EnvironmentSatisfaction_X4 <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, …
## $ Gender_Male <dbl> 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 0, 1, …
## $ JobInvolvement_X2 <dbl> 1, 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1, …
## $ JobInvolvement_X3 <dbl> 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, …
## $ JobInvolvement_X4 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ JobLevel_X2 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, …
## $ JobLevel_X3 <dbl> 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, …
## $ JobLevel_X4 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ JobLevel_X5 <dbl> 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, …
## $ JobRole_Human.Resources <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, …
## $ JobRole_Laboratory.Technician <dbl> 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, …
## $ JobRole_Manager <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ JobRole_Manufacturing.Director <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ JobRole_Research.Director <dbl> 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, …
## $ JobRole_Research.Scientist <dbl> 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, …
## $ JobRole_Sales.Executive <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, …
## $ JobRole_Sales.Representative <dbl> 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, …
## $ JobSatisfaction_X2 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ JobSatisfaction_X3 <dbl> 1, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 1, …
## $ JobSatisfaction_X4 <dbl> 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, …
## $ MaritalStatus_Married <dbl> 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 0, 0, …
## $ MaritalStatus_Single <dbl> 1, 1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 1, …
## $ OverTime_Yes <dbl> 1, 0, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, …
## $ PerformanceRating_X4 <dbl> 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, …
## $ RelationshipSatisfaction_X2 <dbl> 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, …
## $ RelationshipSatisfaction_X3 <dbl> 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, …
## $ RelationshipSatisfaction_X4 <dbl> 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, …
## $ StockOptionLevel_X1 <dbl> 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, …
## $ StockOptionLevel_X2 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ StockOptionLevel_X3 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ WorkLifeBalance_X2 <dbl> 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, …
## $ WorkLifeBalance_X3 <dbl> 1, 1, 1, 0, 1, 0, 1, 1, 0, 1, 1, 1, …
## $ WorkLifeBalance_X4 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …Specify Model
usemodels::use_xgboost(Attrition ~., data = data_train)## xgboost_recipe <-
## recipe(formula = Attrition ~ ., data = data_train) %>%
## step_zv(all_predictors())
##
## xgboost_spec <-
## boost_tree(trees = tune(), min_n = tune(), tree_depth = tune(), learn_rate = tune(),
## loss_reduction = tune(), sample_size = tune()) %>%
## set_mode("classification") %>%
## set_engine("xgboost")
##
## xgboost_workflow <-
## workflow() %>%
## add_recipe(xgboost_recipe) %>%
## add_model(xgboost_spec)
##
## set.seed(3682)
## xgboost_tune <-
## tune_grid(xgboost_workflow, resamples = stop("add your rsample object"), grid = stop("add number of candidate points"))xgboost_spec <-
boost_tree(trees = tune(), tree_depth = tune()) %>%
set_mode("classification") %>%
set_engine("xgboost")
xgboost_workflow <-
workflow() %>%
add_recipe(xgboost_recipe) %>%
add_model(xgboost_spec) Tune Hyperparameters
doParallel::registerDoParallel()
set.seed(45034)
xgboost_tune <-
tune_grid(xgboost_workflow,
resamples = data_cv,
grid = 5,
control = control_grid(save_pred = TRUE))Model Evaluation
Identify Optimal Values for Hyperparameters
collect_metrics(xgboost_tune)## # A tibble: 15 × 8
## trees tree_depth .metric .estimator mean n std_err .config
## <int> <int> <chr> <chr> <dbl> <int> <dbl> <chr>
## 1 1311 2 accuracy binary 0.857 10 0.00933 Preprocessor1_Mo…
## 2 1311 2 brier_class binary 0.113 10 0.00785 Preprocessor1_Mo…
## 3 1311 2 roc_auc binary 0.826 10 0.0150 Preprocessor1_Mo…
## 4 641 5 accuracy binary 0.868 10 0.0109 Preprocessor1_Mo…
## 5 641 5 brier_class binary 0.107 10 0.00940 Preprocessor1_Mo…
## 6 641 5 roc_auc binary 0.836 10 0.0169 Preprocessor1_Mo…
## 7 805 8 accuracy binary 0.867 10 0.0109 Preprocessor1_Mo…
## 8 805 8 brier_class binary 0.110 10 0.00874 Preprocessor1_Mo…
## 9 805 8 roc_auc binary 0.834 10 0.0117 Preprocessor1_Mo…
## 10 1883 10 accuracy binary 0.866 10 0.00771 Preprocessor1_Mo…
## 11 1883 10 brier_class binary 0.111 10 0.00746 Preprocessor1_Mo…
## 12 1883 10 roc_auc binary 0.828 10 0.0108 Preprocessor1_Mo…
## 13 215 13 accuracy binary 0.865 10 0.00939 Preprocessor1_Mo…
## 14 215 13 brier_class binary 0.111 10 0.00739 Preprocessor1_Mo…
## 15 215 13 roc_auc binary 0.818 10 0.0119 Preprocessor1_Mo…collect_predictions(xgboost_tune) %>%
group_by(id) %>%
roc_curve(Attrition, .pred_Left) %>%
autoplot()
Fit the Model for the Last Time
xgboost_last <- xgboost_workflow %>%
finalize_workflow(select_best(xgboost_tune, metric = "accuracy")) %>%
last_fit(data_split)
collect_metrics(xgboost_last)## # A tibble: 3 × 4
## .metric .estimator .estimate .config
## <chr> <chr> <dbl> <chr>
## 1 accuracy binary 0.832 Preprocessor1_Model1
## 2 roc_auc binary 0.759 Preprocessor1_Model1
## 3 brier_class binary 0.151 Preprocessor1_Model1collect_predictions(xgboost_last) %>%
yardstick::conf_mat(Attrition, .pred_class) %>%
autoplot()
Variable Importance
xgboost_last %>%
workflows::extract_fit_engine() %>%
vip()
Conclusion
My previous model had accuracy of .851 and auc of .774. Feature transformation: Normalized numeric data. My new model has slightly decreased accuracy of .832 and increased auc of .759. Feature transformation: YeoJohnson and feature selection: step_pca - no improvement.