從 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
}