caret包函数不完全解析（转）

参考：xccd ，肖凯大牛的博客

 

########## caret 包总结 ###########

使用caret::mdrr

1、降维

a)删除的变量是常数自变量，或者是方差极小的自变量:

nearZeroVar:诊断预测变量是唯一值(即0方差自变量)

nearZeroVar(x, freqCut = 95/5, uniqueCut = 10, saveMetrics = FALSE)

参数:

x:只能为数值numeric vector，matrix，data frame

freqCut :第一众数 与 第二众数的比率的cutoff(临界值)(比如100个数值,有95个1，5个0；第一众数为95，第二众数为0，比率为95/5)

uniqueCut: 剔重后的唯一值 与 样本总数量的百分比 (上例为 2/100),大于这个值不会被剔除

saveMetrics:如果为T，返回样本每个属性的freqRatio,percentUnique,以及判定结果(zeroVar[0方差只有一个值],nzv[近似0方差(通过前两个参数判定)])

 

来看看函数写的?

 

 

 

帮助文档detail的例子写的很详细

 

test <- function(x,freqCut=95/5,uniqueCut=10,saveMetrics=FALSE) 

{

    if(is.vector(x)) 

        x<-matrix(x,ncol=1)

    # 按列处理

    freqRatio<-apply(x,2,function(data){

    # 频数表

        t<-table(data[!is.na(data)])

        # 如果matrix按列统计频率,只有唯一值(rep(3,5)) 或 被考察matrix为空，返回值为0 并 跳出函数

        if(length(t)<=1){

            return(0)

        }

        # 取出频数表中频数最大的下标

        w<-which.max(t)

        # 计算频数表最大的频数(第一众数) / 求除去第一众数的下标剩下的所有频数最大的值(第二众数);max忽略缺失值

        return(max(t,na.rm=TRUE)/max(t[-w],na.rm=TRUE))

    })

    print(freqRatio)

    # 计算matrix x按列 非NA的唯一值的数量(长度)

    lunique<-apply(x,2,function(data)length(unique(data[!is.na(data)])))

# (唯一值的数量/列的总数量)*100

    percentUnique<-100*lunique/apply(x,2,length)

    print(percentUnique)

    

    # 该列只有一个唯一值(该列为常量) 或 x都为NA

    # all:的参数为逻辑型is.na(data),返回逻辑向量(T|F),all:所有为T,返回T，否则为F；另外还有any():只要有一个即可

    # 返回逻辑向量

    zeroVar<-(lunique==1)|apply(x,2,function(data)all(is.na(data)))

    print(zeroVar)

    # 默认为F,如果为真,返回c(1,2)众数占比,unique唯一值总数占总数的比例，

# c(1,2)占比大于阈值freqCut并且唯一值比例小于阈值uniqueCut  或 0方差[常数] 逻辑型[T/F]

    if(saveMetrics){

        out<-data.frame(freqRatio=freqRatio,percentUnique=percentUnique, 

            zeroVar=zeroVar,nzv=(freqRatio]]]]>freqCut&percentUnique<= 

                uniqueCut)|zeroVar)

    }

    else{

    # freqRatio,percentUnique(列计算后的向量),三个向量从index=1开始，一一对应,进行判断条件

    # 满足条件时(TRUE),返回对应的下标(不区分是那个向量的下标),也就是源数据属性的下标,

    # out:问题数据就out了(形象),比如matrix为10列，其中3，5列为问题属性列,返回值即为3，5

        out<-which((freqRatio]]]]>freqCut&percentUnique<= 

            uniqueCut)|zeroVar)

       names(out)<-NULL

    }

    out

}

 

 

findCorrelation:

This function searches through a correlation matrix and returns a vector of integers corresponding to columns to remove to reduce pair-wise correlations.

 

1、通过对相关系数矩阵的查找,返回一个整数向量。这个整数向量对应具有很高相关性的 一对属性列的下标

 

The absolute values of pair-wise correlations are considered. If two variables have a high correlation, the function looks at the mean absolute correlation of each variable and removes the variable with the largest mean absolute correlation.

2、计算的是一对相关系数的绝对值(abs)。如果 两个变量有很高的相关系数, 那么函数将会探查 每一个变量相关系数的绝对值的均值

     并且删除具有最大绝对值相关系数均值的变量

     即：找出均值最大的相关系数的变量,返回下标

 

findCorrelation <- function (x, cutoff = 0.9, verbose = FALSE)

