Задача

Решение задачи предсказания ухода сотрудников компании. Цель - выявить, какие факторы влияют на уход сотрудников из компании, а также предложить меры по увеличению лояльности сотрудников.

Анализ

Данные и логика анализа

library(DBI)
library(RMariaDB)
library(dplyr)
library(ggplot2)
library(plotly)
library(DT)
library(tidymodels)
con <- dbConnect(RMariaDB::MariaDB(), 
                 user='studentminor', 
                 password='DataMinorHSE!2020', 
                 dbname='employee', 
                 host='34.88.193.134',
                 port = 3306)
#медианное значение возраста
age = dbGetQuery(con, "SELECT Age FROM profile")
median_age = median(age$Age)

#Подсчет доли сотрудников, покинувших компанию

young = dbGetQuery(con, "SELECT Attrition, count(*) as n FROM portfolio join profile on portfolio.EmployeeNumber = profile.EmployeeNumber where Age<36 group by Attrition")

all = dbGetQuery(con, "SELECT Attrition, count(*) as n FROM portfolio join profile on portfolio.EmployeeNumber = profile.EmployeeNumber where Age>=36 group by Attrition")

y_attr = round(young[2,2]/(young[1,2]+young[2,2]),3)
a_attr = round(all[1,2]/(all[2,2]+all[1,2]),3)

young = young %>% mutate(cat = "y")
all =all %>%  mutate(cat = "a")
ALL = rbind(young,all)
ALL$Attrition=ALL$Attrition %>% as.factor()
ALL$n = as.numeric(ALL$n)
count = ALL %>% group_by(cat) %>% summarize(n = sum(n))

young$n = young$n %>% as.numeric()
all$n = all$n %>% as.numeric()

Выбрана подгруппа молодых сотрудников, возраст которых меньше медианного уровня (36 лет). Сохранение молодых кадров - важная задача для фирмы, ведь они могут принести пользу в долгосрочной перспективе. Молодые сотрудники более мобильны, а следовательно с большей вероятностью могут покинуть компанию. Это подтверждается и данными: доля молодых сотрудников, покинувших компанию - 0.228, а для сотрудников, которым больше 36 лет, эта доля составляет 0.112.

plot_ly(
  labels = c("Всего", "Старше 35 лет", "Молодые", "Остались", "Ушли",
             "Ушли ", "Остались "),
  parents = c("", "Всего", "Всего", "Молодые", "Молодые", "Старше 35 лет", "Старше 35 лет"),
  values = c(sum(ALL$n), count$n, young$n, all$n),
  type = 'sunburst',
  branchvalues = 'total'
) %>% layout(title="Доля покинувших компанию")

Одним из важных факторов лоялности сотрудника видится зарплата.

income = dbGetQuery(con, "SELECT MonthlyIncome, Attrition FROM portfolio join profile on portfolio.EmployeeNumber = profile.EmployeeNumber where Age<36")

ggplot(income)+geom_boxplot(aes(x = as.factor(Attrition),y =MonthlyIncome),fill = "#BC8F8F")+ggtitle("Распределение ежемесячного дохода \nв зависимости от статуса")+ylab("Доход")+ xlab("Статус")+scale_x_discrete(labels = c("Остался", "Ушел"))+theme_bw()

График показывает, что молодые сотрудники, покинувшие компанию, в среднем получали меньше, чем те, кто остался. После анализа моделей можно будет сделать окончательный вывод о важности этой переменной.

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

data = dbGetQuery(con, "SELECT Attrition, Education, MonthlyIncome, EduFieldId, Gender, MaritalStatus, NumCompaniesWorked, TotalWorkingYears, WorkLifeBalance, DistanceFromHome, BusinessTravel, Department, EnvironmentSatisfaction, JobInvolvement, JobRole, JobSatisfaction, OverTime, PercentSalaryHike, PerformanceRating, RelationshipSatisfaction, TrainingTimesLastYear, YearsAtCompany, YearsInCurrentRole, YearsSinceLastPromotion, YearsWithCurrManager FROM portfolio join profile on portfolio.EmployeeNumber = profile.EmployeeNumber where Age<36")

