https://zhuanlan.zhihu.com/p/30149571
這篇文章是介紹用R做信用（申請）評分卡，包含了常用的數據處理方法，代碼快為如下部分
1. 數據導入
2.數據清洗
3.特征篩選
4.模型訓練
5.效果評估
6.評分卡轉化
Step 1. 數據導入
示例數據選用klaR包中的GermanCredit，數據太干凈了就人為加了少量異常值以便演示數據處理。變量credit_risk代表是否違約 -- ‘good’ 未違約， ‘bad’ 違約。
# 1.數據導入
df <- read.csv("C:/Users/YXS/Desktop/GermanCredit.csv",? stringsAsFactors = F)
# tips: 設置參數strngsAsFactor可防止字符型被自動轉為因子型，方便數據處理
## 若從txt導入? read.table()
## 若從數據庫直接讀取? library(RJDBC)； dbConnect()
Step 2. 數據探查與清洗
# 2.0 數據粗探
head(df)? # 查看前5行
str(df)? # 查看各變量類型
summary(df)? # 查看各變量的基礎統計信息
# 變量重賦值? -- credit_risk取值為字符型，出于習慣將它轉化為y標簽值0,1
df$credit_risk <- ifelse(df$credit_risk == 'bad', 1, 0) # credit_risk是否違約
# 2.1檢查缺失值
na_num <- apply(df, 2, function(x) sum(is.na(x)))? # 檢查每列的缺失情況
sort(na_num, decreasing = T) / nrow(df)? # 缺失百分比
subset(df, is.na(job))? # 發現job變量有缺失，具體看下存在缺失的觀測值
# 也可以加載sqldf以sql的方式做數據處理與探查工作，減少學習成本
# library(sqldf); sqldf('select * from df where job is null ')
# 常用的缺失值可視化拓展包有VIM，mice
# library(VIM); aggr(df)
# library(mice) ;? md.pattern(df)
# 2.2 缺失值處理
## 缺失值賦眾數? ? -- 將job有缺失的值附眾值
df[is.na(df$job), 'job'] <- names(table(df$job)[which.max(table(df$job))])
sum(is.na(df$job))
## 其它常用缺失值處理方法：
## 缺失值賦均值
#df[which(is.na(df$age), 'age')] <- mean(df$age, na.rm=T)? # na.rm
## 缺失值賦特定值
# for(i in 1:ncol(df)){
#? if(is.character(df[,i])){
#? ? df[is.na(df[ ,i]), i] <- "missing"
#? }
#? if(is.numeric(df[,i])){
#? ? df[is.na(df[ ,i]), i] <- -9999
#? }
# }
## 缺失值插補法
# library(DMwR)
# DMwR::knnImputation(data, k = 10, scale = T, meth = "weighAvg",? distData = NULL)
# library(mice)
# mice(data, m=5)
# 2.3 查看特征取值個數
val_num <- data.frame()? # 建立空矩陣用于存儲后續數據
for (i in 1:ncol(df)){
t1 <- length(unique(df[,i]))? # dplyr::n_distinct()
t2 <- names(df)[i]
val_num <- rbind(data.frame(variable = t2, num = t1, type = mode(df[,i]),
stringsAsFactors = F), val_num)
}
rm(i,t1,t2); gc()? # garbage collection
## tips：在數據量大的情況下循環非常占資源，R中的循環基本都能用apply做向量化運算。為便于理解本文均采用for循環寫法。
# apply(df, 2, function(x) length(unique(x))) 可取代上面的for循環
# 2.3.1 轉換數據類型? -- 發現某些離散型變量的數據類型為數值型，將這些轉為字符型處理
convert_cols <- val_num[which(val_num$num < 5),'variable']
df[,convert_cols] <- sapply(df[,convert_cols], as.character)
str(df[, val_num[val_num$num < 5, 'variable']])
# 2.4 查看數據分布
# 2.4.1 連續型變量查看各變量分位數
num_distribution <- c(); temp_name <- c()
for(i in names(df)){
if(is.numeric(df[,i])){
temp <- quantile(df[,i], probs=c(0,0.10,0.25,0.50,0.75,0.90,0.95,0.98,0.99,1), na.rm = T, names = T)
temp_name <- c(temp_name, i)
num_distribution <- rbind(num_distribution, temp)
}
}
row.names(num_distribution) <- temp_name
num_distribution <- as.data.frame(num_distribution)
num_distribution$variable <- temp_name
rm(i, temp, temp_name)
# 2.4.2 離散型變量查看各取值占比
char_distribution <- data.frame(stringsAsFactors = F)
for(i in names(df)){
if(!is.numeric(df[, i])){
temp <- data.frame(Variable = i, table(df[, i]), stringsAsFactors = F)
char_distribution <- rbind(char_distribution, temp)
}
}
char_distribution$Per <- char_distribution$Freq / nrow(df)
rm(i,temp)
# 異常值刪除 -- 在變量分布中發現age最小值為0為異常值，這邊做刪除處理
age_0 <- subset(df, age==0); age_0
df <- df[- which(df$age==0), ]
rm(age_0)
# 2.4.3 查看自變量與應變量聯合分布
xy_distribution <- data.frame()
for(i in names(df)){
if(!is.numeric(df[, i])){
temp <- data.frame(variable = i, table(df[, i], df$credit_risk), stringsAsFactors = F)
xy_distribution <- rbind(xy_distribution, temp)
}
}
xy_distribution <- transform(xy_distribution, Percent= xy_distribution$Freq / ifelse(xy_distribution$Var2 == 0, 699, 298))
rm(i,temp)
Step 3. 變量離散化（分箱）
主要用smbinning包的smbinnig進行分箱
library(smbinning)
# 3.1 字符轉因子型 -- smbinning包要求離散型變量的數據類型為字符型
for ( i in names(df)){
if(i != 'credit_risk' & is.character(df[,i])) {
df[, i] <- as.factor(df[, i])}
}
str(df)
# 3.2 分箱
data_bak <- df
df$credit_risk <- as.numeric(df$credit_risk)? # 要求y值為數值型
bin_iv <- data.frame(); bin_var <- c()
var_name <- names(df)
for(i in var_name) {
if(is.numeric(df[,i]) & i != 'credit_risk'){
bin_tbl <- smbinning(df, y='credit_risk', x= i)? -- 連續變量用smbinning分箱
bin_iv <- rbind(bin_iv, data.frame(bin_tbl$ivtable, variable=i))
new_var <- paste('bin',i, sep='_')
bin_var <- c(bin_var, new_var)
df <- smbinning.gen(df, bin_tbl, new_var)? ? # 生成離散后的數據
}
if(is.factor(df[,i])){
# 離散變量用smbinning.factor，主要是計算woe、iv值
bin_tbl <- smbinning.factor(df, y='credit_risk', x= i)
bin_iv <- rbind(bin_iv, data.frame(bin_tbl$ivtable, variable=i))
new_var <-? paste('bin',i, sep='_')
bin_var <- c(bin_var, new_var)
df <- smbinning.factor.gen(df, bin_tbl, new_var)? # 生成離散后的數據
}
}
rm(i, new_var);
write.csv(bin_iv, file='C:/Users/YXS/Desktop/bin_iv.csv') # 存儲分箱信息
save(df, file='C:/Users/YXS/Desktop/data_after_bin.rdata') # 數據存儲備份
df<- df[, c('credit_risk', bin_var)]
rm(bin_tbl, data_bak, var_name)
Step 4. 特征篩選
# 4.1 通過IV值篩選
library(klaR)
woe_model <- woe(as.factor(df$credit_risk)~., data=df, zeroadj =0.5)? # 計算各段woe值
iv_table <- sort(woe_model$IV, decreasing = T) # woe_model$IV返回IV值，獎序
iv_var <- names(iv_table[iv_table > 0.02])? # 選取iv > 0.02的變量
woe_model <- woe(as.factor(df$credit_risk)~., data = df[, c('credit_risk', iv_var)], zeroadj =0.5, appont =T)
traindata <- predict(woe_model, newdata=df[, c('credit_risk', iv_var)])? # 用woe值代替原來的變量取值
# 4.2 逐步回歸篩選
library(leaps)
regfit <- regsubsets(credit_risk~., data = traindata, method = 'back', nvmax = 10) #向后逐步回歸
reg_summary <- summary(regfit)
plot(reg_summary$bic)? # 9個變量后bic就基本不下降了，選最好的9個變量入模
reg_summary
# 篩選入模變量
feature_in <- c('bin_status', 'bin_credit_history', 'bin_duration'
,'bin_savings','bin_purpose','bin_personal_status_sex',
'bin_other_debtors', 'bin_installment_rate')
feature_in <- paste('woe', feature_in, sep='.')
Step 5. Logistic 模型訓練
# 5. 邏輯回歸訓練
glmodel <- glm(credit_risk~., traindata[,c('credit_risk', feature_in)], family = binomial)
summary(glmodel)
# 5.1 相關性檢驗
corelation <- cor(traindata[,feature_in])
library(lattice)
levelplot(corelation)
rm(corelation)
# 5.2 VIF 共線性檢驗
library(car)
vif(glmodel, digits =3 )
Step 6. 模型評估
# 6.3 模型評估
# ROC/AUC
pred <- predict(glmodel, newdata = traindata,type = "response")
library(ROCR)
t <- prediction(pred, traindata[, 'credit_risk'])
t_roc <- performance(t, 'tpr', 'fpr')
plot(t_roc)
t_auc <- performance(t, 'auc')
t_auc@y.values
title(main = 'ROC Curve')
# KS 值
ks <- max(attr(t_roc, "y.values")[[1]] - (attr(t_roc, "x.values")[[1]])); print(ks)
Step 7. 制作評分卡
# 7.1 計算factor和offset
# 620 = offset + factor * log(15*2)
# 600 = offset + factor * log(15) # 按好壞比15為600分, 翻一番加20
factor <- 20/log(2)? # 比例因子
offset <- 600-factor*log(15)? # 偏移量
# 7.2提取所需 woe、邏輯回歸系數、截距項、特征個數
glm_coef <- data.frame(coef(glmodel))
NamesWoE <- row.names(glm_coef)[-1] <- gsub('woe.', replacement = '', row.names(glm_coef)[-1])
a = glm_coef[1,1]? # 截距
Beta <- glm_coef$coef.glmodel.[-1]? ? # 系數
names(Beta) <- row.names(glm_coef)[-1]; Beta # 系數名
glm_coef$Variables? <-? row.names(glm_coef)
feature_num <- nrow(glm_coef) - 1 # 特征數目
Score_card <- data.frame()
# Score_card? <-? data.frame(WoE = c(NA),? Score = c(NA),? Variable = c(NA),? Beta = c(1), Band = c(NA))
# Score_card <- na.omit(Score_card) # delte na cases
# 7.3 計算最終評分
for (i in NamesWoE) # 循環變量，計算每個變量取值下的分數
{
WoEEE <- data.frame(woe_model$woe[i])
# 評分公式
Score <- data.frame(-(Beta[i]*WoEEE + a/(feature_num)) * factor + offset/(feature_num))
Temp <- cbind(WoEEE,? Score)
Temp$Variable <- i
Temp$Beta <- Beta[i]
Temp$Value <- row.names(Temp)
names(Temp)[1] <- "WoE"
names(Temp)[2] <- "Score"
Score_card <- rbind(Temp,? Score_card)
}
rm(i,WoEEE, NamesWoE, feature_num, glm_coef, Temp, Score)
write.table(Score_card, file='C:/Users/YXS/Desktop/Scorecard.csv', sep? =? ",? ", col.names? =? NA)
數據源與整體code見iking8023/Score-Card
