RPackage011---SMOTE

title: “Learning R—SMOTE”

author: “刘栋”

date: “2017年11月20日”

output: word_document

knitr::opts_chunk$set(echo = TRUE)      

AIM

使用rmarkdown编辑~

主要目标学习SMOTE算法，并且利用DMwR实现该算法，用以处理类不平衡问题。

简介

该函数使用SMOTE算法处理类不平衡问题。简而言之，这个函数能够生成SMOTE算法处理之后的数据。或者，它也可以在新生成的数据集建立二分类模型，并且返回最终的模型。

函数使用方式

Code

SMOTE(form, data, perc.over = 200, k = 5, perc.under = 200,
learner = NULL, ...)      

参数说明

1 . form 公式，用以描述预测问题

2 . data 原始不平衡数据集

3 . perc.over 过采样比例p1=perc.over/100，一个少数类样本生成p1·n1+n1个样本

4 . 默认值为5，k 生成少数类新样本时，所采用的邻居数。即knn中的k

5 . perc.under 欠采样比例 如果p2=perc.under/100,那么生成p1·n1·p2个新样本。貌似是可重复抽样

6 . learner 默认为NULL，参数值可以是一个字符串，表示一个函数，应用于新数据集

7 . … 指定learner的一些别的参数

8 . 若配置数据集1:1，保证perc.over/100 + 1 =perc.over/100 *perv.under/100即可

Details

类不平衡问题会对许多机器学习算法产生影响。该问题的特征为每一类所占的比例不均匀。SMOTE(Chawla et. al. 2002)是解决这一问题的好方法。SMOTE的大体思想为：利用少数类样本的近邻人为的生成新样本(少数类的)。此外，多数类样本也可以使用欠采样，使得数据集更加平衡。

参数perc.over和perc.under控制过采样、欠采样的数量。perc.over 通常大于100，每一个少数类样本都会产生perc.over/100个新样本。如果perc.over小于100，则按照给定比例(perc.over/100)随机产生样本。

参数perc.under决定多数类样本最终随机抽取到新数据集的比例(perc.over/100)

举个栗子：如果少数类样本生成200个新样本，并且perc.under值为100，那么多数类样本中也会精确地抽取200个样本，组成最终的数据集。而如果perc.under值大于100，则会从多数类中抽取更多样本，样本数为少数类新生成的样本数。

参数k决定新样本产生的方式，每一个少数类的样本都会产生新样本，产生新样本的数量有perc.over决定。这些新样本由每个老样本的k个近邻产生。参数k决定邻居的数量。

该函数还可以对新样本集建立分类模型。通过参数learner确定分类模型的名称，也可以添加该模型函数的其他参数。如果参数learner的值不是NULL，那么该函数返回的值是学习模型，而不是新的平衡数据集。模型的参数第一个参数是预测公式，第二个参数是训练集。

Value

Examples

## A small example with a data set created artificially from the IRIS
## data
data(iris)
data <- iris[, c(1, 2, 5)]
data$Species <- factor(ifelse(data$Species == "setosa","rare","common"))
## checking the class distribution of this artificial data set
table(data$Species)
## 少数类为common，共100个样本；多数类为rare，共50个样本。
## now using SMOTE to create a more "balanced problem"
## 参数说明：
## perc.over 过采样600/100,6倍，则少数类样本生成6*50=300个新样本，加上原来的50个样本共计350个样本
## perc.under 欠采样100/100，1倍，从多数类中抽取300*1个新样本
library(DMwR)
newData <- SMOTE(Species ~ ., data, perc.over = 600,perc.under = 100)
table(newData$Species)
## Checking visually the created data
## Not run:
par(mfrow = c(1, 2))
plot(data[, 1], data[, 2], pch = 19 + as.integer(data[, 3]),
main = "Original Data")
plot(newData[, 1], newData[, 2], pch = 19 + as.integer(newData[,3]),
main = "SMOTE'd Data")
## End(Not run)
## Now an example where we obtain a model with the "balanced" data
classTree <- SMOTE(Species ~ ., data, perc.over = 600,perc.under = 100,
learner='rpartXse',se=0.5)
## check the resulting classification tree
classTree
## The tree with the unbalanced data set would be
rpartXse(Species ~ .,data,se=0.5)      

源码

# SMOTE -------------------------------------------------------------------

