1
Help us understand the problem. What are the problem?

More than 3 years have passed since last update.

posted at

updated at

ロジスティック回帰 で 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関数
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Sign upLogin
1
Help us understand the problem. What are the problem?