R使用笔记(4):处理不平衡数据集——基于UCI人口调查数据集

Like it or not , a bitter truth about data science industry is that self-learning, certification, coursework is not sufficient to get you a job.

这是一篇关于如何处理不平衡数据集的文章,笔者在这之前接触的数据量实在太少了(当然这100多M的数据也不多咯!),学习R语言呢,如果没有在实际当中用,说到底还是纸上谈兵。大家还是相信这句话,\(Talk\ is\ cheap,\ show\ me\ the\ code.\)R语言的学习曲线比较高,当中的东西太多太杂,要想在短时间内在R中做到触类旁通简直艰难。在接触到这个小项目(姑且称为小项目)后,踩了好多坑,书上看到的数据清洗和工程应用中的数据清洗可是完全不同的概念。写完这篇文章之后,感觉自己的编程能力太渣,代码的编写阅读量还是太少,任重道远~

在实际工程中,有一些极端条件(欺诈检测、癌症诊断、在线广告捕捉)会使得数据集十分不平衡,目标变量的分布可能会呈现极端分布态势。做这个项目有什么好处呢?

  • 处理不平衡数据是一个技巧性的工作
  • 数据的维度高,因此,它可以帮助你理解和克服机器的内存问题
  • 提升你的编程、数据分析和机器学习技能

目录

  • 描述问题&生成假设
  • 探索数据
  • 数据清洗
    • 遗漏值处理
  • data manipulation 特征工程
  • 机器学习
    • 不平衡技巧
      • 上采样(oversampling)
      • 下采样(undersampling)
      • SMOTE
    • Naive Bayes
    • XgBoost
    • SVM

描述问题&生成假设

给定拥有多个特征的数据集,目标是根据这些特征来建立一个预测收入水平是大于50K还是小于50K的分类模型。

Prediction task is to determine the income level for the person represented by the record. Incomes have been binned at the $50K level to present a binary classification problem, much like the original UCI/ADULT database.

从问题的描述来看,这是一个二分类问题,目标函数输出的结果只有两种类型,即“是”或者“否”。

我们拿到数据要做的第一件事便是打开看看,数据量有多大?有多少个特征?特征是连续型的还是非连续型的?有没有缺失数据?······

在这个项目中我们用到的是来自UCI机器学习的数据集,这是一份美国人口的调查数据,打开数据集,我们会发现列的名字全部都丢失了,完好的数据集在这里下载训练集测试集

考虑到原数据集比较大,我们要用到data.table()这个包。

探索数据

1
2
3
library(data.table)
train <- fread("E:/R/imbalancedata/train.csv",na.string=c(""," ","?","NA",NA))
test <- fread("E:/R/imbalancedata/test.csv",na.string=c(""," ","?","NA",NA))

从数据加载之后的情况来看,训练集中有199523个观测值,41个特征(变量),测试集的观测值有99762个,同样也是41个特征(变量)。回到我们的目标,我们的目标是要建立预测收入的模型,那么因变量是什么?是收入水平。

1
2
train[1:5]
test[1:5]

查看因变量的水平,结果发现训练集的income_level只有-50000+50000两个指标,而测试集也只有-5000050000+.两个指标,分别对应>50K和<50K两个水平。为了计算方便,我们还需要将income_level下的水平替换为0和1。

check target variables levels}
1
2
3
4
unique(train$income_level)
unique(test$income_level)
[1] "-50000" "+50000"
[1] "-50000" "50000+."
encode target variables as 0 & 1}
1
2
3
train[,income_level:= ifelse(income_level == "-50000",0,1)]
#ifelse(test,yes,no)
test[,income_level:= ifelse(income_level == "-50000",0,1)]

项目的主要研究对象是不平衡数据,那么我们就来看看数据不平衡的程度到底有多严重。

severity of imbalanced classes}
1
2
3
round(prop.table(table(train$income_level))*100)
0 1
94 6

从反馈的结果可以看出,原始训练集的数据分布及其不均衡,收入水平<50K的人群占据了94%,>50K的人群仅仅占了6%(毕竟有钱人还是少!),这是一个典型的不平衡数据集,那么如何由这种不平衡数据集学习到一个准确预测收入水平的模型呢?这是主要要解决的难题。

数据预处理

首先,从数据集介绍的页面可以了解到,特征被分为nominal(名义型)和continuous(连续型)两种类型,而在对数据进行预处理时,首先要解决的便是将这两种不同的数据类型切分开来,data.table包可以帮助我们快速简单地完成这个任务。

