R 包 nnet 中的函数 multinom 如何计算多项式概率权重？

Question

我知道我的标题问题的理​​论答案，这是在 here 或 this Stack Overflow 上的上一个问题中讨论的。我的问题是，即使考虑到一些数值舍入，我使用R 函数multinom 中拟合的系数计算的概率权重与直接从同一函数（通过predict(fit, newdata = dat, "probs")）获得的权重完全不同。我尝试在Java 和R 中对这些权重进行数值计算，在这两种实现中我得到了相同的结果，实际上与predict 返回的值不同。

你知道我如何发现R 函数multinom 的函数predict(..., "probs") 的实现吗？

Answer 1

我首先安装nnet 并打开nnet 功能的帮助页面。我看到该函数创建了一个nnet 对象。

我尝试predict.nnet，但没有任何反应。这意味着要么没有加载包，要么函数不存在，要么被隐藏。 methods("predict") 表明该对象实际上是隐藏的（由 * 指示）。

> methods("predict")
 [1] predict.ar*                predict.Arima*             predict.arima0*            predict.glm               
 [5] predict.HoltWinters*       predict.lm                 predict.loess*             predict.mlm               
 [9] predict.multinom*          predict.nls*               predict.nnet*              predict.poly              
[13] predict.ppr*               predict.prcomp*            predict.princomp*          predict.smooth.spline*    
[17] predict.smooth.spline.fit* predict.StructTS*    

显式调用此函数会显示其代码。

> nnet:::predict.nnet
function (object, newdata, type = c("raw", "class"), ...) 
{
    if (!inherits(object, "nnet")) 
        stop("object not of class \"nnet\"")
    type <- match.arg(type)
    if (missing(newdata)) 
        z <- fitted(object)
    else {
        if (inherits(object, "nnet.formula")) {
            newdata <- as.data.frame(newdata)
            rn <- row.names(newdata)
            Terms <- delete.response(object$terms)
            m <- model.frame(Terms, newdata, na.action = na.omit, 
                xlev = object$xlevels)
            if (!is.null(cl <- attr(Terms, "dataClasses"))) 
                .checkMFClasses(cl, m)
            keep <- match(row.names(m), rn)
            x <- model.matrix(Terms, m, contrasts = object$contrasts)
            xint <- match("(Intercept)", colnames(x), nomatch = 0L)
            if (xint > 0L) 
                x <- x[, -xint, drop = FALSE]
        }
        else {
            if (is.null(dim(newdata))) 
                dim(newdata) <- c(1L, length(newdata))
            x <- as.matrix(newdata)
            if (any(is.na(x))) 
                stop("missing values in 'x'")
            keep <- 1L:nrow(x)
            rn <- rownames(x)
        }
        ntr <- nrow(x)
        nout <- object$n[3L]
        .C(VR_set_net, as.integer(object$n), as.integer(object$nconn), 
            as.integer(object$conn), rep(0, length(object$wts)), 
            as.integer(object$nsunits), as.integer(0L), as.integer(object$softmax), 
            as.integer(object$censored))
        z <- matrix(NA, nrow(newdata), nout, dimnames = list(rn, 
            dimnames(object$fitted.values)[[2L]]))
        z[keep, ] <- matrix(.C(VR_nntest, as.integer(ntr), as.double(x), 
            tclass = double(ntr * nout), as.double(object$wts))$tclass, 
            ntr, nout)
        .C(VR_unset_net)
    }
    switch(type, raw = z, class = {
        if (is.null(object$lev)) stop("inappropriate fit for class")
        if (ncol(z) > 1L) object$lev[max.col(z)] else object$lev[1L + 
            (z > 0.5)]
    })
}
<bytecode: 0x0000000009305fd8>
<environment: namespace:nnet>