R语言实现变量分箱及应用

本文是决策树分箱在R语言中的实现，代码如下，其中df是待分箱的数据集，key_var是主键，y_var是y变量，max_depth是决策树的最大深度，p是决策树叶节点最小占比。

cut_bin <- function(df, key_var, y_var, max_depth, p) {
  library(rpart)
  df_bin <- df[, c(key_var, y_var)] 
  Xvar_df<- df[-which(colnames(df) %in% c(key_var, y_var))] 
  lst_bin<- list()
  j<-0
  for (col in colnames(Xvar_df)) {
    if (class(df[, col]) != 'character') {
      fit <- rpart(
        df[, y_var] ~ df[, col],
        data = df,
        method = "anova",
        control = rpart.control(
          xval = 10,
          minbucket = round(p*nrow(df)), 
          maxdepth = max_depth,
          cp = 0.0001 
        )
      )
      splits <- fit$splits[, 'index']
      vec<-NULL
      if (length(splits) == 1) {
        vec[df[, col] < splits[1]] <- 1
        vec[df[, col] >= splits[1]] <- 2
        inter_bin<- rbind(c(1, -1000000000, splits[1]), c(2, splits[1], 1000000000))
      }
      else if (length(splits) > 1) {
        splits <- sort(splits)
        vec[df[, col] < splits[1]] <- 1
        inter_bin<- matrix(c(1, -1000000000, splits[1]), nrow=1)
        rownames(inter_bin)<-1
        for (i in 1:(length(splits) - 1)) {
          vec[df[, col] >= splits[i] & df[, col] < splits[i + 1]] <- i + 1
          inter_bin<- rbind(inter_bin, c(i+1, splits[i], splits[i + 1]))
          rownames(inter_bin)[i+1]<-i+1
        }
        vec[df[, col] >= splits[length(splits)]] <-length(splits) + 1
        inter_bin<- rbind(inter_bin, c(length(splits) + 1, splits[length(splits)], 1000000000))
        rownames(inter_bin)[length(splits)+1]<-length(splits)+1
      }
      else {
        vec <- 1
        inter_bin<- matrix(c(1, -1000000000, 1000000000), nrow=1)
      }
      # data.frame->bin
      df_bin[, col]<-vec
      # Freq&BadRate
      inter_df<-as.data.frame(inter_bin)
      colnames(inter_df)<- c('bin', 'lower', 'upper')
      zz1<-data.frame(prop.table(table(df_bin[, col])))
      zz2<-data.frame(prop.table(table(df_bin[, col],df_bin[, y_var]), 1))
      Freq<-zz1$Freq
      BadRate<-zz2$Freq[zz2$Var2==1]
      inter_df<-cbind(inter_df, Freq, BadRate)
      inter_df$lower<-round(inter_df$lower, 2)
      inter_df$upper<-round(inter_df$upper, 2)
      # bin->list
      lst_temp<- list(inter_df=inter_df)
      lst_bin<-c(lst_bin, lst_temp)
      j<-j+1
      names(lst_bin)[j]<-col
    }
    all<- list(lst_bin=lst_bin, df_bin=df_bin)
  }
  return(all)
}

输出对象存放在列表all中，all中包含2个元素，lst_bin是变量分箱结果的列表，df_bin是分好箱的数据集。下面查看lst_bin中某变量分箱结果和df_bin。

某变量分箱结果

分箱后的数据集df_bin

下面函数将训练样本上分箱方式“套进” 测试样本里。其中df是测试样本数据集， key_var是主键， y_var是y值， lst_bin是训练样本上变量分箱结果的列表。该函数也输出一个列表，含有2个元素，其中lst_bin_test是测试样本上变量分箱结果的列表，df_bin是测试样本分箱结果数据集。