set column classes as numerical or categorical}
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
#数据集介绍的页面已经告诉我们哪些特征为nominal或是continuous
factcols <- c(2:5,7,8:16,20:29,31:38,40,41)
numcols <- setdiff(1:40,factcols)
train[,(factcols) := lapply(.SD, factor), .SDcols = factcols]
train[,(numcols) := lapply(.SD, as.numeric), .SDcols = numcols]
test[,(factcols) := lapply(.SD, factor), .SDcols = factcols]
test[,(numcols) := lapply(.SD, as.numeric), .SDcols = numcols]
#分别将训练集和测试集中的nominal和continuous提取出来
cat_train <- train[,factcols, with=FALSE]
cat_test <- test[,factcols,with=FALSE]
num_train <- train[,numcols,with=FALSE]
num_test <- test[,numcols,with=FALSE]
#为了节省内存,之前的两个数据集就可以暂时先移出内存空间
rm(train,test) #to save memory

单纯查看数据集无法得到直观的感受,图形是最简单直观的办法,下面我们会用到ggplot2plotly两个强大的绘图包。

plot variable histogram}
1
2
3
4
5
6
7
8
9
10
library(ggplot2)
library(plotly)
tr <- function(a){ggplot(data = num_train, aes(x= a, y=..density..)) +
geom_histogram(fill="blue",color="red",alpha = 0.5,bins =100) + geom_density()
ggplotly()
}
tr(num_train$age)
tr(num_train$capital_losses)

以上得出的两个分布图符合我们的常识,年龄分布在0~90岁之间,年龄越大,所占比例越小。可以看出,大部分年龄段处于25-65的人收入水平income_level为1(大于50K),他们的小时工资wage per hour处在1000$到4000$的水平。这个事实进一步强化了我们认为年龄小于20的人收入水平小于50K的假设。

从数据中发现隐藏的信息往往是说起来比做容易。我们需要从数据变量的不同角度去发现隐藏的趋势,这样对工程才是有帮助的。

同样的,我们也可以将分类变量以可视化的形式展现出来,对于类别数据,dodged bar chart比条形图能展更多的信息。在dodged bar chart中,我们将类别变量和非独立变量两两相邻。

我们分别考虑训练集中的数值型变量和型变量与income_level的关系,首先看数值型变量,也就是num_trainnum_train下有wage_per_hour``capital_gains``capital_losses``dividend_from_Stocks等等几个特征,接下来要做的就是观察这几个特征与收入的关系。

通过ggplot作图包,我们选取了四个关联程度较大的指标,图中我们可以看出,income_level为1,也就是收入水平大于50000的人似乎都落在25~65这个阶段,wage_per_hour的工资水平大概在1000$到4000$的水平。

create a scatter plot wage with income}
1
2
3
4
5
#income_level属于类别型的,被切分到了cat_train中
num_train[,income_level := cat_train$income_level]
ggplot(data=num_train,aes(x = age,
y=wage_per_hour))+geom_point(aes(colour=income_level))+scale_y_continuous("wage per
hour", breaks = seq(0,10000,1000))

股票收益对收入的影响也是比较大的,收入水平>50000$的人群基本上股票分红都超过了30000美元

create a scatter plot stocks with income}
1
2
3
num_train[,income_level := cat_train$income_level]
ggplot(data=num_train,aes(x = age,y=dividend_from_Stocks))+geom_point(aes(colour=income_level))+
scale_y_continuous("dividend from stocks", breaks = seq(0,10000,5000))

类似地,我们可以还可以查看capital_gains资本增值和capital_losses资本贬值与收入水平的关系,如下图所示

同样地,针对类别型变量也可以做类似的可视化操作,对于类别型数据,用点图不太合适,dodged bar chart比条形图能展更多的信息。在dodged bar chart中,我们将类别变量和非独立变量两两相邻。

1
2
3
all_bar <- function(i){
ggplot(cat_train,aes(x=i,fill=income_level))+geom_bar(position = "dodge", color="black")+scale_fill_brewer(palette = "Pastel1")+theme(axis.text.x =element_text(angle = 60,hjust = 1,size=10))
}

这里的all bar暂时不知道啥意思==

数据清洗

数据清洗时数据分析的一个重要步骤,首先检查,训练集和测试集中是否有遗漏值

checking missing values in numerical data}
1
2
table(is.na(num_train))
table(is.na(num_test))

从反馈的结果来看,FALSE分别等于1596184=199523×8,698334=99762×7,故训练集和测试集中没有一个遗漏值,这是一个不错的消息!拿到数据之后,通常检查数值型变量之间的相关性是一个不错的选择,caret包能够帮助我们筛选出高度相关的变量

