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