data = data %>% mutate_if(is.character, as.factor)
data$Attrition=data$Attrition %>% as.factor()
#отключаемся от базы
dbDisconnect(con)

Модель

set.seed(101)

split <- initial_split(data)
train <- training(split)
test  <- testing(split)

balance = round(table(train$Attrition)[1]/table(train$Attrition)[2],1)

Выборка несбалансированная - сотрудников, покинувших компанию, в 3.4 раза больше, чем оставшихся.

a = table(train$Attrition) %>% as.data.frame() %>% rename(status = Var1,number = Freq)
a$status = ifelse(a$status=="0","Остался", "Ушел")
knitr::kable(a)
status number
Остался 302
Ушел 90 
train_A1 <- train %>% filter(Attrition == "1")
train_w <- train
for (i in 1:2){
  train_w <- rbind(train_w, train_A1)
}

balance_new=round(table(train_w$Attrition)[1]/table(train_w$Attrition)[2],1)

Чтобы решить эту проблему, будут переопределены веса.Соотношение оставшихся к ушедшим стало 1.1.

  1. Логистическая регрессия:
log.wf = logistic_reg() %>% 
    fit(Attrition~., data = train_w)


#logreg <- logistic_reg()

#log.wf <- workflow() %>%
 #  add_formula(Attrition ~.) %>%
 #  add_model(logreg) %>%
  # fit(train_w)

predtest.logreg  = log.wf %>% 
    predict(test)

log.metrics_test  = predtest.logreg %>% 
    cbind(test) %>% 
    conf_mat(Attrition, .pred_class) %>% summary() %>% filter(.metric == "accuracy"|.metric == "sens"|.metric == "spec") %>% select(-.estimator)

predtrain.logreg  = log.wf %>% 
    predict(train_w)

log.metrics_train  = predtrain.logreg %>% 
    cbind(train_w) %>% 
    conf_mat(Attrition, .pred_class) %>% summary() %>% filter(.metric == "accuracy"|.metric == "sens"|.metric == "spec") %>% select(-.estimator)

log.metrics_train=log.metrics_train %>% rename(train = .estimate)
log.metrics_test=log.metrics_test %>% rename(test =.estimate)
knitr::kable(log.metrics_train %>% inner_join(log.metrics_test))
.metric train test
accuracy 0.8601399 0.8015267
sens 0.8642384 0.8333333
spec 0.8555556 0.6896552

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

  1. Дерево решений
tree <- decision_tree(
  mode = "classification") %>%
  set_engine("rpart")

tree.wf <- workflow() %>%
   add_formula(Attrition ~.) %>%
   add_model(tree) %>%
   fit(train_w)

predtest.tree = tree.wf %>% 
    predict(test)

tree.metrics_test = test %>% 
    cbind(predtest.tree) %>% 
    conf_mat(Attrition, .pred_class)%>% summary() %>% filter(.metric == "accuracy"|.metric == "sens"|.metric == "spec") %>% select(-.estimator)

predtrain.tree = tree.wf %>% 
    predict(train_w)

tree.metrics_train = train_w %>% 
    cbind(predtrain.tree) %>% 
    conf_mat(Attrition, .pred_class)%>% summary() %>% filter(.metric == "accuracy"|.metric == "sens"|.metric == "spec") %>% select(-.estimator)

tree.metrics_test=tree.metrics_test %>% rename(test = .estimate)
tree.metrics_train=tree.metrics_train %>% rename(train=.estimate)
knitr::kable(tree.metrics_test %>% inner_join(tree.metrics_train))
.metric test train
accuracy 0.7328244 0.8531469
sens 0.7549020 0.8211921
spec 0.6551724 0.8888889

Показатели этой модели хуже, чем логистической регресии.

  1. Random forest
rf = rand_forest(mode = "classification", mtry = 7) %>% 
  set_engine('randomForest')

wf_rf = workflow() %>% 
  add_model(rf) %>% 
  add_formula(Attrition~.) %>%
fit(train_w)

predtrain.rf = predict(wf_rf, train_w)
predtest.rf = predict(wf_rf, test)

