R/rpart.class.R

In henckr/distRforest: Distribution-based Random Forest

rpart.class <- function(y, offset, parms, wt)
{
    if (!is.null(offset)) stop("No offset allowed in classification models")

    fy <- as.factor(y)
    y <- as.integer(fy)
    numclass <- max(y[!is.na(y)])
    counts <- tapply(wt, factor(y, levels = 1:numclass), sum)
    counts <- ifelse(is.na(counts), 0, counts) # in case of an empty class

    if (missing(parms) || is.null(parms))
	parms <- list(prior = counts/sum(counts),
		      loss = matrix(rep(1, numclass^2) - diag(numclass),
                                   numclass),
		      split = 1)
    else if (is.list(parms)) {
	if (is.null(names(parms))) stop("The parms list must have names")
	temp <- pmatch(names(parms), c("prior", "loss", "split"), 0L)
	if (any(temp == 0L)) # FIXME plural?
            stop(gettextf("'parms' component not matched: %s",
                          names(parms)[temp == 0L]), domain = NA)
	names(parms) <- c("prior", "loss", "split")[temp]

	if (is.null(parms$prior)) temp <- c(counts/sum(counts))
	else {
	    temp <- parms$prior
	    if (sum(temp) != 1) stop("Priors must sum to 1")
	    if (any(temp < 0)) stop("Priors must be >= 0")
	    if (length(temp) != numclass) stop("Wrong length for priors")
        }

	if (is.null(parms$loss)) temp2 <- 1 - diag(numclass)
	else {
	    temp2 <- parms$loss
	    if (length(temp2) != numclass^2)
                stop("Wrong length for loss matrix")
	    temp2 <- matrix(temp2, ncol = numclass)
	    if (any(diag(temp2) != 0))
                stop("Loss matrix must have zero on diagonals")
	    if (any(temp2 < 0))
                stop("Loss matrix cannot have negative elements")
	    if (any(rowSums(temp2) == 0))
                stop("Loss matrix has a row of zeros")
        }

	if (is.null(parms$split)) temp3 <- 1L
        else {
            temp3 <- pmatch(parms$split, c("gini", "information"))
            if (is.null(temp3)) stop("Invalid splitting rule")
        }
	parms <- list(prior = temp, loss = matrix(temp2, numclass), split = temp3)
    }
    else stop("Parameter argument must be a list")

    list(y = y, parms = parms, numresp = numclass + 2L, counts = counts,
	 ylevels = levels(fy), numy = 1L,
	 print = function(yval, ylevel, digits) {
	     temp <- if (is.null(ylevel)) as.character(yval[, 1L])
	     else ylevel[yval[, 1L]]

	     nclass <- (ncol(yval) - 2L)/2L
	     yprob <- if (nclass < 5L)
		 format(yval[, 1L + nclass + 1L:nclass],
                        digits = digits, nsmall = digits)
	     else formatg(yval[, 1L + nclass + 1L:nclass], digits = 2L)
	     if (!is.matrix(yprob)) #this case only occurs for no split trees
                 yprob <- matrix(yprob, nrow = 1L)
             ## FIXME: improve code
	     temp <- paste0(temp, " (", yprob[, 1L])
	     for (i in 2L:ncol(yprob)) temp <- paste(temp, yprob[, i], sep = " ")
	     temp <- paste0(temp, ")")
	     temp
         },
	 summary = function(yval, dev, wt, ylevel, digits) {
	     nclass <- (ncol(yval) - 2L) /2L
	     group <- yval[, 1L]
	     counts <- yval[, 1L + (1L:nclass)]
	     yprob <- yval[, 1L + nclass + 1L:nclass]
             nodeprob <- yval[, 2L * nclass + 2L]
	     if (!is.null(ylevel)) group <- ylevel[group]

	     temp1 <- formatg(counts, format = "%5g")
	     temp2 <- formatg(yprob, format = "%5.3f")
	     if (nclass >1) {
		 temp1 <- apply(matrix(temp1, ncol = nclass), 1L,
                                paste, collapse = " ")
		 temp2 <- apply(matrix(temp2, ncol = nclass), 1L,
                                paste, collapse = " ")
             }
             dev <- dev/(wt[1L] * nodeprob)
	     paste0("  predicted class=", format(group, justify = "left"),
                    "  expected loss=", formatg(dev, digits),
                    "  P(node) =", formatg(nodeprob, digits), "\n",
                    "    class counts: ", temp1, "\n",
                    "   probabilities: ", temp2)
         },
	 text = function(yval, dev, wt, ylevel, digits, n, use.n) {
	     nclass <- (ncol(yval) - 2L)/2L
	     group <- yval[, 1L]
	     counts <- yval[, 1L+ (1L:nclass)]
	     if (!is.null(ylevel)) group <- ylevel[group]

	     temp1 <- formatg(counts, digits)
	     if (nclass > 1L)
		 temp1 <- apply(matrix(temp1, ncol = nclass), 1L,
                                paste, collapse = "/")
	     if (use.n)  paste0(format(group, justify = "left"), "\n", temp1)
             else format(group, justify = "left")
         })
}