Warning: package 'tidymodels' was built under R version 4.3.3
Warning: package 'dials' was built under R version 4.3.3
Warning: package 'ggplot2' was built under R version 4.3.3
Warning: package 'infer' was built under R version 4.3.3
Warning: package 'modeldata' was built under R version 4.3.3
Warning: package 'parsnip' was built under R version 4.3.3
Warning: package 'recipes' was built under R version 4.3.3
Warning: package 'rsample' was built under R version 4.3.3
Warning: package 'tune' was built under R version 4.3.3
Warning: package 'workflows' was built under R version 4.3.3
Warning: package 'workflowsets' was built under R version 4.3.3
Warning: package 'yardstick' was built under R version 4.3.3
library (modeldata)library (themis)
Warning: package 'themis' was built under R version 4.3.3
The attrition Dataset
These data are from the IBM Watson Analytics Lab . It is a fictional data set created by IBM data scientists. There are 1470 rows
<- tibble (attrition)<- janitor:: clean_names (attrition)str (attrition)
tibble [1,470 × 31] (S3: tbl_df/tbl/data.frame)
$ age : int [1:1470] 41 49 37 33 27 32 59 30 38 36 ...
$ attrition : Factor w/ 2 levels "No","Yes": 2 1 2 1 1 1 1 1 1 1 ...
$ business_travel : Factor w/ 3 levels "Non-Travel","Travel_Frequently",..: 3 2 3 2 3 2 3 3 2 3 ...
$ daily_rate : int [1:1470] 1102 279 1373 1392 591 1005 1324 1358 216 1299 ...
$ department : Factor w/ 3 levels "Human_Resources",..: 3 2 2 2 2 2 2 2 2 2 ...
$ distance_from_home : int [1:1470] 1 8 2 3 2 2 3 24 23 27 ...
$ education : Ord.factor w/ 5 levels "Below_College"<..: 2 1 2 4 1 2 3 1 3 3 ...
$ education_field : Factor w/ 6 levels "Human_Resources",..: 2 2 5 2 4 2 4 2 2 4 ...
$ environment_satisfaction : Ord.factor w/ 4 levels "Low"<"Medium"<..: 2 3 4 4 1 4 3 4 4 3 ...
$ gender : Factor w/ 2 levels "Female","Male": 1 2 2 1 2 2 1 2 2 2 ...
$ hourly_rate : int [1:1470] 94 61 92 56 40 79 81 67 44 94 ...
$ job_involvement : Ord.factor w/ 4 levels "Low"<"Medium"<..: 3 2 2 3 3 3 4 3 2 3 ...
$ job_level : int [1:1470] 2 2 1 1 1 1 1 1 3 2 ...
$ job_role : Factor w/ 9 levels "Healthcare_Representative",..: 8 7 3 7 3 3 3 3 5 1 ...
$ job_satisfaction : Ord.factor w/ 4 levels "Low"<"Medium"<..: 4 2 3 3 2 4 1 3 3 3 ...
$ marital_status : Factor w/ 3 levels "Divorced","Married",..: 3 2 3 2 2 3 2 1 3 2 ...
$ monthly_income : int [1:1470] 5993 5130 2090 2909 3468 3068 2670 2693 9526 5237 ...
$ monthly_rate : int [1:1470] 19479 24907 2396 23159 16632 11864 9964 13335 8787 16577 ...
$ num_companies_worked : int [1:1470] 8 1 6 1 9 0 4 1 0 6 ...
$ over_time : Factor w/ 2 levels "No","Yes": 2 1 2 2 1 1 2 1 1 1 ...
$ percent_salary_hike : int [1:1470] 11 23 15 11 12 13 20 22 21 13 ...
$ performance_rating : Ord.factor w/ 4 levels "Low"<"Good"<"Excellent"<..: 3 4 3 3 3 3 4 4 4 3 ...
$ relationship_satisfaction : Ord.factor w/ 4 levels "Low"<"Medium"<..: 1 4 2 3 4 3 1 2 2 2 ...
$ stock_option_level : int [1:1470] 0 1 0 0 1 0 3 1 0 2 ...
$ total_working_years : int [1:1470] 8 10 7 8 6 8 12 1 10 17 ...
$ training_times_last_year : int [1:1470] 0 3 3 3 3 2 3 2 2 3 ...
$ work_life_balance : Ord.factor w/ 4 levels "Bad"<"Good"<"Better"<..: 1 3 3 3 3 2 2 3 3 2 ...
$ years_at_company : int [1:1470] 6 10 0 8 2 7 1 1 9 7 ...
$ years_in_current_role : int [1:1470] 4 7 0 7 2 7 0 0 7 7 ...
$ years_since_last_promotion: int [1:1470] 0 1 0 3 2 3 0 0 1 7 ...
$ years_with_curr_manager : int [1:1470] 5 7 0 0 2 6 0 0 8 7 ...
Our job will be predicting the binary attrition target variable. As the positive case corresponds with the Yes level, we must modify the target variable so that it is the first level.
<- attrition |> mutate (attrition = factor (attrition, levels = c ("Yes" , "No" )))
Examining the target variable, we observe it is unbalanced (there are more negative than positive cases).
ggplot (attrition, aes (attrition)) + geom_bar () + theme_minimal ()
Predicting Personnel Attrition
Let’s define a predicting workflow for the attrition dataset, completing the steps described in this section.
Train and Test Split
Performing an adequate train and test split, keeping 20% of the dataset in the train set.
set.seed (123123 )<- initial_split (attrition, prop = 0.8 , strata = attrition)<- training (attrition_split)<- testing (attrition_split)
Data Preprocessing
Preparing an adequate preprocessing of the dataset in a recipe. Here are some hints to do the job:
Transform factors into numeric variables. Take into account that there are ordered and unordered factors.
Remove variables with low variance.
Remove variables highly correlated with other features.
Also considering oversampling or undersampling to account for class imbalance.
<- recipe (attrition ~ ., data = at_train) %>% step_dummy (all_nominal_predictors ()) %>% step_zv (all_predictors ()) %>% step_corr (all_numeric_predictors ()) %>% step_smote (attrition) #to consider oversampling
── Recipe ──────────────────────────────────────────────────────────────────────
Number of variables by role
• Dummy variables from: all_nominal_predictors()
• Zero variance filter on: all_predictors()
• Correlation filter on: all_numeric_predictors()
• SMOTE based on: attrition
We can see the preprocessed dataset doing:
%>% prep () %>% bake (new_data = NULL )
# A tibble: 1,972 × 56
age daily_rate distance_from_home hourly_rate monthly_income monthly_rate
<dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 49 279 8 61 5130 24907
2 33 1392 3 56 2909 23159
3 27 591 2 40 3468 16632
4 32 1005 2 79 3068 11864
5 59 1324 3 81 2670 9964
6 30 1358 24 67 2693 13335
7 38 216 23 44 9526 8787
8 36 1299 27 94 5237 16577
9 35 809 16 84 2426 16479
10 29 153 15 49 4193 12682
# ℹ 1,962 more rows
# ℹ 50 more variables: num_companies_worked <dbl>, percent_salary_hike <dbl>,
# stock_option_level <dbl>, total_working_years <dbl>,
# training_times_last_year <dbl>, years_at_company <dbl>,
# years_in_current_role <dbl>, years_since_last_promotion <dbl>,
# years_with_curr_manager <dbl>, business_travel_Travel_Frequently <dbl>,
# business_travel_Travel_Rarely <dbl>, department_Sales <dbl>, …
Models
Choosing two models that can be adequate for this dataset, and define workflows to integrate them with the recipe or recipes.
# Logistic Regression Model <- logistic_reg () %>% set_engine ("glm" )<- workflow () %>% add_model (logistic_model) %>% add_recipe (at_rec)# Random Forest Model <- rand_forest (trees = 50 ) %>% set_engine ("ranger" ) %>% set_mode ("classification" )<- workflow () %>% add_model (forest_model) %>% add_recipe (at_rec)
Cross Validation
Defining a cross validation scheme with five folds, and evaluate each of the models with the following metrics:
Accuracy.
Sensitivity.
Specificity.
set.seed (123123 )<- vfold_cv (at_train, v = 5 , strata = attrition)
<- metric_set (accuracy, sens, spec)
<- fit_resamples (resamples = attrition_folds,metrics = metrics<- fit_resamples (resamples = attrition_folds,metrics = metrics
Warning: package 'ranger' was built under R version 4.3.3
%>% collect_metrics ()
# A tibble: 3 × 6
.metric .estimator mean n std_err .config
<chr> <chr> <dbl> <int> <dbl> <chr>
1 accuracy binary 0.794 5 0.0181 Preprocessor1_Model1
2 sens binary 0.740 5 0.0244 Preprocessor1_Model1
3 spec binary 0.804 5 0.0195 Preprocessor1_Model1
%>% collect_metrics ()
# A tibble: 3 × 6
.metric .estimator mean n std_err .config
<chr> <chr> <dbl> <int> <dbl> <chr>
1 accuracy binary 0.858 5 0.00405 Preprocessor1_Model1
2 sens binary 0.212 5 0.0220 Preprocessor1_Model1
3 spec binary 0.982 5 0.00413 Preprocessor1_Model1
Assessing Best Model
Selecting the best model from the ones tested, train it with the whole train set and obtain the prediction metrics with the test set.
-> We have an imbalanced dataset, with more negative than positive cases. When comparing the two models, the random forest model has better accuracy and specificity, making it highly effective at identifying negative cases. However, the logistic regression model (model 1) has significantly better sensitivity, which is crucial for identifying positive cases. Therefore, I chose the logistic regression model to better address the class imbalance and improve the detection of positive cases.
<- logistic_workflow %>% fit (at_train)<- best_model %>% predict (at_test) %>% bind_cols (at_test) %>% conf_mat (truth= attrition, estimate = .pred_class)<- metric_set (sens, yardstick:: spec, accuracy)%>% predict (at_test) %>% bind_cols (at_test) %>% metrics (truth = attrition, estimate = .pred_class)
# A tibble: 3 × 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 sens binary 0.688
2 spec binary 0.806
3 accuracy binary 0.786
%>% predict (at_test, type = "prob" )
# A tibble: 295 × 2
.pred_Yes .pred_No
<dbl> <dbl>
1 0.0107 0.989
2 0.412 0.588
3 0.315 0.685
4 0.00725 0.993
5 0.232 0.768
6 0.802 0.198
7 0.107 0.893
8 0.541 0.459
9 0.0122 0.988
10 0.464 0.536
# ℹ 285 more rows