txt_bin<- function(df, key_var, y_var, lst_bin){
  df_bin <- df[, c(key_var, y_var)] 
  var_df<- df[-which(colnames(df) %in% c(key_var, y_var))]
  for (col in names(lst_bin)){
    vec<-NULL
    bin<- lst_bin[[col]]
    for (i in 1:length(bin$bin)){
      vec[df[, col]>=bin$lower[i] & df[, col]<bin$upper[i]]<- bin$bin[i]
    }
    df_bin[, col]<-vec
  }
  
  lst_bin_test<- list()
  j<- 0
  for (col in names(lst_bin)){  
    z1<-data.frame(prop.table(table(df_bin[, col], df_bin[, y_var]), 1))
    z2<-data.frame(prop.table(table(df_bin[, col])))
    z_df<-cbind(bin=z2$Var1, Freq=z2$Freq, BadRate=z1$Freq[z1$Var2==1])
    inter_df<-merge(lst_bin[[col]][,1:3], z_df, by="bin", all=FALSE)
    lst_temp<- list(inter_df=inter_df)
    lst_bin_test<-c(lst_bin_test, lst_temp)
    j<-j+1
    names(lst_bin_test)[j]<-col
  }
  result<- list(lst_bin_test=lst_bin_test, df_bin=df_bin)
  return(result)
}

上面的两个函数实现了变量分箱的自动化，现在想看看训练样本和测试样本里某个变量的趋势是否一致，编写函数plot_train_test_bin来实现该功能。其中TrainVar_bin是训练样本中某变量的分箱结果及风险趋势, TestVar_bin是测试样本中某变量的分箱结果及风险趋势。

plot_train_test_bin<-function(TrainVar_bin, TestVar_bin){
  par(mfrow=c(1,2))
  
  par(mar=c(3.5,3.5,3,3.1))
  bar <- barplot(TrainVar_bin$Freq,ylim=c(0,1.3*max(TrainVar_bin$Freq)),col="gray")
  mtext(TrainVar_bin$bin,side=1,line=0.5,at=bar,col="black")
  mtext("Train bin",side=1,line=1.5,col="black")
  mtext("Freq",side=2,line=2,col="black")
  par(new=T)
  plot(bar,TrainVar_bin$BadRate ,axes=F,ylim=c(0,1.3*max(TrainVar_bin$BadRate)),xlab="",ylab="",type="o")
  axis(4,col="black",col.ticks="black",col.axis="black")
  mtext("BadRate",side=4,line=2,col="black")
  
  par(mar=c(3.5,3.1,3,3.5))
  bar <- barplot(TestVar_bin$Freq,ylim=c(0,1.3*max(TestVar_bin$Freq)),col="gray")
  mtext(TestVar_bin$bin,side=1,line=0.5,at=bar,col="black")
  mtext("Test bin",side=1,line=1.5,col="black")
  mtext("Freq",side=2,line=2,col="black")
  par(new=T)
  plot(bar,TestVar_bin$BadRate ,axes=F,ylim=c(0,1.3*max(TestVar_bin$BadRate)),xlab="",ylab="",type="o")
  axis(4,col="black",col.ticks="black",col.axis="black")
  mtext("BadRate",side=4,line=2,col="black")
}

运行后的结果如下，左侧为该变量在训练样本上的趋势，右侧为测试样本上的趋势，从图中可以看出该变量的趋势在3和4两处发生了波动，具体实践时需要具体分析原因，或者看能否将3、4和5进行合并处理等等。

或者，在对上面这个变量分箱时增加叶子结点最小占比，看看分箱结果如何。从下图可以看出，调整后的变量趋势更加稳定了。

temp_train<-train[, c(key, y, TempVar)]
temp_train_all<-cut_bin(temp_train, key, y, 3, 0.1)
temp_train_lst_bin<-temp_train_all$lst_bin

temp_test<- test[, c(key, y, TempVar)]
temp_test_all<- txt_bin(temp_test, key, y, temp_train_lst_bin)
temp_test_lst_bin<- temp_test_all$lst_bin_test

plot_train_test_bin(temp_train_lst_bin[[TempVar]], temp_test_lst_bin[[TempVar]])

更多精彩，戳这里：