R/residuals.rpart.R

In henckr/distRforest: Distribution-based Random Forest

residuals.rpart <-
    function(object, type = c("usual", "pearson", "deviance"), ...)
{
    if (!inherits(object, "rpart"))
        stop("Not a legitimate \"rpart\" object")

    y <- object$y
    if (is.null(y)) y <- model.extract(model.frame(object), "response")
    frame <- object$frame
    type <- match.arg(type)
    if (is.na(match(type, c("usual", "pearson", "deviance"))))
        stop("Invalid type of residual")

    resid <- if (object$method == "class") {
	ylevels <- attr(object, "ylevels")
	nclass <- length(ylevels)

        if (type == "usual") {
            yhat <- frame$yval[object$where]
            loss <- object$parms$loss
        } else {
	    yprob <- frame$yval2[object$where, 1L + nclass + 1L:nclass]
	    yhat <- yprob[cbind(seq(y), unclass(y))]
        }
        switch(type,
               usual = loss[cbind(y, yhat)],
               pearson = (1 - yhat)/yhat,
               deviance = -2 * log(yhat))
    } else if (object$method == "poisson" || object$method == "exp") {
	lambda <- (object$frame$yval)[object$where]
	time <- y[, 1L]               # observation time in new data
	events <- y[, 2L]               # number of events, in new data
	expect <- lambda * time         # expected number of events
	temp <- ifelse(expect == 0, 0.0001, 0) # failsafe for log(0)

	switch(type,
               usual = events - expect,
               pearson = (events - expect)/sqrt(temp),
               deviance = sign(events- expect) *
                   sqrt(2 * (events * log(events/temp) - (events - expect)))
               )
    } else
        y - frame$yval[object$where]

    names(resid) <- names(y)
    ## Expand out the missing values in the result
    if (!is.null(object$na.action)) naresid(object$na.action, resid) else resid
}