{

    varnum <- dim(x)[1]

    if (!isTRUE(all.equal(x, t(x))))

        stop("correlation matrix is not symmetric")

    if (varnum == 1)

        stop("only one variable given")

     # 相关系数矩阵的每一个元素取绝对值

    x <- abs(x)

    originalOrder <- 1:varnum

    # 对向量取均值(这里单独写成函数,是避免apply函数使用mean时,无法使用na.rm=T 的选项)

    # 例如:apply(tmp, 2, mean) 此时如果tmp有NA，将会返回NA

   

    averageCorr <- function(x) mean(x, na.rm = TRUE)

    # 系数矩阵另存变量

    tmp <- x

    # 对角阵设置NA

    diag(tmp) <- NA

    # 按列计算 已经绝对值处理过的相关系数矩阵tmp 的均值, 然后降序排序(即当前变量与其它变量的相关性)

    # 找出最相关的属性变量降序排序,返回值为排序的下标vector

    maxAbsCorOrder <- order(apply(tmp, 2, averageCorr), decreasing = TRUE)

     print("maxAbsCorOrder")

    print(maxAbsCorOrder)

   

    # expample:

    # abscor <- abs(cor(iris[,-5]));maxAbsCorOrder = 3 4 1 2

    # 下面的生成的x即为:第3行，第3列(3,3) 重新排序到第1行，第1列(1,1),

    # 第3行,第4列(3,4)-->第2行,第1列(2,1);

    # 即以3 4 1 2 为索引,将排序后的matrix,按列排序

   

    x <- x[maxAbsCorOrder, maxAbsCorOrder]

   

    newOrder <- originalOrder[maxAbsCorOrder]

    print("newOrder")

    print(newOrder)

    # 删除列下标

    deletecol <- 0

    print(x)

    # 循环已经按照相关系数大小排序后的 matrix 进行循环,如果每一个元素大于指定的阈值(cutoff),

    # 并且

    for (i in 1:(varnum - 1)) {

        for (j in (i + 1):varnum) {

            if (!any(i == deletecol) & !any(j == deletecol)) {

                if (verbose)

                  cat("Considering row\t", newOrder[i], "column\t",

                    newOrder[j], "value\t", round(x[i, j], 3),

                    "\n")

                # 如果x[i,j] 相关系数 大于 指定的阈值(如0.9)

                if (abs(x[i, j]) > cutoff) {

                  # 1、举例:比如c(1,2)元素相关系数为0.98,那么意味着,第一个和第二个元素相关性超出阈值

                  # 那么取出哪个作为相关性最大的属性呢?

                  # 思路:

                  # 1、统计第一个属性与其它属性的相关系数(即除去本节点外的其它行元素的均值)

                  # 2、第二个元素与其它元素的均值(去除当前节点)

                  # 3、如果第一个元素与其它元素均值大于 第二个元素与其它元素相关系数的均值,则取第一个元素的下标

                  # 4、并且unique 剔重

                  # 5、否则，将第二个元素的下标取出

                  if (mean(x[i, -i]) > mean(x[-j, j])) {

                    deletecol <- unique(c(deletecol, i))

                    if (verbose)

                      cat("  Flagging column\t", newOrder[i],

                        "\n")

                  }

                  else {

                    deletecol <- unique(c(deletecol, j))

                    if (verbose)

                      cat("  Flagging column\t", newOrder[j],

                        "\n")

                  }

                }

            }

        }

    }

    # 最开始deletecol赋值为0,此时剔除掉

    deletecol <- deletecol[deletecol != 0]

    # newOrder为按照列计算相关系数均值降序排序的 向量vector,如c(3,4,2,1),

    # deletecol:按照系数降序排序的只取出最大相关系数均值的 下标

    newOrder[deletecol]

}

 

 

 

preProcess：函数将多个函数进行了整合

 

例如:

1、如果使用methods = "bagImpute", 即使用装袋法的方式,拟合数据，那么看看preProcess是如何处理的?

 

命令行:

preProcess

函数返回片段(找到与bagImpute调用的代码段)

if (any(method == "bagImpute")) {

        if (verbose)

            cat("Computing bagging models for each predictor...")

        # 

        bagModels <- as.list(colnames(x))

        # 给列表定义名称(名称和列表内容一致)

        names(bagModels) <- colnames(x)

        bagModels <- lapply(bagModels, bagImp, x = x)

        if (verbose)

            cat(" done\n")

    }

 

关键代码为: bagModels <- lapply(bagModels, bagImp, x = x)

对数据x(数值型 的 matrix 或者 data frame)，对x使用bagImp方法进行拟合k紧邻，其中bagModels为数据框x的属性名称，类型必须为list。为什么呢？看bagImp方法

命令行:

bagImp # Error: object 'bagImp' not found

methods(bagImp) # Error: object 'bagImp' not found

 

getAnywhere(bagImp) # 最后一招奏效

描述

A single object matching 'bagImp' was found

It was found in the following places

  namespace:caret

with value

函数定义:

 

function (var, x, B = 10)

{

    # 加载bagging的包ipred

    library(ipred)

    # 转换为数据框

    if (!is.data.frame(x))

        x <- as.data.frame(x)

    # 拟合(结合preProcess调用处的代码,即 var = bagModels, x = x, nbagg = 10)

    # 

    mod <- bagging(as.formula(paste(var, "~.")), data = x, nbagg = B)

    list(var = var, model = mod)

}

<environment: namespace:caret>

 

> ma

     [,1] [,2] [,3] [,4]

[1,]    1    5    9   13

[2,]    2    6   10   14