filter out variables with high correlation}
1
2
3
4
5
library(caret)
x <- cor(num_train)
ax <- findCorrelation(x, cutoff=0.7)
num_train <- num_train[,-ax,with=FALSE]
num_test <- num_test[,weeks_worked_in_year := NULL]

筛选的结果显示,weeks_worked_in_year变量与其他变量存在相当高的相关性,这很好理解,因为一年之中工作的时间越长那么相应的工资、回报也会随之上涨,所以要把这个高度相关性的变量剔除掉,这样num_train当中就只剩下6个变量了。

似乎训练集中数值型的数据已经处理得差不多了,下面我们来看看训练集中类别型的数据cat_train,首先检查每一列数据的遗漏情况

check missing values per column}
1
2
3
4
5
mvtr <- sapply(cat_train, function(x){sum(is.na(x))/length(x)})*100
mvte <- sapply(cat_test, function(x){sum(is.na(x)/length(x))}*100)
mvtr
mvte

大部分的列情况比较乐观,但是有的列甚至有超过50%的数据遗漏(这有可能是由于采集数据难度所致,特别是人口普查),将遗漏率小于5%的列挑选出来,遗漏率太高的不要。

select columns with missing values less than 5%}
1
2
cat_train <- subset(cat_train, select = mvtr < 5 )
cat_test <- subset(cat_test, select = mvte < 5)

对于cat_train中剩下的遗漏值,比较好的办法是将其标记为“Unavailable”,这里要借助于data.table包中的set()函数,它将使标记工作变得很简单。

1
2
3
4
5
6
7
8
9
10
11
cat_train <- cat_train[,names(cat_train) := lapply(.SD, as.character),.SDcols = names(cat_train)]
for (i in seq_along(cat_train)) set(cat_train, i=which(is.na(cat_train[[i]])), j=i, value="Unavailable")
cat_train <- cat_train[, names(cat_train) := lapply(.SD,factor), .SDcols = names(cat_train)]
cat_test <- cat_test[, (names(cat_test)) := lapply(.SD, as.character), .SDcols = names(cat_test)]
for (i in seq_along(cat_test)) set(cat_test, i=which(is.na(cat_test[[i]])), j=i, value="Unavailable")
cat_test <- cat_test[, (names(cat_test)) := lapply(.SD, factor), .SDcols = names(cat_test)]

数据操作——标准化处理

在前面的分析中,有的类别变量下个别水平出现的频率很低,这样的数据对我们的分析作用不是特别大。在接下来的步骤中,我们的任务是将这些变量下频率低于5%的水平字段 设置为“Other”。处理完类别型数据之后,对于数值型数据,各个变量下的水平分布过于稀疏,所以需要将其规范化。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#将cat_train和cat_test中每列下出现频率低于5%的水平设置为“Other”
for(i in names(cat_train)){
p <- 5/100
ld <- names(which(prop.table(table(cat_train[[i]])) < p ))
levels(cat_train[[i]])[levels(cat_train[[i]]) %in% ld] <- "Other"
}
for(i in names(cat_test)){
p <- 5/100
ld <- names(which(prop.table(table(cat_test[[i]])) < p ))
levels(cat_test[[i]])[levels(cat_test[[i]]) %in% ld] <- "Other"
}
library(mlr)
#"nlevs"参数:返回每列下维度的个数,测试集和训练集是否匹配
summarizeColumns(cat_train)[,"nlevs"]
summarizeColumns(cat_test)[,"nlevs"]
num_train[,.N,age][order(age)]
num_train[,.N,wage_per_hour][order(-N)]
#以0,30,90为分隔点,将年龄段划分为三个区段,“young”,“adult”,“old”
num_train[,age:= cut(x = age,breaks = c(0,30,60,90),include.lowest = TRUE,labels = c("young","adult","old"))]
num_train[,age := factor(age)]
num_test[,age:= cut(x = age,breaks = c(0,30,60,90),include.lowest = TRUE,labels = c("young","adult","old"))]
num_test[,age := factor(age)]
#将wage_per_hour,capital_gains,capital_losses,dividend_from_Stocks设置为只有0和大于0两个水平
num_train[,wage_per_hour := ifelse(wage_per_hour == 0,"Zero","MoreThanZero")][,wage_per_hour := as.factor(wage_per_hour)]
num_train[,capital_gains := ifelse(capital_gains == 0,"Zero","MoreThanZero")][,capital_gains := as.factor(capital_gains)]
num_train[,capital_losses := ifelse(capital_losses == 0,"Zero","MoreThanZero")][,capital_losses := as.factor(capital_losses)]
num_train[,dividend_from_Stocks := ifelse(dividend_from_Stocks == 0,"Zero","MoreThanZero")][,dividend_from_Stocks := as.factor(dividend_from_Stocks)]
num_test[,wage_per_hour := ifelse(wage_per_hour == 0,"Zero","MoreThanZero")][,wage_per_hour := as.factor(wage_per_hour)]
num_test[,capital_gains := ifelse(capital_gains == 0,"Zero","MoreThanZero")][,capital_gains := as.factor(capital_gains)]
num_test[,capital_losses := ifelse(capital_losses == 0,"Zero","MoreThanZero")][,capital_losses := as.factor(capital_losses)]
num_test[,dividend_from_Stocks := ifelse(dividend_from_Stocks ==0,"Zero","MoreThanZero")][,dividend_from_Stocks := as.factor(dividend_from_Stocks)]
num_train[,income_level := NULL]
标准化处理之后的结果

