从 caret::train 获取预测的置信区间

Question

我试图弄清楚如何从插入符号::train 线性 model 获得置信区间。

我的第一次尝试只是使用通常的 lm 置信区间 arguments 运行预测：

m <- caret::train(mpg ~ poly(hp,2), data=mtcars, method="lm")
predict(m, newdata=mtcars, interval="confidence", level=0.95)

但看起来从 caret::train 返回的 object 没有实现这个。

我的第二次尝试是提取 finalModel 并对此进行预测：

m <- caret::train(mpg ~ poly(hp,2), data=mtcars, method="lm")
fm <- m$finalModel
predict(fm, newdata=mtcars, interval="confidence", level=0.95)

但我得到了错误

Error in eval(predvars, data, env) : object 'poly(hp, 2)1' not found

深入挖掘，似乎最终的 model 对公式有一些奇怪的表示，并且正在我的 newdata 中搜索“poly(hp, 2)1”列，而不是评估公式。 m$finalModel 看起来像这样：

Call:
lm(formula = .outcome ~ ., data = dat)

Coefficients:
   (Intercept)  `poly(hp, 2)1`  `poly(hp, 2)2`  
         20.09          -26.05           13.15

我应该补充一点，我不只是使用lm ，因为我使用插入符号通过交叉验证来适应 model。

如何通过 caret::train 从线性 model 中获得置信区间？

Answer 1

免责声明：

这是一个可怕的答案，或者caret package 只是对这个特定问题有一个可怕的实现。 在任何一种情况下，如果尚不存在，它似乎适合在github上打开问题或希望（希望更多样化的predict功能或修复object$finalModel中使用的命名）

问题（发生在第二次试验）源于caret package 如何在内部处理各种拟合程序，基本上限制了预测 function 似乎是为了清洁和标准化目的。

问题：

问题有两个方面。

1. predict.train不允许预测/置信区间
2. train(...)的finalModel中包含的 finalModel 包含一个格式异常的公式。

这两个问题似乎源于train的格式和predict.train的用法。 首先关注后一个问题，通过查看 output 从

formula(m$finalModel)
#`.outcome ~ `poly(hp, 2)1` + `poly(hp, 2)2`)

显然，在运行train时会执行一些格式化，因为预期的 output 将是mpg ~ poly(hp, 2) ，而 output 扩展了 RHS（并添加了引号/标签）并更改了 LHS。 因此，修复公式或能够使用公式会很好。

研究caret package 如何在predict.train function 中使用它，揭示了下面用于newdata输入的代码片段

predict.formula
#output
--more code
if (!is.null(newdata)) {
    if (inherits(object, "train.formula")) {
        newdata <- as.data.frame(newdata)
        rn <- row.names(newdata)
        Terms <- delete.response(object$terms)
        m <- model.frame(Terms, newdata, na.action = na.action, 
            xlev = object$xlevels)
        if (!is.null(cl <- attr(Terms, "dataClasses"))) 
            .checkMFClasses(cl, m)
        keep <- match(row.names(m), rn)
        newdata <- model.matrix(Terms, m, contrasts = object$contrasts)
        xint <- match("(Intercept)", colnames(newdata), 
            nomatch = 0)
        if (xint > 0) 
            newdata <- newdata[, -xint, drop = FALSE]
    }
}
--more code
    out <- predictionFunction(method = object$modelInfo, 
                modelFit = object$finalModel, newdata = newdata, 
                preProc = object$preProcess)

For the less experienced R users, we basically see, that a model.matrix is constructed from scratch without using the output of formula(m$finalModel) (we can use this,), and later some function is called to predict based on the m$finalModel 。 从同一个 package 中查看predictionFunction发现这个 function 只是调用m$modelInfo$predict(m$finalModel, newdata) （对于我们的例子）

最后查看m$modelInfo$predict会显示以下代码片段

m$modelInfo$predict
#output
function(modelFit, newdata, submodels = NULL) {
                    if(!is.data.frame(newdata)) 
                        newdata <- as.data.frame(newdata)
                    predict(modelFit, newdata)
                  }

请注意， modelFit = m$finalModel和newdata是使用上面的 output 生成的。 另请注意，对predict的调用不允许指定interval = "confidence" ，这是第一个问题的原因。

解决问题（排序）：

有无数种方法可以解决这个问题。 一种是使用lm(...)而不是train(...) 。 另一个是利用 function 的内部结构来创建一个数据 object，它符合奇怪的 model 规范，所以我们可以使用新数据的predict(m$finalModel, newdata = newdata, interval = "confidence") 。

我选择做后者。

caretNewdata <- caretTrainNewdata(m, mtcars)
preds <- predict(m$finalModel, caretNewdata, interval = "confidence")
head(preds, 3)
#output
                         fit      lwr      upr
Mazda RX4           22.03708 20.74297 23.33119
Mazda RX4 Wag       22.03708 20.74297 23.33119
Datsun 710          24.21108 22.77257 25.64960

function 如下所示。 对于书呆子，我基本上从predict.train 、 predictionFunction和m$modelInfo$predict中提取了model.matrix构建过程。 我不会 promise 这个 function 适用于每个caret model 的一般情况使用，但它是一个开始的地方。

caretTrainNewdata function：

caretTrainNewdata <- function(object, newdata, na.action = na.omit){
    if (!is.null(object$modelInfo$library)) 
        for (i in object$modelInfo$library) do.call("requireNamespaceQuietStop", 
                                                    list(package = i))
    if (!is.null(newdata)) {
        if (inherits(object, "train.formula")) {
            newdata <- as.data.frame(newdata)
            rn <- row.names(newdata)
            Terms <- delete.response(object$terms)
            m <- model.frame(Terms, newdata, na.action = na.action, 
                             xlev = object$xlevels)
            if (!is.null(cl <- attr(Terms, "dataClasses"))) 
                .checkMFClasses(cl, m)
            keep <- match(row.names(m), rn)
            newdata <- model.matrix(Terms, m, contrasts = object$contrasts)
            xint <- match("(Intercept)", colnames(newdata), 
                          nomatch = 0)
            if (xint > 0) 
                newdata <- newdata[, -xint, drop = FALSE]
        }
    }
    else if (object$control$method != "oob") {
        if (!is.null(object$trainingData)) {
            if (object$method == "pam") {
                newdata <- object$finalModel$xData
            }
            else {
                newdata <- object$trainingData
                newdata$.outcome <- NULL
                if ("train.formula" %in% class(object) && 
                    any(unlist(lapply(newdata, is.factor)))) {
                    newdata <- model.matrix(~., data = newdata)[, 
                                                                -1]
                    newdata <- as.data.frame(newdata)
                }
            }
        }
        else stop("please specify data via newdata")
    } else
        stop("please specify data data via newdata")
    if ("xNames" %in% names(object$finalModel) & is.null(object$preProcess$method$pca) & 
        is.null(object$preProcess$method$ica)) 
        newdata <- newdata[, colnames(newdata) %in% object$finalModel$xNames, 
                           drop = FALSE]
    if(!is.null(object$preProcess))
       newdata <- predict(preProc, newdata)
    if(!is.data.frame(newdata) && 
      !is.null(object$modelInfo$predict) && 
      any(grepl("as.data.frame", as.character(body(object$modelInfo$predict)))))
           newdata <- as.data.frame(newdata)
    newdata
}