accuracyTrain.rf =  
  accuracy_vec(train_w$Attrition, predtrain.rf$.pred_class)

accuracyTest.rf =  
  accuracy_vec(test$Attrition, predtest.rf$.pred_class)



accuracy.rf = tree.metrics_test %>% inner_join(tree.metrics_train) %>% filter(.metric=="accuracy") %>% mutate(test = accuracyTest.rf, train =accuracyTrain.rf )

knitr::kable(accuracy.rf)
.metric test train
accuracy 0.8167939 1
  1. Градиентный бустинг
set.seed(101)
xgb = boost_tree(mode = "classification", mtry = 3) %>% 
  set_engine('xgboost')

wf_xgb = workflow() %>% 
  add_model(xgb) %>% 
  add_formula(Attrition~.) %>% 
  fit(train_w)

predtrain.xgb = predict(wf_xgb, train_w) 
predtest.xgb = predict(wf_xgb, test)

accuracyTrain.xgb =  
  accuracy_vec(train_w$Attrition, predtrain.xgb$.pred_class)

accuracyTest.xgb =  
  accuracy_vec(test$Attrition, predtest.xgb$.pred_class)

accuracy_xgb = accuracy.rf %>% mutate(test = accuracyTest.xgb, train =accuracyTrain.xgb)
knitr::kable(accuracy_xgb)
.metric test train
accuracy 0.7862595 0.9597902

Модели 3 и 4 оказались сильно переобучены. Будет использоваться модель логистической регрессии.

Симуляция

library(vip)

vip:::vip.model_fit(log.wf)

Самым важным показателем в модели оказалось наличие переработок.

ggplot(data)+geom_bar(aes(x = as.factor(OverTime), fill = Attrition), position = 'fill') +xlab("Переработки")+ scale_x_discrete(labels = c("Нет", "Есть")) +scale_fill_brewer(labels = c("Остался", "Ушел"), name = "Статус", palette = "Dark2")+theme_bw()

Действительно, доля покинувших компанию среди тех, у кого есть переработки значительно выше (почти 50%), чем среди тех, кто не перерабатывает (около 13%).

Предположим, что компания может реорганизовать рабочий процесс и это позволит снизить число переработок в 3 раза.

test2 = test
set.seed(101)
test2$OverTime[test2$OverTime == "Yes"] = 
  sample(c("Yes", "No"), 
         size = length(test2$OverTime[test2$OverTime == "Yes"]),
         replace = T, prob = c(0.33, 0.67))

predTest_new = predict(log.wf, test2)

ggplot(test) + geom_bar(aes(x = Attrition), alpha = 0.5) +
  geom_bar(data = data.frame(predTest_new), aes(x = .pred_class), alpha = 0.5, fill = "red")+xlab("Статус")+scale_x_discrete(labels = c("Остался", "Ушел"))+ylab(" ")+theme_bw()+scale_fill_discrete("Этап")

После изменения ситуация улучшилась, но не очень сильно. Другим важным фактором является число тренингов. Имеет смысл попробовать провести для каждого сотрудника на 2 тренинга в год больше. Это относительно несложно реализовать. Также можно постарасться повысить мобльность сотрудников внутри компании, воздействуя на показатель YearsInCurrentRole. Это не обязательно должно быть повышение (вертикальная мобильность), это может быть горизонтальная мобильность, в определенной степени смена должностных обязанностей, получение новой роли в процессах компании. Предположим, что удасться уменьшить пребывание сотрудника в одной роли в среднем на полгода.

test2$TrainingTimesLastYear = test2$TrainingTimesLastYear+2
test2$YearsInCurrentRole = test2$YearsInCurrentRole-0.5
predTest_new2 = predict(log.wf, test2)

ggplot(test) + geom_bar(aes(x = Attrition), alpha = 0.5) +
  geom_bar(data = data.frame(predTest_new2), aes(x = .pred_class), alpha = 0.5, fill = "red")+xlab("Статус")+scale_x_discrete(labels = c("Остался", "Ушел"))+ylab(" ")+theme_bw()

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

Общие выводы

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