标准化处理之后的结果

组合数据

1
2
3
4
5
6
7
8
9
10
11
12
13
14
d_train <- cbind(num_train, cat_train)
d_test <- cbind(num_test, cat_test)
rm(num_train,cat_train,num_test,cat_test)
library(mlr)
train.task <- makeClassifTask(data = d_train, target = "income_level")
test.task <- makeClassifTask(data = d_test, target = "income_level")
train.task <- removeConstantFeatures(train.task)
test.task <- removeConstantFeatures(test.task)
var_imp <- generateFilterValuesData(train.task, method = c("information.gain"))
plotFilterValues(var_imp,feat.type.cols = TRUE)

处理不平衡数据集的几种统计学方法:下采样、上采样、SMOTE

应对不平衡数据集,通常需要使用特别的技巧,如上采样(oversampling)、下采样(undersampling),以及过采样的一种代表性方法SMOTE(Synthetic Minority Oversampling TEchnique)算法。

  • 上采样:即增加一些正例使得正、反例数目接近,然后再进行学习
  • 下采样:去除一些反例使得正、反例数目接近,然后进行学习
  • SMOTE:通过对训练集里的正例进行插值来产生额外的正例,主要思想是通过在一些位置相近的少数类样本中插入新样本来达到平衡的目的

下采样法的时间开销通常远远小于上采样法,因为前者丢弃了很多反例,使得训练集远小于初始训练集,下采样另外一个可能的缺陷在于 它可能会导致信息的丢失。上采样法增加了很多正例,训练集的大小大于初始训练集,训练时间开销变大,而且容易导致过拟合。更多关于 SMOTE采样方法,[Chawla et al., 2002]的这篇文章有详细的说明。

1
2
3
4
5
6
7
8
9
train_under <- undersample(train.task, rate = 0.1)
table(getTaskTargets(train_under))
train_over <- oversample(train.task, rate = 15)
table(getTaskTargets(train_over))
system.time(train_smote <- smote(train.task, rate = 15, nn=3))

naive Bayes

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
naive_learner <- makeLearner("classif.naiveBayes", predict.type = "response")
naive_learner$par.vals <- list(laplace = 1)
folds <- makeResampleDesc("CV", iters = 10, stratify = TRUE)
fun_cv <- function(a){
crv_val <- resample(naive_learner,a,folds,measures = list(acc,tpr,tnr,fpr,fp,fn))
crv_val$aggr
}
fun_cv(train.task)
fun_cv(train_under)
fun_cv(train_over)
nB_model <- train(naive_learner, train_over)
nB_predict <- predict(nB_model, test.task)
nB_prediction <- nB_predict$data$response
dCM <- confusionMatrix(d_test$income_level,nB_prediction)
# Accuracy : 0.8174
# Sensitivity : 0.9862
# Specificity : 0.2299
# calculate F measure
precision <- dCM$byClass['Pos Pred Value']
recall <- dCM$byClass['Sensitivity']
f_measure <- 2*((precision*recall)/(precision+recall))
f_measure

参考文献

  1. Chawla N V, Bowyer K W, Hall L O, et al. SMOTE: synthetic minority over-sampling technique[J]. Journal of artificial intelligence research, 2002, 16: 321-357.
  2. Chawla N V. Data mining for imbalanced datasets: An overview[M]//Data mining and knowledge discovery handbook. Springer US, 2005: 853-867.