[3,]    3    7   11   15

[4,]    4    8   12   16

> colnames(ma) <- c("v1","v2","v3","v4")

> ma

     v1 v2 v3 v4

[1,]  1  5  9 13

[2,]  2  6 10 14

[3,]  3  7 11 15

[4,]  4  8 12 16

> ma.list <- as.list(colnames(ma))

> ma.list

[[1]]

[1] "v1"

 

[[2]]

[1] "v2"

 

[[3]]

[1] "v3"

 

[[4]]

[1] "v4"

 

> names(ma.list) <- colnames(ma)

> ma.list

$v1

[1] "v1"

 

$v2

[1] "v2"

 

$v3

[1] "v3"

 

$v4

[1] "v4"

 

> as.formula(paste(ma.list,"~."))

v1 ~ .

> fora <- as.formula(paste(ma.list,"~."))

> class(fora)

[1] "formula"

为什么去掉as.fornula 之后，结果是下面这样呢？看看as.formula

> paste(ma.list,"~.")

[1] "v1 ~." "v2 ~." "v3 ~." "v4 ~."

 

看看会不会去掉v2以后的内容

function (object, env = parent.frame())

{

    if (inherits(object, "formula"))

        object

    else {

        rval <- formula(object, env = baseenv())

        if (identical(environment(rval), baseenv()) || !missing(env))

            environment(rval) <- env

        rval

    }

}

 

 

paste(ma.list,"~.")[1]

[1] "v1 ~."

> paste(ma.list,"~.")[2]

[1] "v2 ~."

 

formula会默认取第一个

 

caret包可以处理至少以下事情.

1、初步筛选属性(过滤以下属性)

a、找出 属性值接近为常数的 属性 nearZeroVar

b、找出 相关系数最大的        属性 findCorrelation

c、找出 多重共线性的           属性 findLinearCombos

 

2、处理缺失值 

preProcess(data, method=c("bagImpute","knnImpute"));predict(pro, newdata)

 

3、中心化、标准化

preProcess(data, method=c("center","scale"))

 

4、特征选择

rfeControl,rfe

 

5、抽样数据划分

createDataPartition()

createFold()…

 

6、模型训练

trainControl():设置训练交叉验证的重数,重复几次等

train(): 设置使用何种模型训练(查看函数定义[非常之多])

 

7、预测结果

predict()

 

 

 

# 定义属性个数

data(mdrr)

# 0 variance

newdata <- mdrrDescr[, -nearZeroVar(mdrrDescr)]

# high cor

descrCorr <- cor(newdata)

newdata2 <- newdata[, -findCorrelation(descrCorr)]

 

# 去掉共线性(如果存在)

comboInfo <- findLinearCombos(newdata2)

if(!is.null(comboInfo)){

     newdata3 <- newdata2[, -comboInfo$remove]

} 

 

# 如果有缺失值,使用bagImpute,knnImpute进行计算填补

if(nrow(newdata2[!complete.cases(newdata2),])=0)

{

process <- preProcess(newdata2, method="bagImpute")

pre <- predict(process, newdata2)

}

 

# feather selection

# 产生检测属性个数的序列

subsets <- seq(2, ncol(newdata2), by=2)

 

# define rfeControl

ctl <- rfeControl(functions=rfFuncs, method="cv", verbose=FALSE, returnResamp="final")

 

# rfe: feature selection

pro <- rfe(newdata2, mdrrClass, sizes = subsets, rfeControl=ctl)

 

plot(pro);

# feature selected variables

pro$optVariables

 

# 训练模型

# 获取特征选择后的属性

newdata4 <- newdata2[, pro$optVariables]

 

# 训练数据和测试数据

 

index <- createDataPartition(mdrrClass, p=3/4, list=F)

 

trainx <- newdata4[index,]

trainy <- mdrrClass[index]

 

testx <- newdata4[-index,]

testy <- mdrrClass[-index]

 

# 设置模型训练参数并拟合模型

fitControl <- trainControl(method="repeatedcv", number=10, repeats=3, returnResamp="all")

 

gbmGrid <- expand.grid(.interaction.depth=c(1,3), .n.trees=seq(50,300,by=50), .shrinkage=0.1)

 

gbmFit1 <- train(trainx, trainy, method="gbm", trControl=fitControl, tuneGrid= gbmGrid, verbose=F)

trainControl

plot(gbmFit1)

 

# 使用训练好的模型进行predict

predict(gbmFit1, newdata=testx)

# 混淆矩阵查看结果

table(testy, predict(gbmFit1, newdata=testx))

 

# 使用另外的模型(装袋法)

gbmFit2 <- train(trainx, trainy, method="treebag", trControl=fitControl)

table(testy, predict(gbmFit2, newdata=testx))

 

models <- list(gbmFit1, gbmFit2);

 

predValues <- extractPrediction(models, testX=testx, testY=testy)

# predValues <- extractPrediction(models, testX=testx)

 

转自：http://blog.csdn.net/wolfbloodbj/article/details/8831877