Записки репетитора

Эта страница только для чтения. Вы можете посмотреть её исходный текст, но не можете его изменить. Сообщите администратору, если считаете, что это неправильно.
====== Логистическая регрессия в R на примере данных оттока клиентов из телекоммуникационной компании ======

===== Постановка задачи =====

При решении задач бинарной классификации (вероятность имеет два значения 0 или 1) зачастую используют логистическую регрессию. Из определения — логистическая регрессия — это статистическая модель, которая применяется для предсказания вероятности возникновения некоторого события по значениям множества признаков.

$$
P(y)=\frac{1}{1+e^{-F(y)}}
$$

где $𝐹(y)$ — некоторая (в общем случая не линейная) функция от исследуемых переменных $y_𝑖$ вида: $𝐹(y)=𝐵_0+𝐵_1⋅y_1+⋯+𝐵_𝑛⋅y_𝑛$.

Значение 𝑃(y) — есть вероятность события $(0 \leq 𝑃(y) \leq 0)$, тогда $𝐹(y)$ — некоторая функция, принимающая значения от $-\infty$ до $+\infty$.

{{posts:logistic-fig1.png| Логистическая функция}}

Как видно из графика, для большинства значений аргумента 𝑦 вероятность события $𝐹(y)$ может принимать одно из двух значений 0 или 1, однако вблизи точки x=0 значение 𝐹 испытывает скачок. Здесь чтобы разделить исходы на 0 и 1 мы должны ввести точку отсечки — значение вероятности события $𝐹(y)$ выше которой трактуются как 1, а ниже — как 0. По умолчанию, это значение равно 0.5. Тем не менее, в каждом конкретном случае мы модем изменять её для обеспечения лучших результатов в классификации. Например, если нас интересует только один из возможных исходов.

===== Описательный анализ =====

Ниже по ссылке лежат исходные {{posts:data.zip|данные}} для анализа. Их необходимо скачать и распаковать файл в директорию с проектом.

<Code:R linenums:1>
# нам понядобятся следующие пакеты
library(tidyverse)
library(knitr)
library(ROCR)
library(caret)

# обратите внимание на то, как мы читаем данные:
# указываем, чтобы первая строка в файле трактовалась как строка заголовка
# также говорим чтобы при чтении строковые значения воспринимались как категориальные
teleco.raw.data <- read.csv("WA_Fn-UseC_-Telco-Customer-Churn.csv", header = TRUE, stringsAsFactors = TRUE)
</Code>


^customerID	^gender	^SeniorCitizen	^Partner	^Dependents	^tenure	^PhoneService	^MultipleLines	^InternetService	^OnlineSecurity	^OnlineBackup	^DeviceProtection	^TechSupport	^StreamingTV	^StreamingMovies	^Contract	^PaperlessBilling	^PaymentMethod	^MonthlyCharges	^TotalCharges	^Churn^
|7590-VHVEG	|Female	|0	|Yes	|No	|1	|No	|No phone service	|DSL	|No	|Yes	|No	|No	|No	|No	|Month-to-month	|Yes	|Electronic check	|29.85	|29.85	|No|
|5575-GNVDE	|Male	|0	|No	|No	|34	|Yes	|No	|DSL	|Yes	|No	|Yes	|No	|No	|No	|One year	|No	|Mailed check	|56.95	|1889.50	|No|
|3668-QPYBK	|Male	|0	|No	|No	|2	|Yes	|No	|DSL	|Yes	|Yes	|No	|No	|No	|No	|Month-to-month	|Yes	|Mailed check	|53.85	|108.15	|Yes|
|7795-CFOCW	|Male	|0	|No	|No	|45	|No	|No phone service	|DSL	|Yes	|No	|Yes	|Yes	|No	|No	|One year	|No	|Bank transfer (automatic)	|42.30	|1840.75	|No|
|9237-HQITU	|Female	|0	|No	|No	|2	|Yes	|No	|Fiber optic	|No	|No	|No	|No	|No	|No	|Month-to-month	|Yes	|Electronic check	|70.70	|151.65	|Yes|

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

<Code:R linenums:1>
str(teleco.raw.data)
 