function (form, data, perc.over = 200, k = 5, perc.under = 200, 
          learner = NULL, ...) 
{
  tgt <- which(names(data) == as.character(form[[2]])) ## 目标变量的索引,第几列
  minCl <- levels(data[, tgt])[which.min(table(data[, tgt]))] ## 取出少数类名称
  minExs <- which(data[, tgt] == minCl) ## 少数类的行索引
  ## 如果目标变量不是最后一列,那么把目标变量换到最后一列~
  ## 用写的这么麻烦吗？单独拉出来重新赋值不就行了
  if (tgt < ncol(data)) {
    cols <- 1:ncol(data) ## 存放列的向量1:n
    cols[c(tgt, ncol(data))] <- cols[c(ncol(data), tgt)]
    data <- data[, cols]
  }
  ## 少数类生成新样本的函数，没有找到详细的函数呀
  ## 看看包里是不是有这个函数
  newExs <- smote.exs(data[minExs, ], ncol(data), perc.over, 
                      k)
  ## 再按照原数据集列的顺序调整回去
  if (tgt < ncol(data)) {
    newExs <- newExs[, cols]
    data <- data[, cols]
  }
  ## 多数类可重复抽样，抽取样本数为perc.under/100*少数类新增的样本数
  selMaj <- sample((1:NROW(data))[-minExs], as.integer((perc.under/100) * 
                                                         nrow(newExs)), replace = T)
  ## 合并数据集
  newdataset <- rbind(data[selMaj, ], data[minExs, ], newExs)
  ## 如果learner参数为空，返回处理之后的数据集。否则调用指定的分类模型，返回模型结果
  if (is.null(learner)) 
    return(newdataset)
  else do.call(learner, list(form, newdataset, ...))
}



# smote.exs ---------------------------------------------------------------


newExs <- smote.exs(data[minExs, ], ncol(data), perc.over,k)

## 参数 data少数类样本，tgt目标变量所在列，perc.over欠采样参数,k近邻数
function (data, tgt, N, k)
{
  nomatr <- c()
  ## 生成一个空矩阵，行数是少数类的行数，列为原数据框列数-1
  T <- matrix(nrow = dim(data)[1], ncol = dim(data)[2] - 1)
  ## for循环是为了将少数类样本中的字符型或者因子型变量转换为数值型
  ## 遍历每一个列，如果是因子型或者字符型，转换成数值型
  ## nomatr 为因子or字符型变量所在的列
  for (col in seq.int(dim(T)[2])){
    if (class(data[, col]) %in%
        c("factor", "character")) {
      T[, col] <- as.integer(data[, col])
      nomatr <- c(nomatr, col)
    }
    else
      T[, col] <- data[, col]
  }
  ## 欠采样参数如果小于100,不重复简单随机抽样抽取as.integer((N / 100) * nT)个样本
  if (N < 100) {
    nT <- NROW(T)
    idx <- sample(1:nT, as.integer((N / 100) * nT))
    T <- T[idx,]
    N <- 100
  }
  p <- dim(T)[2]
  nT <- dim(T)[1]
  ## 求每一列的值域，不包括目标变量列
  ranges <- apply(T, 2, max) - apply(T, 2, min)
  nexs <- as.integer(N / 100)
  ## 生成新的矩阵，行数为 as.integer(N / 100)*nT,即perc.over/100 * 原来少数类样本的行数
  ## 相当于每一个少数类样本新生成perc.over/100新样本
  new <- matrix(nrow = nexs * nT, ncol = p)
  ## 对每一个少数类样本进行操作
  ## xd是标准化之后的矩阵。标准化方法为极差标准化
  ## 但是不是减去均值，而是减去指定的矩阵行数据，最后除以极差
  for (i in 1:nT) {
    xd <- scale(T, T[i,], ranges)
    ## 遍历所有字符串列,判断元素是否为0，返回TRUE or FALSE 覆盖原值
    ## 矩阵元素平方，行求和，drop转换成向量
    for (a in nomatr)
      xd[, a] <- xd[, a] == 0
    ## 不知道这个是干嘛的
    dd <- drop(xd ^ 2 %*% rep(1, ncol(xd)))
    ## 排序取最近
    ## order函数有小到大返回相关数字的索引
    ## 取出第2小-k+1个小的索引
    kNNs <- order(dd)[2:(k + 1)]
    
    ## nexs = as.integer(perc.over/100)
    ## 每次随机抽取
    for (n in 1:nexs) {
      neig <- sample(1:k, 1)
      ex <- vector(length = ncol(T))
      ## 选取一个随机确定的邻居，得到邻居和该少数类样本的差
      difs <- T[kNNs[neig],] - T[i,]
      ## 构造出新样本，构造逻辑真奇怪，还要看下论文
      new[(i - 1) * nexs + n,] <- T[i,] + runif(1) *
        difs
      for (a in nomatr)
        new[(i - 1) * nexs + n, a] <- c(T[kNNs[neig],
                                          a], T[i, a])[1 + round(runif(1), 0)]
    }
  }
  newCases <- data.frame(new)
  for (a in nomatr)
    newCases[, a] <- factor(newCases[, a],
                            levels = 1:nlevels(data[, a]),
                            labels = levels(data[,
                                                 a]))
  newCases[, tgt] <- factor(rep(data[1, tgt], nrow(newCases)),
                            levels = levels(data[, tgt]))
  colnames(newCases) <- colnames(data)
  newCases
}      

Ref