お題

あなたは銀行のデジタル部門のデータサイエンティストです。次回のキャンペーンに向けてデータ分析を行う必要があります。あなたがお願いされている仕事は以下の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関数