## 'data.frame':    7043 obs. of  21 variables:
##  $ customerID      : Factor w/ 7043 levels "0002-ORFBO","0003-MKNFE",..: 5376 3963 2565 5536 6512 6552 1003 4771 5605 4535 ...
##  $ gender          : Factor w/ 2 levels "Female","Male": 1 2 2 2 1 1 2 1 1 2 ...
##  $ SeniorCitizen   : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Partner         : Factor w/ 2 levels "No","Yes": 2 1 1 1 1 1 1 1 2 1 ...
##  $ Dependents      : Factor w/ 2 levels "No","Yes": 1 1 1 1 1 1 2 1 1 2 ...
##  $ tenure          : int  1 34 2 45 2 8 22 10 28 62 ...
##  $ PhoneService    : Factor w/ 2 levels "No","Yes": 1 2 2 1 2 2 2 1 2 2 ...
##  $ MultipleLines   : Factor w/ 3 levels "No","No phone service",..: 2 1 1 2 1 3 3 2 3 1 ...
##  $ InternetService : Factor w/ 3 levels "DSL","Fiber optic",..: 1 1 1 1 2 2 2 1 2 1 ...
##  $ OnlineSecurity  : Factor w/ 3 levels "No","No internet service",..: 1 3 3 3 1 1 1 3 1 3 ...
##  $ OnlineBackup    : Factor w/ 3 levels "No","No internet service",..: 3 1 3 1 1 1 3 1 1 3 ...
##  $ DeviceProtection: Factor w/ 3 levels "No","No internet service",..: 1 3 1 3 1 3 1 1 3 1 ...
##  $ TechSupport     : Factor w/ 3 levels "No","No internet service",..: 1 1 1 3 1 1 1 1 3 1 ...
##  $ StreamingTV     : Factor w/ 3 levels "No","No internet service",..: 1 1 1 1 1 3 3 1 3 1 ...
##  $ StreamingMovies : Factor w/ 3 levels "No","No internet service",..: 1 1 1 1 1 3 1 1 3 1 ...
##  $ Contract        : Factor w/ 3 levels "Month-to-month",..: 1 2 1 2 1 1 1 1 1 2 ...
##  $ PaperlessBilling: Factor w/ 2 levels "No","Yes": 2 1 2 1 2 2 2 1 2 1 ...
##  $ PaymentMethod   : Factor w/ 4 levels "Bank transfer (automatic)",..: 3 4 4 1 3 3 2 4 3 1 ...
##  $ MonthlyCharges  : num  29.9 57 53.9 42.3 70.7 ...
##  $ TotalCharges    : num  29.9 1889.5 108.2 1840.8 151.7 ...
##  $ Churn           : Factor w/ 2 levels "No","Yes": 1 1 2 1 2 2 1 1 2 1 ...

</Code>

Ага, фактор `SeniorCitizen` помечен как числовой, но очевидно, что он категориальный, заменим его. Также переместим фактор `Churn` на первое место для удобства.

<Code:R linenums:1>
teleco.raw.data$SeniorCitizen=as.factor(teleco.raw.data$SeniorCitizen)
teleco.raw.data %>%
  relocate(Churn) -> prepared.data
</Code>

Теперь посмотрим, в каких столбцах находятся пропущенные данные и сколько их:

<Code:R linenums:1>
sapply(prepared.data,function(x) sum(is.na(x)))
##           Churn           gender    SeniorCitizen          Partner
##               0                0                0                0
##      Dependents           tenure     PhoneService    MultipleLines
##               0                0                0                0
## InternetService   OnlineSecurity     OnlineBackup DeviceProtection
##               0                0                0                0
##     TechSupport      StreamingTV  StreamingMovies         Contract
##               0                0                0                0
##PaperlessBilling    PaymentMethod   MonthlyCharges     TotalCharges
##               0                0                0               11
</Code>

Замечательно, пустые значения есть только в столбце `TotalCharges` и их всего 11. Потому можем просто удалить записи, которые содержат пустые значения.


<Code:R linenums:1>
teleco.raw.data[complete.cases(teleco.raw.data),]->teleco.raw.data
# мы воспользовались функцией complete.cases, котора возвращает 
# логический индекс строк, которые не содержат пустые значения

prepared.data[complete.cases(prepared.data),] ->prepared.data
</Code>

===== Подготовим тренировочную и тестовю выборки из наших данных =====
Соотношение числа элементов тренировочной и тестовой выборки будет 75%:25%.

<Code:R linenums:1 >
#Предварительно закодируем наши факторы как серию столбцов из 0 и 1, так называемое `one_hot` кодирование.
require(mltools)

 
one_hot(as.data.table(prepared.data), dropUnusedLevels=T)->prepared.data

smp_size <- floor(0.75 * nrow(prepared.data))
set.seed(123)
train_ind <- sample(seq_len(nrow(prepared.data)), size = smp_size)
 
train_df <- prepared.data[train_ind, ]
test_df <- prepared.data[-train_ind, ]
</Code>

Теперь у нас есть тренировочный и тестовый наборы, определим модель:


<Code:R linenums:1>
model <- glm(Churn ~.,family=binomial(link='logit'),data=train_df)

# Вариационный анализ покажет нам наиболее важные факторы
anova(model, test="Chisq")->res
res[with(res, order(-Deviance)),]

## 
## Analysis of Deviance Table
## 
## Model: binomial, link: logit
## 
## Response: Churn
## 
## Terms added sequentially (first to last)
## 
## 
##                                           Df Deviance Resid. Df Resid. Dev
## tenure                                     1   637.02      5268     5217.6
## `InternetService_Fiber optic`              1   370.10      5264     4644.5
## MultipleLines_No                           1   143.90      5266     5073.2
## Partner_No                                 1   124.20      5270     5891.6
## SeniorCitizen_0                            1    91.70      5271     6015.8
## `Contract_Month-to-month`                  1    80.86      5257     4479.0
## InternetService_DSL                        1    58.65      5265     5014.6
## Dependents_No                              1    36.94      5269     5854.6
## OnlineSecurity_No                          1    28.75      5263     4615.7
## StreamingTV_No                             1    23.88      5259     4571.4
## TechSupport_No                             1    19.90      5260     4595.3
## TotalCharges                               1    15.58      5250     4415.5
## `Contract_One year`                        1    14.79      5256     4464.2
## PaperlessBilling_No                        1    12.68      5255     4451.5
## StreamingMovies_No                         1    11.60      5258     4559.8
## `PaymentMethod_Electronic check`           1    10.46      5252     4433.3
## `PaymentMethod_Credit card (automatic)`    1     7.06      5253     4443.7
## MonthlyCharges                             1     2.20      5251     4431.1
## `PaymentMethod_Bank transfer (automatic)`  1     0.70      5254     4450.8
## gender_Female                              1     0.57      5272     6107.5
## PhoneService_No                            1     0.47      5267     5217.1
## OnlineBackup_No                            1     0.27      5262     4615.5
## DeviceProtection_No                        1     0.26      5261     4615.2
</Code>

===== Анализ результатов =====

Теперь давайте посмотрим, как наша модель работает на тестовой выборке:

<Code:R linenums:1>
fitted.results <- predict(model,newdata=test_df,type='response')
fitted.results <- ifelse(fitted.results > 0.5,1,0)
misClasificError <- mean(fitted.results != test_df$Churn)
print(paste('Accuracy',1-misClasificError))

## [1] "Accuracy 0.82"
</Code>

Здесь мы получили, что модель дает правильные результаты в 82% случаев, при этом это процент верно предсказанных позитивных исходов (в нашем случае это сигнал, что клиент остался с поставщиком) Sensitivity=TP/(TP+FN)
И его можно оценить из матрицы неточностей (см. ниже)

<Code:R linenums:1>
# матрица неточностей имеет вид
confusionMatrix(data=factor(fitted.results), reference = factor(test_df$Churn))

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction    0    1
##          0 1180  196
##          1  111  271
## 
##                Accuracy : 0.8254
##                  95% CI : (0.8068, 0.8428)
##     No Information Rate : 0.7344
##     P-Value [Acc > NIR] : < 2.2e-16
## 
##                   Kappa : 0.5248
## 
##  Mcnemar's Test P-Value : 1.634e-06
## 
##             Sensitivity : 0.9140
##             Specificity : 0.5803
##          Pos Pred Value : 0.8576
##          Neg Pred Value : 0.7094
##              Prevalence : 0.7344
##          Detection Rate : 0.6712
##    Detection Prevalence : 0.7827
##       Balanced Accuracy : 0.7472
## 
##        'Positive' Class : 0
</Code>

Здесь $Accuracy=\frac{TP+TN}{P+N}$, $Senitivity = \frac{TP}{P}$, $Specificity=\frac{TN}{N}$, $Precisiob=\frac{TP}{TP+FP}$.

В нашем случае Specificity=58% — специфичность - процент верно предсказанных негативных исходов, то есть случаев, когда клиент ушел от поставщика услуг. В то же время Sensitivity=91%, число верно предсказанных положительных исходов, тоесть случаев, когда клиент остался с поставщиком услуг.

Общая точность модели составляет 82%.

Построим теперь график зависимости True negative rate от False negative rate.

{{posts:tnr_performance.png | Производительность модели в зависимости от выбора точки отсечки.}}

Здесь на графике мы видим, что увеличение порога отсечки увеличивает как TPR, так и TNR. Здесь варе баланс. В зависимости от того, предсказание какого исход предпочтительнее, выбирается та или иная точка отсечки.  

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

Инструменты пользователя

Инструменты сайта

Инструменты страницы
