ロジスティック回帰 で Bank Marketing Data Set を分析してみた 

# お題
#### あなたは銀行のデジタル部門のデータサイエンティストです。次回のキャンペーンに 向けてデータ分析を行う必要があります。あなたがお願いされている仕事は以下の2 つです。
- キャンペーンのROIを最大化するために過去のキャンペーンデータを使ってター ゲットのユーザー像を浮かび上がらせてマーケティングチームへのインプットが 求められています。
- さらに、予測モデルを用いてROIを最大化させるためのアタックリストを出力する アルゴリズムの作成を求められています。なお、キャンペーンを実施するにあた り1人の顧客に架電するコストは500円かかります。一方、1件獲得したときの平 均LTVは一律2000円です。


- https://archive.ics.uci.edu/ml/datasets/bank+marketing
- 利用したデータはこちらのデータ


##### データの読み込み
```
data <- read.csv("bank_marketing_train.csv")
head(data)
summary(data)

# 属性を調べる関数
dim(data)
```
##### yの数を確認
```
table(data$y)

   no   yes 
34321  2747 
```

##### テストデータとトレインデータに分ける
```
set.seed(123)
train_idx <- sample(c(1:dim(data)[1]), size = dim(data)[1]*0.7)
train <- data[train_idx,]
test  <- data[-train_idx,]
```

##### trainデータを使って、モデルを作る
- 線形回帰よりロジスティック回帰の方が良さそう。
- 全部入りで特徴量の良し悪しを確認する

```
model1 <- glm(y ~
                age
              + job  
              + marital  
              + education  
              + default
              + housing
              + loan
              + contact
              + month
              + day_of_week
              + duration
              + campaign
              + pdays
              + previous
              + poutcome
              + emp.var.rate
              + cons.price.idx
              + cons.conf.idx
              + euribor3m
              + nr.employed
              , data = train, family = 'binomial')
summary(model1)
```

- summaryの結果

```
Coefficients: (2 not defined because of singularities)
                               Estimate Std. Error z value Pr(>|z|)    
(Intercept)                   8.493e+03  5.942e+03   1.429 0.152913    
age                          -1.498e-03  3.819e-03  -0.392 0.694802    
jobblue-collar               -9.256e-02  1.136e-01  -0.815 0.415300    
jobentrepreneur               1.082e-01  1.660e-01   0.652 0.514642    
jobhousemaid                  6.973e-03  2.372e-01   0.029 0.976547    
jobmanagement                 3.369e-02  1.258e-01   0.268 0.788767    
jobretired                    5.291e-01  1.809e-01   2.924 0.003451 ** 
jobself-employed             -8.806e-02  1.670e-01  -0.527 0.597999    
jobservices                  -6.356e-02  1.217e-01  -0.522 0.601447    
jobstudent                    4.707e-01  1.920e-01   2.452 0.014210 *  
jobtechnician                -7.637e-02  1.055e-01  -0.724 0.469339    
jobunemployed                 3.938e-01  1.995e-01   1.974 0.048336 *  
jobunknown                    4.588e-01  3.780e-01   1.214 0.224764    
maritalmarried               -2.482e-02  1.019e-01  -0.244 0.807610    
maritalsingle                 1.252e-01  1.138e-01   1.100 0.271381    
maritalunknown                3.310e-01  5.680e-01   0.583 0.560071    
educationbasic.6y             1.168e-01  1.729e-01   0.675 0.499502    
educationbasic.9y             1.418e-01  1.378e-01   1.029 0.303552    
educationhigh.school          1.893e-01  1.415e-01   1.337 0.181093    
educationilliterate           1.736e+00  1.047e+00   1.659 0.097127 .  
educationprofessional.course  2.880e-01  1.574e-01   1.829 0.067334 .  
educationuniversity.degree    4.029e-01  1.431e-01   2.816 0.004862 ** 
educationunknown              2.209e-01  1.965e-01   1.124 0.260906    
defaultunknown               -3.107e-01  8.896e-02  -3.492 0.000479 ***
defaultyes                   -9.989e+00  5.095e+02  -0.020 0.984359    
housingunknown               -6.209e-02  2.095e-01  -0.296 0.766916    
housingyes                   -3.820e-02  6.118e-02  -0.624 0.532385    
loanunknown                          NA         NA      NA       NA    
loanyes                       6.279e-02  8.342e-02   0.753 0.451584    
contacttelephone             -2.377e-01  1.389e-01  -1.711 0.087046 .  
monthaug                     -7.615e+01  5.328e+01  -1.429 0.152941    
monthdec                     -9.216e+01  3.354e+02  -0.275 0.783488    
monthjul                     -2.899e+01  2.034e+01  -1.425 0.154165    
monthjun                      2.002e+01  1.389e+01   1.441 0.149603    
monthmar                     -1.739e+01  1.354e+01  -1.285 0.198948    
monthmay                     -1.773e+01  1.182e+01  -1.500 0.133585    
monthnov                     -4.832e+01  3.306e+01  -1.461 0.143920    
monthoct                      8.489e+00  3.481e+00   2.439 0.014729 *  
day_of_weekmon               -3.125e-02  9.704e-02  -0.322 0.747397    
day_of_weekthu                8.179e-02  9.446e-02   0.866 0.386547    
day_of_weektue               -1.109e-01  1.011e-01  -1.097 0.272469    
day_of_weekwed                1.427e-01  9.681e-02   1.474 0.140445    
duration                      5.005e-03  9.986e-05  50.117  < 2e-16 ***
campaign                     -4.023e-02  1.540e-02  -2.613 0.008973 ** 
pdays                        -4.140e-04  1.254e-03  -0.330 0.741247    
previous                      1.075e-01  3.015e-01   0.357 0.721388    
poutcomenonexistent           6.999e-01  3.388e-01   2.066 0.038825 *  
poutcomesuccess               1.631e+00  1.249e+00   1.305 0.191839    
emp.var.rate                  3.006e+01  2.156e+01   1.394 0.163181    
cons.price.idx               -9.038e+01  6.321e+01  -1.430 0.152737    
cons.conf.idx                 6.777e-01  4.520e-01   1.499 0.133782    
euribor3m                     1.186e+00  8.125e-01   1.459 0.144501    
nr.employed                          NA         NA      NA       NA    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 13484.5  on 25946  degrees of freedom
Residual deviance:  8293.3  on 25896  degrees of freedom
AIC: 8395.3

Number of Fisher Scoring iterations: 13
```
```
vif(model1)
```

#### 結果に効きそうなカテゴリの特徴量でyesとの相関を確認する
##### jobで相関を確認
```
y_job <- table(train$y, train$job) 
print(y_job)
round(prop.table(y_job,2),digit=2)
```

##### educationで相関を確認
```
y_education <- table(train$y, train$education) 
print(y_education)
round(prop.table(y_education,2),digit=2)
```
##### defaultで相関を確認
```
y_default <- table(train$y, train$default) 
print(y_default)
round(prop.table(y_default,2),digit=2)
```
##### contactで相関を確認
```
y_contact <- table(train$y, train$contact) 
print(y_contact)
round(prop.table(y_contact,2),digit=2)

cellular

```
##### monthで相関を確認
```
y_month <- table(train$y, train$month) 
print(y_month)
round(prop.table(y_month,2),digit=2)

oct
```

##### poutcomeで相関を確認
```
y_poutcome <- table(train$y, train$poutcome) 
print(y_poutcome)
round(prop.table(y_poutcome,2),digit=2)

success

```

## 新変数を作成する
#### 無職の人
```
train$no_job <- 0
train$no_job[which(train$job == 'student' | train$job == 'retired')] = 1
```

#### education illiterate
```
train$educationilliterate  <- 0
train$educationilliterate [which(train$education  == 'illiterate')] = 1
```

#### default no
```
train$defaultno  <- 0
train$defaultno [which(train$default  == 'no')] = 1
```

#### contact cellular
```
train$contactcellular  <- 0
train$contactcellular [which(train$contact  == 'cellular')] = 1
```

#### month oct
```
train$monthoct  <- 0
train$monthoct [which(train$month  == 'oct')] = 1
```

#### poutcome 以前のマーケティングキャンペーンの結果
```
train$poutcomesuccess  <- 0
train$poutcomesuccess [which(train$poutcome  == 'success')] = 1
```

# 必要な特徴量だけを利用してモデルを作成する
```
model2 <- glm(y ~ 
                no_job
              + educationilliterate
              + defaultno
              + contactcellular
              + monthoct
              + poutcomesuccess
              + campaign
              , data = train, family = 'binomial')

summary(model2)
vif(model2)
```

# テストデータに対して予測（確率値を出す）
### テストデータ用のダミー変数も作成する
#### 無職の人
```
test$no_job <- 0
test$no_job[which(test$job == 'student' | test$job == 'retired')] = 1
```

#### education illiterate
```
test$educationilliterate  <- 0
test$educationilliterate [which(test$education  == 'illiterate')] = 1
```

#### default no
```
test$defaultno  <- 0
test$defaultno [which(test$default  == 'no')] = 1
```

#### contact cellular
```
test$contactcellular  <- 0
test$contactcellular [which(test$contact  == 'cellular')] = 1
```

#### month oct
```
test$monthoct  <- 0
test$monthoct [which(test$month  == 'oct')] = 1
```

#### poutcome 以前のマーケティングキャンペーンの結果
```
test$poutcomesuccess  <- 0
test$poutcomesuccess [which(test$poutcome  == 'success')] = 1
```

### テストデータを使って確認する
```
ypred <- predict(model2, newdata = test, type = 'response')
hist(ypred)
mean_value<- mean(ypred)
```

### 確率値をフラグにする
```
y_flg <- ifelse(ypred > mean_value, 1, 0)
```

### 混同行列
```
conf_mat <- table(y_flg, test$y)
conf_mat
```

### 電話かける人
```
tel_count <- conf_mat[2] + conf_mat[4]
```
### 成約した人
```
subcribed <- conf_mat[2]
```
### ROI
```
roi <- (subcribed * 2000) - (tel_count * 500)
roi
```


# 使わなかったダミー変数
#### day_of_weektue 

```
train$day_of_weektue <- 0
train$day_of_weektue[which(train$day_of_week == 'tue')] = 1
```
#### pdays 経過日数。
```
train$no_contact <- ifelse(train$pdays == '999' , 1, 0 )
```

##### 宿題事項
- 以下を使ってモデルをブラッシュアップする。
- optimaize 関数
- step関数