R/CART.r
In AndriSignorell/ModTools: Building Regression and Classification Models
Defines functions
print.node
plot.CP
print.CP
CP
plot.LeafRates
print.LeafRates
LeafRates
Splits
BestTree
Snip
Desc.rpart
print.Rules
Rules
.myStripStyle
Documented in
CP
LeafRates
plot.CP
plot.LeafRates
print.CP
Rules
Splits
# ****************************************************************************
#
# Projekt: ModTools
#
# Zweck: some CART stuff, routines for handling rparts
#
# Autor: partly by B. Compton, compiled and extended by Andri Signorell
#
# ****************************************************************************
# plot.rpart <- function (x, uniform = FALSE, branch = 1, compress = FALSE, nspace,
# margin = 0, minbranch = 0.3, ...) {
# rpart.plot(x=x, uniform = uniform, branch = branch, compress = compress, nspace = nspace,
# margin =margin, minbranch = minbranch, ...)
# }
#
# plot.rpart <- function (x = stop("no 'x' arg"), type = 0, extra = 0, under = FALSE,
# clip.right.labs = TRUE, fallen.leaves = FALSE, branch = if (fallen.leaves) 1 else 0.2,
# uniform = TRUE, digits = 2, varlen = -8, faclen = 3, cex = NULL,
# tweak = 1, compress = TRUE, ycompress = uniform, snip = FALSE,
# ...){
# rpart.plot (x , type , extra , under ,
# clip.right.labs , fallen.leaves , branch ,
# uniform , digits , varlen , faclen , cex,
# tweak , compress , ycompress , snip,
# ...)
# }
#
.myStripStyle <- function(which.panel, factor.levels, ...) {
panel.rect(0, -0.5, 1, 1,
col = "grey",
border = 1)
panel.text(x = 0.5, y = 0.25,
font=2,
lab = gettextf("%s", factor.levels[which.panel]),
col = "black")
}
# Rules ------------------
Rules <- function(x, node=NULL, leafonly = FALSE) {
if (!inherits(x, "rpart")) stop("Not a legitimate rpart tree")
#
# Get some information.
#
if(is.null(node))
node <- rownames(x$frame)
else
node <- as.character(node)
frm <- x$frame[node, ]
if(leafonly)
# the leafs
frm <- frm[frm$var == "<leaf>", ]
names <- row.names(frm)
ylevels <- attr(x, "ylevels")
ds.size <- x$frame[1,]$n
if(nrow(frm) > 0)
structure(list(
frame=frm,
ylevels=ylevels,
ds.size=ds.size,
path=rpart::path.rpart(x, nodes=as.numeric(row.names(frm)), print.it=FALSE)),
class="Rules")
else
NA
}
print.Rules <- function(x, ...){
# Print each leaf node as a rule.
for (i in 1:nrow(x$frame)) {
cat("\n")
cat(sprintf(" Rule number: %s ", rownames(x$frame)[i]))
if (x$frame[i, 1] == "<leaf>") {
cat(sprintf("[yval=%s cover=%d (%.0f%%) prob=%0.2f]",
x$ylevels[x$frame[i,]$yval], x$frame[i,]$n,
round(100 * x$frame[i,]$n / x$ds.size), x$frame[i,]$yval2[,5]))
}
cat("\n")
cat(sprintf(" %s\n", x$path[[i]][-1]), sep="")
}
cat("\n")
}
# TreeDepth ------------------
TreeDepth <- function (nodes) {
depth <- floor(log(nodes, base = 2) + 1e-7)
as.vector(depth - min(depth))
}
# Desc.rpart ------------------
Desc.rpart <- function(x, nodes = NULL, cp = 0, digits = getOption("digits"), ...) {
# SCCS @(#)summary.rpart.s 1.18 07/05/01
# adapted for single node summary: 22.12.2009 / Andri Signorell
# purpose: prints the summary for single nodes, where nodes is the node id
# then rest remains original code
# example: node.summary( r.rpart, nodes=c(32) )
object <- x
if(!inherits(object, "rpart")) stop("Not legitimate rpart object")
# If this is an older-style rpart object, convert it
# either way, rename it to "x" to save typing
# if (!is.null(object$frame$splits)) x <- rpconvert(object)
# else x <- object
# get rid of old hats
x <- object
# omit <- x$na.action
# n <- x$frame$n
# if (length(omit))
# cat(" n=", n[1], " (", naprint(omit), ")\n\n", sep="")
# else cat(" n=", n[1], "\n\n")
# print(x$cptable, digits=digits)
ff <- x$frame
ylevel <- attr(x,'ylevels')
id <- as.integer(row.names(ff))
parent.id <- ifelse(id==1,1, floor(id/2))
parent.cp <- ff$complexity[match(parent.id, id)]
rows <- (1:length(id))[parent.cp > cp]
if (length(rows)>0) rows <- rows[order(id[rows])]
else rows <- 1
is.leaf <- (ff$var=='<leaf>')
index <- cumsum(c(1, ff$ncompete + ff$nsurrogate + 1*(!is.leaf)))
if(!all(is.leaf)) { #skip these lines for a "no splits" tree
sname <- dimnames(x$splits)[[1]]
cuts <- vector(mode='character', length=nrow(x$splits))
temp <- x$splits[ ,2]
for (i in 1:length(cuts)) {
if (temp[i] == -1)
cuts[i] <-paste("<", format(signif(x$splits[i,4], digits=digits)))
else if (temp[i] ==1)
cuts[i] <-paste("<", format(signif(x$splits[i,4], digits=digits)))
else cuts[i]<- paste("splits as ",
paste(c("L", "-", "R")[x$csplit[x$splits[i,4], 1:temp[i]]],
collapse='', sep=''), collapse='')
}
# S-PLUS 4.0 can't handle null vectors here
if(any(temp<2)) cuts[temp<2 ] <- format(cuts[temp<2],justify="left")
cuts <- paste(cuts, ifelse(temp >=2, ",",
ifelse(temp==1, " to the right,", " to the left, ")),
sep = '')
}
if (is.null(ff$yval2))
tprint <- x$functions$summary(ff$yval[rows], ff$dev[rows],
ff$wt[rows], ylevel, digits)
else
tprint <- x$functions$summary(ff$yval2[rows,,drop=TRUE], ff$dev[rows],
ff$wt[rows], ylevel, digits)
# Get the nodes
nodes.id <- match( nodes, id[rows] )
# Original: for (ii in 1:length(rows)) {
for (ii in nodes.id) {
i <- rows[ii]
nn <- ff$n[i]
cat("\nNode number ", id[i], ": ", nn, " observations", sep='')
if (ff$complexity[i] < cp || is.leaf[i]) cat("\n")
else cat(", complexity param=",
format(signif(ff$complexity[i], digits)), "\n", sep="")
cat(tprint[ii], "\n")
if (ff$complexity[i] > cp && !is.leaf[i] ){
sons <- 2*id[i] + c(0,1)
sons.n <- ff$n[match(sons, id)]
cat(" left son=", sons[1], " (", sons.n[1], " obs)",
" right son=", sons[2], " (", sons.n[2], " obs)", sep='')
j <- nn - (sons.n[1] + sons.n[2])
if (j>1) cat(", ", j, " observations remain\n", sep='')
else if (j==1) cat(", 1 observation remains\n")
else cat("\n")
cat(" Primary splits:\n")
j <- seq(index[i], length.out=1+ff$ncompete[i])
if (all(nchar(cuts[j], "w") < 25))
temp <- format(cuts[j], justify="left")
else temp <- cuts[j]
cat(paste(" ", format(sname[j], justify="left"), " ", temp,
" improve=", format(signif(x$splits[j,3], digits)),
", (", nn - x$splits[j,1], " missing)", sep=''),
sep="\n")
if (ff$nsurrogate[i] >0) {
cat(" Surrogate splits:\n")
j <- seq(1 +index[i] + ff$ncompete[i], length.out=ff$nsurrogate[i])
agree <- x$splits[j,3]
if (all(nchar(cuts[j], "w") < 25))
temp <- format(cuts[j], justify="left")
else temp <- cuts[j]
if (ncol(x$splits)==5) {
adj <- x$splits[j,5]
cat(paste(" ", format(sname[j], justify="left"), " ",
temp,
" agree=", format(round(agree, 3)),
", adj=" , format(round(adj, 3)),
", (", x$splits[j,1], " split)", sep=''),
sep="\n")
}
else { #an older style rpart object -- no adj value present
cat(paste(" ", format(sname[j], justify="left"), " ",
temp,
" agree=", format(round(agree, 3)),
", (", x$splits[j,1], " split)", sep=''),
sep="\n")
}
}
}
}
cat("\n")
invisible(x)
}
###
# Snip for rpart.plot -------
Snip <- function(...){
plot(..., snip=TRUE)
}
# Flop --------------
"Flop" <- function(x, n = 1, m = 1) {
# flop.rpart(rpart object)
# Flop branches of rpart object x such that splits are always > (or :), never <
# B. Compton, 2 March 2003
#return(x)
if(n == 1) {
y <- x
x <- x$frame
}
i <- x[as.numeric(row.names(x)) == n, ]
row.names(i) <- as.character(m)
if(i[1] == "<leaf>")
i
else {
q <- c(2 * n, 2 * n + 1) # Existing node #s
r <- c(2 * m, 2 * m + 1) # New node #s
print(i$splits)
if("<" == substring(i$splits[1], 1, 1)) {
i$splits[1] <- paste(">", substring(i$splits[1], 2),
sep = "")
i$splits[2] <- paste("<", substring(i$splits[2], 2),
sep = "")
q <- rev(q)
}
z <- rbind(Flop(x, q[1], r[1]), Flop(x, q[2], r[2])
)
z <- rbind(i, z) # if within recursion, return new node
if(n != 1)
z
else {
y$frame <- z
y
}
}
}
# BestTree --------------
BestTree <- function(x) {
# pick.tree
# Pick best tree from rpart object using 1 SE rule
# Returns number of leaves in global leaves
# B. Compton, 12 May 2004, 21 May 2004
# example: BestTree(r.glass)
i <- x$cptable[,4] <= min(x$cptable[,4] + x$cptable[,5])
list( leaves = 1 + as.numeric(x$cptable[,2][i][1]),
cp = as.numeric(x$cptable[,1][i][1] + .000001) # Add a little for rounding errors
)
}
# Splits --------------
Splits <- function(x) {
# original: splits.rpart
# B. Compton, 19 Apr 2004
# Gives results from old z$frame$splits
# example: Splits(r.glass)
x <- labels(x, collapse = FALSE)
x[a <- apply(x, 2, "==", "<leaf>")] <- ""
a <- (!a) & apply(x, 2, substring, 1, 1) != "<" & apply(x, 2, substring, 1, 1) != ">"
x[a] <- paste(":", x[a], sep="")
x[!a] <- paste( apply(x, 2, substr, 1, 1),apply(x, 2, substring, 3, last=100), sep="")[!a]
colnames(x) <- c("cutleft", "cutright")
x
}
# LeafRates and LeafHist --------------
#
# # Purity ------------------
# Purity <- function(x, leaves=TRUE) {
#
# if(x$method != "anova"){
# # returns the purity of all nodes
#
# n <- ( ncol(x$frame$yval2) - 2 ) / 2
# xp <- diag(apply(x$frame$yval2[,-c(1:(n+1))], 1, "[", x$frame$yval))
#
#
# freq <- data.frame(node=row.names(x$frame), x$frame$yval2[, 2:(1+length(attr(x, "ylevels")))])
# colnames(freq)[-1] <- attr(x, "ylevels")
#
# # res <- data.frame(node=rownames(x$frame), purity=xp)
# names(xp) <- rownames(x$frame)
#
# if(leaves){
# xp <- xp[x$frame$var=="<leaf>"]
# freq <- freq[x$frame$var=="<leaf>",]
# }
#
# res <- list(purity=xp, freq=freq)
#
# class(res) <- c("Purity", class(res))
# return(res)
#
# } else {
# return(NA)
# }
# }
# Columns of frame include the node, a factor giving the names of the variables used in
# the split at each node (leaf nodes are denoted by the level "<leaf>"), n, the number
# of observations reaching the node, wt, the sum of case weights for observations
# reaching the node, dev, the deviance of the node, yval, the fitted value of the
# response at the node, and splits, a two column matrix of left and right split labels
# for each node. Also included in the frame are complexity, the complexity parameter
# at which this split will collapse, ncompete, the number of competitor splits recorded,
# and nsurrogate, the number of surrogate splits recorded.
LeafRates <- function(x) {
# original name: rates.rpart
# Get misclassification rates for rpart object in all end nodes
# B. Compton, 13 May 2004
# Rewritten, 16 Nov 2004
# Modified for root trees, 15 Dec 2004
if(x$method == "anova"){
warning("Leafrates can't be returned for regression trees.")
return(NA)
}
xx <- x$frame$yval2[x$frame$var == "<leaf>",]
if(is.matrix(xx)) {
z <- matrix(0,dim(xx)[1], 2)
for(i in 1:dim(xx)[1])
z[i,1] <- xx[i,xx[i,1]+1]
z[,2] <- rowSums(xx[,2:((dim(xx)[2]-1)/2+1)]) - z[,1]
}
else z <- matrix(xx[c(3,2)],1,2)
colnames(z) <- c('right', 'wrong')
rownames(z) <- rownames(x$frame[x$frame$var == "<leaf>",])
structure(
list(node=rownames(z),
freq=z,
p.row=prop.table(z, 1),
mfreq=apply(z, 1, sum),
mperc=prop.table(apply(z, 1, sum))
),
class=c("LeafRates","list"))
}
print.LeafRates <- function(x, ...){
z <- rbind(c("","freq","","perc","","total",""),
c("node","right","wrong","right","wrong","abs","perc"),
"",
cbind(x$node,
Format(x$freq, fmt="abs"),
Format(x$p.row, fmt="%", digits=1),
Format(x$mfreq, fmt="abs"),
Format(x$mperc, fmt="%")))
write.table(format(z, justify="left"), sep = " ",
row.names=FALSE, col.names=FALSE, quote=FALSE)
}
plot.LeafRates <- function(x, col=NULL, which=c("rel","abs"),
layout=NULL, ylim=NULL, ...){
# m <- x$frame$yval2[,-1]
# m <- m[,1:((ncol(m)-1)/2)]
# rownames(m) <- rownames(x$frame)
# m.leaves <- m[x$frame$var == "<leaf>",]
#
# m.leaves <- x
# if(type=="rel") m.leaves <- prop.table(m.leaves, 1)
# d.leaves <- data.frame(frq=as.vector(t(m.leaves)),
# leaf=factor(rep(rownames(m.leaves), each=length(attr(x, "ylevels"))),
# levels=rep(rownames(m.leaves))),
# class=rep(attr(x, "ylevels"), times=nrow(m.leaves))
# )
if(is.null(col))
col <- c(DescTools::hblue, DescTools::hred)
which <- match.arg(which)
if(which=="rel"){
if(is.null(ylim))
ylim = c(0, 1.1)
ylab = "relative freq."
} else {
ylab = "frequency"
}
d.leaves <- data.frame(frq=c(x$freq[,1], x$freq[,2]),
leaf=rep(row.names(x$freq), times=2),
# class=rep(colnames(x$freq), each=nrow(x$freq)), stringsAsFactors = FALSE)
class=factor(rep(c("T","F"), each=nrow(x$freq)), levels=c("T","F")), stringsAsFactors = FALSE)
idx <- d.leaves$leaf[1:nrow(x$freq)]
if(which=="rel")
d.leaves$frq <- c(x$p.row[,1], x$p.row[,2])
if(is.null(layout))
layout <- c(nrow(x$freq), 1)
# what a zangengeburt.... node order as in the original result
id <- order(as.numeric(Sort(cbind(nod=rownames(x$freq),
nr=1:nrow(x$freq)))[,2]))
barchart( frq ~ class|leaf, data=d.leaves,
stack=FALSE, horiz=FALSE, layout=layout, ylab=ylab, xlab="classes",
ylim=ylim, index.cond=list(id),
panel = function(y, x, ...){
cols <- rep(col, length(y))
cols[which.max(y)] <- col[1]
panel.barchart(x, y,..., col=cols, origin=0, box.width=0.85)
},
strip=.myStripStyle
)
}
# Complexity parameter
CP <- function(x, ...){
structure(list(cp=x$cptable,
mincp=x$cptable[which.min(x$cptable[,"xerror"]), "CP"],
x=x), class=c("CP"))
}
print.CP <- function(x, digits = getOption("digits") - 2L, ...){
rpart::printcp(x$x, digits=digits, ...)
cat("\n")
}
plot.CP <- function(x, minline = TRUE, lty = 3,
col = 1, upper = c("size", "splits", "none"), ...){
rpart::plotcp(x$x, minline, lty, col, upper=upper, ...)
}
# plot.rpart ------------------
# we override the native rpart plot and use rpart.plot here
plot.rpart <- function (x = stop("no 'x' arg"), type = 2, extra = "auto",
under = FALSE, fallen.leaves = TRUE, digits = 2, varlen = 0,
faclen = 0, roundint = TRUE, cex = NULL, tweak = 1, clip.facs = FALSE,
clip.right.labs = TRUE, snip = FALSE, box.palette = "auto",
shadow.col = 0, node.labels=TRUE, ...) {
if(identical(box.palette, "auto"))
box.palette <- as.list(ColToOpaque(SetAlpha(Pal("Helsana"))))
b <- rpart.plot(x =x, type = type, extra = extra,
under = under, fallen.leaves = fallen.leaves, digits = digits, varlen = varlen,
faclen = faclen, roundint = roundint, cex = cex, tweak = tweak,
clip.facs = clip.facs,
clip.right.labs = clip.right.labs, snip = snip, box.palette = box.palette ,
shadow.col = shadow.col, ...)
if(node.labels){
oldpar <- par(xpd=TRUE)
on.exit(par(oldpar))
BoxedText(x = b$boxes$x1, y=b$boxes$y2, labels = rownames(x$frame),
border=NA, txt.col = "steelblue", font=2, col=SetAlpha("white", 0.7), cex=0.8)
}
invisible(b)
}
.predict.rpart <- function (object, newdata, type = c("vector", "prob", "class",
"matrix", "where", "leaf"), na.action = na.pass, ...){
type <- match.arg(type)
if(type %in% c("where","leaf"))
.predict.leaves(object, newdata, type = type)
else {
class(object) <- class(object)[class(object) != "FitMod"]
predict(object, newdata, type, na.action, ...)
}
}
.predict.leaves <- function (rp, newdata, type = "where") {
if (type == "where") {
rp$frame$yval <- 1:nrow(rp$frame)
should.be.leaves <- which(rp$frame[, 1] == "<leaf>")
}
else if (type == "leaf") {
rp$frame$yval <- rownames(rp$frame)
should.be.leaves <- rownames(rp$frame)[rp$frame[, 1] ==
"<leaf>"]
}
else stop("Type must be 'where' or 'leaf'")
leaves <- predict(rp, newdata = newdata, type = "vector")
should.be.leaves <- which(rp$frame[, 1] == "<leaf>")
bad.leaves <- leaves[!is.element(leaves, should.be.leaves)]
if (length(bad.leaves) == 0)
return(leaves)
u.bad.leaves <- unique(bad.leaves)
u.bad.nodes <- row.names(rp$frame)[u.bad.leaves]
all.nodes <- row.names(rp$frame)[rp$frame[, 1] == "<leaf>"]
is.descendant <- function(all.leaves, node) {
if (length(all.leaves) == 0)
return(logical(0))
all.leaves <- as.numeric(all.leaves)
node <- as.numeric(node)
if (missing(node))
return(NA)
result <- rep(FALSE, length(all.leaves))
for (i in 1:length(all.leaves)) {
LEAF <- all.leaves[i]
while (LEAF > node) {
LEAF <- trunc(LEAF/2)
if (LEAF == node)
result[i] <- TRUE
break
}
}
return(result)
}
where.tbl <- table(rp$where)
names(where.tbl) <- row.names(rp$frame)[as.numeric(names(where.tbl))]
for (u in 1:length(u.bad.nodes)) {
desc.vec <- is.descendant(all.nodes, u.bad.nodes[u])
me <- where.tbl[all.nodes][desc.vec]
winner <- names(me)[me == max(me)][1]
leaves[leaves == u.bad.leaves[u]] <- which(row.names(rp$frame) ==
winner)
}
return(leaves)
}
Node <- function (x, node=NULL, type=c("all", "split", "leaf"), digits=3) {
if (!inherits(x, "rpart"))
stop("Not a legitimate \"rpart\" object")
ff <- x$frame
ylevel <- attr(x, "ylevels")
id <- as.integer(row.names(ff))
parent.id <- ifelse(id == 1L, 1L, id%/%2L)
rows <- seq_along(id)
is.leaf <- ff$var == "<leaf>"
index <- cumsum(c(1L, ff$ncompete + ff$nsurrogate + !is.leaf))
if (!all(is.leaf)) {
sname <- rownames(x$splits)
cuts <- character(nrow(x$splits))
temp <- x$splits[, 2L]
for (i in seq_along(cuts)) {
cuts[i] <- if (temp[i] == -1L)
paste("<", format(signif(x$splits[i, 4L], digits)))
else if (temp[i] == 1L)
paste("<", format(signif(x$splits[i, 4L], digits)))
else paste("splits as ", paste(c("L", "-", "R")[x$csplit[x$splits[i, 4L], 1:temp[i]]],
collapse = "", sep = ""), collapse = "")
}
if (any(temp < 2L))
cuts[temp < 2L] <- format(cuts[temp < 2L], justify = "left")
cuts <- paste0(cuts, ifelse(temp >= 2L, ",", ifelse(temp == 1L, " to the right,", " to the left, ")))
}
tmp <- if (is.null(ff$yval2))
ff$yval[rows]
else
ff$yval2[rows, , drop = FALSE]
tmp <- unname(tmp)
tprint <- x$functions$summary(tmp, ff$dev[rows], ff$wt[rows], ylevel, digits)
nclass <- (ncol(tmp) - 2L)/2L
nlst <- list()
if(is.null(node))
nid <- seq_along(rows)
else
nid <- seq_along(rows)[which(!is.na(rows[match(row.names(ff), node)]))]
for (ii in nid) {
i <- rows[ii]
nlbl <- as.character(id[i])
nlst[[nlbl]] <- SetNames(list(), names=nlbl)
nn <- ff$n[i]
nlst[[nlbl]]$id <- id[i]
nlst[[nlbl]]$vname <- as.character(ff$var[i])
nlst[[nlbl]]$isleaf <- is.leaf[i]
nlst[[nlbl]]$nobs <- nn
nlst[[nlbl]]$group <- ylevel[tmp[i, 1L]]
nlst[[nlbl]]$ycount <- tmp[i, 1L + (1L:nclass)]
nlst[[nlbl]]$yprob <- tmp[i, 1L + nclass + 1L:nclass]
nlst[[nlbl]]$nodeprob <- tmp[i, 2L * nclass + 2L]
nlst[[nlbl]]$complexity <- ff$complexity[i]
nlst[[nlbl]]$tprint <- tprint[ii]
if (!is.leaf[i]) {
sons <- 2L * id[i] + c(0L, 1L)
sons_n <- ff$n[match(sons, id)]
nlst[[nlbl]]$sons <- SetNames(sons, names=c("left", "right"))
nlst[[nlbl]]$sons_n <- SetNames(sons_n, names=c("left", "right"))
## what's that??
# j <- nn - (sons.n[1L] + sons.n[2L])
# if (j > 1L)
# cat(", ", j, " observations remain\n",
# sep = "")
# else if (j == 1L)
# cat(", 1 observation remains\n")
# else cat("\n")
# primary splits
j <- seq(index[i], length.out = 1L + ff$ncompete[i])
temp <- if (all(nchar(cuts[j], "w") < 25L))
format(cuts[j], justify = "left")
else
cuts[j]
nlst[[nlbl]]$primarysplits <- data.frame(split=sname[j], direction=temp, improve=x$splits[j, 3L], missing= nn - x$splits[j, 1L])
# surrogate splits
if (ff$nsurrogate[i] > 0L) {
j <- seq(1L + index[i] + ff$ncompete[i], length.out = ff$nsurrogate[i])
agree <- x$splits[j, 3L]
temp <- if (all(nchar(cuts[j], "w") < 25L))
format(cuts[j], justify = "left")
else cuts[j]
adj <- x$splits[j, 5L]
nlst[[nlbl]]$surrogatesplits <- data.frame(split=sname[j], direction=temp,
agree=agree, adj=adj, split=x$splits[j, 1L])
}
}
}
type <- match.arg(type)
if(type=="leaf")
nlst <- nlst[sapply(nlst, "[[", "isleaf")]
if(type=="split")
nlst <- nlst[!sapply(nlst, "[[", "isleaf")]
return(structure(nlst, class="node"))
}
print.node <- function(x, digits=3, ...){
if(length(x)==0)
cat("list()\n")
else {
for(i in seq_along(x)) {
cat("\nNode number ", x[[i]]$id, ": ", x[[i]]$nobs, " observations", sep = "")
if (x[[i]]$isleaf)
cat("\n")
else
cat(", complexity param=", format(signif(x[[i]]$complexity, digits)), "\n", sep = "")
cat(x[[i]]$tprint, "\n")
if(!x[[i]]$isleaf){
cat(" left son=", x[[i]]$sons[1L], " (", x[[i]]$sons_n[1L],
" obs)", " right son=", x[[i]]$sons[2L],
" (", x[[i]]$sons_n[2L], " obs)", sep = "")
cat("\n Primary splits:\n")
for(lx in split(x[[i]][["primarysplits"]],
f = 1:nrow(x[[i]][["primarysplits"]]))) {
cat(paste(" ", format(lx$split, justify = "left"),
" ", lx$direction, " improve=", format(signif(lx$improve, digits)),
", (",
lx$missing, " missing)", sep = ""), sep = "\n")
}
if(!is.null(x[[i]]$surrogatesplits)){
cat(" Surrogate splits:\n")
for(lx in split(x[[i]][["surrogatesplits"]],
f = 1:nrow(x[[i]][["surrogatesplits"]]))) {
cat(paste(" ", format(lx$split, justify = "left"),
" ", lx$direction, " agree=", format(round(lx$agree, 3L)),
", adj=", format(round(lx$adj, 3L)),
", (", lx$split.1, " split)",
sep = ""), sep = "\n")
}
}
}
cat("\n")
}
}
}
#' #' @importFrom flipU OutcomeName
#' #' @importFrom stats formula
#' rPartToTreeFrame <- function(obj)
#' {
#' frame <- obj$frame
#' n.nodes <- nrow(frame)
#' splits <- matrix("", n.nodes, 2)
#' nms <- colnames(obj$splits)
#' index.i <- nms == "index"
#' ncat.i <- nms == "ncat"
#' c <- 1
#' for (i in 1:n.nodes)
#' {
#' var.name <- as.character(frame$var[i])
#' if (var.name != "<leaf>")
#' {
#' if (is.factor(obj$model[[var.name]]))
#' {
#' n.levels <- length(attr(obj, "xlevels")[[var.name]])
#' extended.letters <- extendLetters(n.levels)
#' lttrs <- extended.letters[1:n.levels]
#' levels.split <- obj$csplit[obj$splits[c, index.i], ]
#' splits[i, 1] <- paste0(":", paste(lttrs[levels.split == 1], collapse = ""))
#' splits[i, 2] <- paste0(":", paste(lttrs[levels.split == 3], collapse = ""))
#' }
#' else
#' {
#' break.val <- obj$splits[c, index.i]
#' if (obj$splits[c, ncat.i] < 0)
#' {
#' splits[i, 1] <- paste0("<", break.val)
#' splits[i, 2] <- paste0(">=", break.val)
#' }
#' else
#' {
#' splits[i, 1] <- paste0(">=", break.val)
#' splits[i, 2] <- paste0("<", break.val)
#' }
#' }
#' c <- c + frame$ncompete[i] + frame$nsurrogate[i] + 1
#' }
#' }
#' frame$splits <- splits
#'
#' outcome.var <- obj$model[[OutcomeName(formula(obj$terms))]]
#'
#' if (is.factor(outcome.var))
#' frame$yval <- levels(outcome.var)[frame$yval]
#'
#' if (!is.null(frame$yval2))
#' {
#' fitted.levels <- levels(droplevels(outcome.var[obj$subset]))
#' all.levels <- levels(outcome.var)
#' n.levels <- length(fitted.levels)
#' yprob <- frame$yval2[, (n.levels + 2):(2 * n.levels + 1)]
#' empty.levels <- all.levels[!all.levels %in% fitted.levels]
#' yprob <- cbind(yprob, matrix(0, nrow = nrow(yprob), ncol = length(empty.levels)))
#' colnames(yprob) <- c(fitted.levels, empty.levels)
#' frame$yprob <- yprob
#' }
#' frame
#' }
AndriSignorell/ModTools documentation built on Jan. 17, 2025, 12:37 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions print.node plot.CP print.CP CP plot.LeafRates print.LeafRates LeafRates Splits BestTree Snip Desc.rpart print.Rules Rules .myStripStyle
Documented in CP LeafRates plot.CP plot.LeafRates print.CP Rules Splits
# ****************************************************************************
#
# Projekt: ModTools
#
# Zweck: some CART stuff, routines for handling rparts
#
# Autor: partly by B. Compton, compiled and extended by Andri Signorell
#
# ****************************************************************************
# plot.rpart <- function (x, uniform = FALSE, branch = 1, compress = FALSE, nspace,
# margin = 0, minbranch = 0.3, ...) {
# rpart.plot(x=x, uniform = uniform, branch = branch, compress = compress, nspace = nspace,
# margin =margin, minbranch = minbranch, ...)
# }
#
# plot.rpart <- function (x = stop("no 'x' arg"), type = 0, extra = 0, under = FALSE,
# clip.right.labs = TRUE, fallen.leaves = FALSE, branch = if (fallen.leaves) 1 else 0.2,
# uniform = TRUE, digits = 2, varlen = -8, faclen = 3, cex = NULL,
# tweak = 1, compress = TRUE, ycompress = uniform, snip = FALSE,
# ...){
# rpart.plot (x , type , extra , under ,
# clip.right.labs , fallen.leaves , branch ,
# uniform , digits , varlen , faclen , cex,
# tweak , compress , ycompress , snip,
# ...)
# }
#
.myStripStyle <- function(which.panel, factor.levels, ...) {
panel.rect(0, -0.5, 1, 1,
col = "grey",
border = 1)
panel.text(x = 0.5, y = 0.25,
font=2,
lab = gettextf("%s", factor.levels[which.panel]),
col = "black")
}
# Rules ------------------
Rules <- function(x, node=NULL, leafonly = FALSE) {
if (!inherits(x, "rpart")) stop("Not a legitimate rpart tree")
#
# Get some information.
#
if(is.null(node))
node <- rownames(x$frame)
else
node <- as.character(node)
frm <- x$frame[node, ]
if(leafonly)
# the leafs
frm <- frm[frm$var == "<leaf>", ]
names <- row.names(frm)
ylevels <- attr(x, "ylevels")
ds.size <- x$frame[1,]$n
if(nrow(frm) > 0)
structure(list(
frame=frm,
ylevels=ylevels,
ds.size=ds.size,
path=rpart::path.rpart(x, nodes=as.numeric(row.names(frm)), print.it=FALSE)),
class="Rules")
else
NA
}
print.Rules <- function(x, ...){
# Print each leaf node as a rule.
for (i in 1:nrow(x$frame)) {
cat("\n")
cat(sprintf(" Rule number: %s ", rownames(x$frame)[i]))
if (x$frame[i, 1] == "<leaf>") {
cat(sprintf("[yval=%s cover=%d (%.0f%%) prob=%0.2f]",
x$ylevels[x$frame[i,]$yval], x$frame[i,]$n,
round(100 * x$frame[i,]$n / x$ds.size), x$frame[i,]$yval2[,5]))
}
cat("\n")
cat(sprintf(" %s\n", x$path[[i]][-1]), sep="")
}
cat("\n")
}
# TreeDepth ------------------
TreeDepth <- function (nodes) {
depth <- floor(log(nodes, base = 2) + 1e-7)
as.vector(depth - min(depth))
}
# Desc.rpart ------------------
Desc.rpart <- function(x, nodes = NULL, cp = 0, digits = getOption("digits"), ...) {
# SCCS @(#)summary.rpart.s 1.18 07/05/01
# adapted for single node summary: 22.12.2009 / Andri Signorell
# purpose: prints the summary for single nodes, where nodes is the node id
# then rest remains original code
# example: node.summary( r.rpart, nodes=c(32) )
object <- x
if(!inherits(object, "rpart")) stop("Not legitimate rpart object")
# If this is an older-style rpart object, convert it
# either way, rename it to "x" to save typing
# if (!is.null(object$frame$splits)) x <- rpconvert(object)
# else x <- object
# get rid of old hats
x <- object
# omit <- x$na.action
# n <- x$frame$n
# if (length(omit))
# cat(" n=", n[1], " (", naprint(omit), ")\n\n", sep="")
# else cat(" n=", n[1], "\n\n")
# print(x$cptable, digits=digits)
ff <- x$frame
ylevel <- attr(x,'ylevels')
id <- as.integer(row.names(ff))
parent.id <- ifelse(id==1,1, floor(id/2))
parent.cp <- ff$complexity[match(parent.id, id)]
rows <- (1:length(id))[parent.cp > cp]
if (length(rows)>0) rows <- rows[order(id[rows])]
else rows <- 1
is.leaf <- (ff$var=='<leaf>')
index <- cumsum(c(1, ff$ncompete + ff$nsurrogate + 1*(!is.leaf)))
if(!all(is.leaf)) { #skip these lines for a "no splits" tree
sname <- dimnames(x$splits)[[1]]
cuts <- vector(mode='character', length=nrow(x$splits))
temp <- x$splits[ ,2]
for (i in 1:length(cuts)) {
if (temp[i] == -1)
cuts[i] <-paste("<", format(signif(x$splits[i,4], digits=digits)))
else if (temp[i] ==1)
cuts[i] <-paste("<", format(signif(x$splits[i,4], digits=digits)))
else cuts[i]<- paste("splits as ",
paste(c("L", "-", "R")[x$csplit[x$splits[i,4], 1:temp[i]]],
collapse='', sep=''), collapse='')
}
# S-PLUS 4.0 can't handle null vectors here
if(any(temp<2)) cuts[temp<2 ] <- format(cuts[temp<2],justify="left")
cuts <- paste(cuts, ifelse(temp >=2, ",",
ifelse(temp==1, " to the right,", " to the left, ")),
sep = '')
}
if (is.null(ff$yval2))
tprint <- x$functions$summary(ff$yval[rows], ff$dev[rows],
ff$wt[rows], ylevel, digits)
else
tprint <- x$functions$summary(ff$yval2[rows,,drop=TRUE], ff$dev[rows],
ff$wt[rows], ylevel, digits)
# Get the nodes
nodes.id <- match( nodes, id[rows] )
# Original: for (ii in 1:length(rows)) {
for (ii in nodes.id) {
i <- rows[ii]
nn <- ff$n[i]
cat("\nNode number ", id[i], ": ", nn, " observations", sep='')
if (ff$complexity[i] < cp || is.leaf[i]) cat("\n")
else cat(", complexity param=",
format(signif(ff$complexity[i], digits)), "\n", sep="")
cat(tprint[ii], "\n")
if (ff$complexity[i] > cp && !is.leaf[i] ){
sons <- 2*id[i] + c(0,1)
sons.n <- ff$n[match(sons, id)]
cat(" left son=", sons[1], " (", sons.n[1], " obs)",
" right son=", sons[2], " (", sons.n[2], " obs)", sep='')
j <- nn - (sons.n[1] + sons.n[2])
if (j>1) cat(", ", j, " observations remain\n", sep='')
else if (j==1) cat(", 1 observation remains\n")
else cat("\n")
cat(" Primary splits:\n")
j <- seq(index[i], length.out=1+ff$ncompete[i])
if (all(nchar(cuts[j], "w") < 25))
temp <- format(cuts[j], justify="left")
else temp <- cuts[j]
cat(paste(" ", format(sname[j], justify="left"), " ", temp,
" improve=", format(signif(x$splits[j,3], digits)),
", (", nn - x$splits[j,1], " missing)", sep=''),
sep="\n")
if (ff$nsurrogate[i] >0) {
cat(" Surrogate splits:\n")
j <- seq(1 +index[i] + ff$ncompete[i], length.out=ff$nsurrogate[i])
agree <- x$splits[j,3]
if (all(nchar(cuts[j], "w") < 25))
temp <- format(cuts[j], justify="left")
else temp <- cuts[j]
if (ncol(x$splits)==5) {
adj <- x$splits[j,5]
cat(paste(" ", format(sname[j], justify="left"), " ",
temp,
" agree=", format(round(agree, 3)),
", adj=" , format(round(adj, 3)),
", (", x$splits[j,1], " split)", sep=''),
sep="\n")
}
else { #an older style rpart object -- no adj value present
cat(paste(" ", format(sname[j], justify="left"), " ",
temp,
" agree=", format(round(agree, 3)),
", (", x$splits[j,1], " split)", sep=''),
sep="\n")
}
}
}
}
cat("\n")
invisible(x)
}
###
# Snip for rpart.plot -------
Snip <- function(...){
plot(..., snip=TRUE)
}
# Flop --------------
"Flop" <- function(x, n = 1, m = 1) {
# flop.rpart(rpart object)
# Flop branches of rpart object x such that splits are always > (or :), never <
# B. Compton, 2 March 2003
#return(x)
if(n == 1) {
y <- x
x <- x$frame
}
i <- x[as.numeric(row.names(x)) == n, ]
row.names(i) <- as.character(m)
if(i[1] == "<leaf>")
i
else {
q <- c(2 * n, 2 * n + 1) # Existing node #s
r <- c(2 * m, 2 * m + 1) # New node #s
print(i$splits)
if("<" == substring(i$splits[1], 1, 1)) {
i$splits[1] <- paste(">", substring(i$splits[1], 2),
sep = "")
i$splits[2] <- paste("<", substring(i$splits[2], 2),
sep = "")
q <- rev(q)
}
z <- rbind(Flop(x, q[1], r[1]), Flop(x, q[2], r[2])
)
z <- rbind(i, z) # if within recursion, return new node
if(n != 1)
z
else {
y$frame <- z
y
}
}
}
# BestTree --------------
BestTree <- function(x) {
# pick.tree
# Pick best tree from rpart object using 1 SE rule
# Returns number of leaves in global leaves
# B. Compton, 12 May 2004, 21 May 2004
# example: BestTree(r.glass)
i <- x$cptable[,4] <= min(x$cptable[,4] + x$cptable[,5])
list( leaves = 1 + as.numeric(x$cptable[,2][i][1]),
cp = as.numeric(x$cptable[,1][i][1] + .000001) # Add a little for rounding errors
)
}
# Splits --------------
Splits <- function(x) {
# original: splits.rpart
# B. Compton, 19 Apr 2004
# Gives results from old z$frame$splits
# example: Splits(r.glass)
x <- labels(x, collapse = FALSE)
x[a <- apply(x, 2, "==", "<leaf>")] <- ""
a <- (!a) & apply(x, 2, substring, 1, 1) != "<" & apply(x, 2, substring, 1, 1) != ">"
x[a] <- paste(":", x[a], sep="")
x[!a] <- paste( apply(x, 2, substr, 1, 1),apply(x, 2, substring, 3, last=100), sep="")[!a]
colnames(x) <- c("cutleft", "cutright")
x
}
# LeafRates and LeafHist --------------
#
# # Purity ------------------
# Purity <- function(x, leaves=TRUE) {
#
# if(x$method != "anova"){
# # returns the purity of all nodes
#
# n <- ( ncol(x$frame$yval2) - 2 ) / 2
# xp <- diag(apply(x$frame$yval2[,-c(1:(n+1))], 1, "[", x$frame$yval))
#
#
# freq <- data.frame(node=row.names(x$frame), x$frame$yval2[, 2:(1+length(attr(x, "ylevels")))])
# colnames(freq)[-1] <- attr(x, "ylevels")
#
# # res <- data.frame(node=rownames(x$frame), purity=xp)
# names(xp) <- rownames(x$frame)
#
# if(leaves){
# xp <- xp[x$frame$var=="<leaf>"]
# freq <- freq[x$frame$var=="<leaf>",]
# }
#
# res <- list(purity=xp, freq=freq)
#
# class(res) <- c("Purity", class(res))
# return(res)
#
# } else {
# return(NA)
# }
# }
# Columns of frame include the node, a factor giving the names of the variables used in
# the split at each node (leaf nodes are denoted by the level "<leaf>"), n, the number
# of observations reaching the node, wt, the sum of case weights for observations
# reaching the node, dev, the deviance of the node, yval, the fitted value of the
# response at the node, and splits, a two column matrix of left and right split labels
# for each node. Also included in the frame are complexity, the complexity parameter
# at which this split will collapse, ncompete, the number of competitor splits recorded,
# and nsurrogate, the number of surrogate splits recorded.
LeafRates <- function(x) {
# original name: rates.rpart
# Get misclassification rates for rpart object in all end nodes
# B. Compton, 13 May 2004
# Rewritten, 16 Nov 2004
# Modified for root trees, 15 Dec 2004
if(x$method == "anova"){
warning("Leafrates can't be returned for regression trees.")
return(NA)
}
xx <- x$frame$yval2[x$frame$var == "<leaf>",]
if(is.matrix(xx)) {
z <- matrix(0,dim(xx)[1], 2)
for(i in 1:dim(xx)[1])
z[i,1] <- xx[i,xx[i,1]+1]
z[,2] <- rowSums(xx[,2:((dim(xx)[2]-1)/2+1)]) - z[,1]
}
else z <- matrix(xx[c(3,2)],1,2)
colnames(z) <- c('right', 'wrong')
rownames(z) <- rownames(x$frame[x$frame$var == "<leaf>",])
structure(
list(node=rownames(z),
freq=z,
p.row=prop.table(z, 1),
mfreq=apply(z, 1, sum),
mperc=prop.table(apply(z, 1, sum))
),
class=c("LeafRates","list"))
}
print.LeafRates <- function(x, ...){
z <- rbind(c("","freq","","perc","","total",""),
c("node","right","wrong","right","wrong","abs","perc"),
"",
cbind(x$node,
Format(x$freq, fmt="abs"),
Format(x$p.row, fmt="%", digits=1),
Format(x$mfreq, fmt="abs"),
Format(x$mperc, fmt="%")))
write.table(format(z, justify="left"), sep = " ",
row.names=FALSE, col.names=FALSE, quote=FALSE)
}
plot.LeafRates <- function(x, col=NULL, which=c("rel","abs"),
layout=NULL, ylim=NULL, ...){
# m <- x$frame$yval2[,-1]
# m <- m[,1:((ncol(m)-1)/2)]
# rownames(m) <- rownames(x$frame)
# m.leaves <- m[x$frame$var == "<leaf>",]
#
# m.leaves <- x
# if(type=="rel") m.leaves <- prop.table(m.leaves, 1)
# d.leaves <- data.frame(frq=as.vector(t(m.leaves)),
# leaf=factor(rep(rownames(m.leaves), each=length(attr(x, "ylevels"))),
# levels=rep(rownames(m.leaves))),
# class=rep(attr(x, "ylevels"), times=nrow(m.leaves))
# )
if(is.null(col))
col <- c(DescTools::hblue, DescTools::hred)
which <- match.arg(which)
if(which=="rel"){
if(is.null(ylim))
ylim = c(0, 1.1)
ylab = "relative freq."
} else {
ylab = "frequency"
}
d.leaves <- data.frame(frq=c(x$freq[,1], x$freq[,2]),
leaf=rep(row.names(x$freq), times=2),
# class=rep(colnames(x$freq), each=nrow(x$freq)), stringsAsFactors = FALSE)
class=factor(rep(c("T","F"), each=nrow(x$freq)), levels=c("T","F")), stringsAsFactors = FALSE)
idx <- d.leaves$leaf[1:nrow(x$freq)]
if(which=="rel")
d.leaves$frq <- c(x$p.row[,1], x$p.row[,2])
if(is.null(layout))
layout <- c(nrow(x$freq), 1)
# what a zangengeburt.... node order as in the original result
id <- order(as.numeric(Sort(cbind(nod=rownames(x$freq),
nr=1:nrow(x$freq)))[,2]))
barchart( frq ~ class|leaf, data=d.leaves,
stack=FALSE, horiz=FALSE, layout=layout, ylab=ylab, xlab="classes",
ylim=ylim, index.cond=list(id),
panel = function(y, x, ...){
cols <- rep(col, length(y))
cols[which.max(y)] <- col[1]
panel.barchart(x, y,..., col=cols, origin=0, box.width=0.85)
},
strip=.myStripStyle
)
}
# Complexity parameter
CP <- function(x, ...){
structure(list(cp=x$cptable,
mincp=x$cptable[which.min(x$cptable[,"xerror"]), "CP"],
x=x), class=c("CP"))
}
print.CP <- function(x, digits = getOption("digits") - 2L, ...){
rpart::printcp(x$x, digits=digits, ...)
cat("\n")
}
plot.CP <- function(x, minline = TRUE, lty = 3,
col = 1, upper = c("size", "splits", "none"), ...){
rpart::plotcp(x$x, minline, lty, col, upper=upper, ...)
}
# plot.rpart ------------------
# we override the native rpart plot and use rpart.plot here
plot.rpart <- function (x = stop("no 'x' arg"), type = 2, extra = "auto",
under = FALSE, fallen.leaves = TRUE, digits = 2, varlen = 0,
faclen = 0, roundint = TRUE, cex = NULL, tweak = 1, clip.facs = FALSE,
clip.right.labs = TRUE, snip = FALSE, box.palette = "auto",
shadow.col = 0, node.labels=TRUE, ...) {
if(identical(box.palette, "auto"))
box.palette <- as.list(ColToOpaque(SetAlpha(Pal("Helsana"))))
b <- rpart.plot(x =x, type = type, extra = extra,
under = under, fallen.leaves = fallen.leaves, digits = digits, varlen = varlen,
faclen = faclen, roundint = roundint, cex = cex, tweak = tweak,
clip.facs = clip.facs,
clip.right.labs = clip.right.labs, snip = snip, box.palette = box.palette ,
shadow.col = shadow.col, ...)
if(node.labels){
oldpar <- par(xpd=TRUE)
on.exit(par(oldpar))
BoxedText(x = b$boxes$x1, y=b$boxes$y2, labels = rownames(x$frame),
border=NA, txt.col = "steelblue", font=2, col=SetAlpha("white", 0.7), cex=0.8)
}
invisible(b)
}
.predict.rpart <- function (object, newdata, type = c("vector", "prob", "class",
"matrix", "where", "leaf"), na.action = na.pass, ...){
type <- match.arg(type)
if(type %in% c("where","leaf"))
.predict.leaves(object, newdata, type = type)
else {
class(object) <- class(object)[class(object) != "FitMod"]
predict(object, newdata, type, na.action, ...)
}
}
.predict.leaves <- function (rp, newdata, type = "where") {
if (type == "where") {
rp$frame$yval <- 1:nrow(rp$frame)
should.be.leaves <- which(rp$frame[, 1] == "<leaf>")
}
else if (type == "leaf") {
rp$frame$yval <- rownames(rp$frame)
should.be.leaves <- rownames(rp$frame)[rp$frame[, 1] ==
"<leaf>"]
}
else stop("Type must be 'where' or 'leaf'")
leaves <- predict(rp, newdata = newdata, type = "vector")
should.be.leaves <- which(rp$frame[, 1] == "<leaf>")
bad.leaves <- leaves[!is.element(leaves, should.be.leaves)]
if (length(bad.leaves) == 0)
return(leaves)
u.bad.leaves <- unique(bad.leaves)
u.bad.nodes <- row.names(rp$frame)[u.bad.leaves]
all.nodes <- row.names(rp$frame)[rp$frame[, 1] == "<leaf>"]
is.descendant <- function(all.leaves, node) {
if (length(all.leaves) == 0)
return(logical(0))
all.leaves <- as.numeric(all.leaves)
node <- as.numeric(node)
if (missing(node))
return(NA)
result <- rep(FALSE, length(all.leaves))
for (i in 1:length(all.leaves)) {
LEAF <- all.leaves[i]
while (LEAF > node) {
LEAF <- trunc(LEAF/2)
if (LEAF == node)
result[i] <- TRUE
break
}
}
return(result)
}
where.tbl <- table(rp$where)
names(where.tbl) <- row.names(rp$frame)[as.numeric(names(where.tbl))]
for (u in 1:length(u.bad.nodes)) {
desc.vec <- is.descendant(all.nodes, u.bad.nodes[u])
me <- where.tbl[all.nodes][desc.vec]
winner <- names(me)[me == max(me)][1]
leaves[leaves == u.bad.leaves[u]] <- which(row.names(rp$frame) ==
winner)
}
return(leaves)
}
Node <- function (x, node=NULL, type=c("all", "split", "leaf"), digits=3) {
if (!inherits(x, "rpart"))
stop("Not a legitimate \"rpart\" object")
ff <- x$frame
ylevel <- attr(x, "ylevels")
id <- as.integer(row.names(ff))
parent.id <- ifelse(id == 1L, 1L, id%/%2L)
rows <- seq_along(id)
is.leaf <- ff$var == "<leaf>"
index <- cumsum(c(1L, ff$ncompete + ff$nsurrogate + !is.leaf))
if (!all(is.leaf)) {
sname <- rownames(x$splits)
cuts <- character(nrow(x$splits))
temp <- x$splits[, 2L]
for (i in seq_along(cuts)) {
cuts[i] <- if (temp[i] == -1L)
paste("<", format(signif(x$splits[i, 4L], digits)))
else if (temp[i] == 1L)
paste("<", format(signif(x$splits[i, 4L], digits)))
else paste("splits as ", paste(c("L", "-", "R")[x$csplit[x$splits[i, 4L], 1:temp[i]]],
collapse = "", sep = ""), collapse = "")
}
if (any(temp < 2L))
cuts[temp < 2L] <- format(cuts[temp < 2L], justify = "left")
cuts <- paste0(cuts, ifelse(temp >= 2L, ",", ifelse(temp == 1L, " to the right,", " to the left, ")))
}
tmp <- if (is.null(ff$yval2))
ff$yval[rows]
else
ff$yval2[rows, , drop = FALSE]
tmp <- unname(tmp)
tprint <- x$functions$summary(tmp, ff$dev[rows], ff$wt[rows], ylevel, digits)
nclass <- (ncol(tmp) - 2L)/2L
nlst <- list()
if(is.null(node))
nid <- seq_along(rows)
else
nid <- seq_along(rows)[which(!is.na(rows[match(row.names(ff), node)]))]
for (ii in nid) {
i <- rows[ii]
nlbl <- as.character(id[i])
nlst[[nlbl]] <- SetNames(list(), names=nlbl)
nn <- ff$n[i]
nlst[[nlbl]]$id <- id[i]
nlst[[nlbl]]$vname <- as.character(ff$var[i])
nlst[[nlbl]]$isleaf <- is.leaf[i]
nlst[[nlbl]]$nobs <- nn
nlst[[nlbl]]$group <- ylevel[tmp[i, 1L]]
nlst[[nlbl]]$ycount <- tmp[i, 1L + (1L:nclass)]
nlst[[nlbl]]$yprob <- tmp[i, 1L + nclass + 1L:nclass]
nlst[[nlbl]]$nodeprob <- tmp[i, 2L * nclass + 2L]
nlst[[nlbl]]$complexity <- ff$complexity[i]
nlst[[nlbl]]$tprint <- tprint[ii]
if (!is.leaf[i]) {
sons <- 2L * id[i] + c(0L, 1L)
sons_n <- ff$n[match(sons, id)]
nlst[[nlbl]]$sons <- SetNames(sons, names=c("left", "right"))
nlst[[nlbl]]$sons_n <- SetNames(sons_n, names=c("left", "right"))
## what's that??
# j <- nn - (sons.n[1L] + sons.n[2L])
# if (j > 1L)
# cat(", ", j, " observations remain\n",
# sep = "")
# else if (j == 1L)
# cat(", 1 observation remains\n")
# else cat("\n")
# primary splits
j <- seq(index[i], length.out = 1L + ff$ncompete[i])
temp <- if (all(nchar(cuts[j], "w") < 25L))
format(cuts[j], justify = "left")
else
cuts[j]
nlst[[nlbl]]$primarysplits <- data.frame(split=sname[j], direction=temp, improve=x$splits[j, 3L], missing= nn - x$splits[j, 1L])
# surrogate splits
if (ff$nsurrogate[i] > 0L) {
j <- seq(1L + index[i] + ff$ncompete[i], length.out = ff$nsurrogate[i])
agree <- x$splits[j, 3L]
temp <- if (all(nchar(cuts[j], "w") < 25L))
format(cuts[j], justify = "left")
else cuts[j]
adj <- x$splits[j, 5L]
nlst[[nlbl]]$surrogatesplits <- data.frame(split=sname[j], direction=temp,
agree=agree, adj=adj, split=x$splits[j, 1L])
}
}
}
type <- match.arg(type)
if(type=="leaf")
nlst <- nlst[sapply(nlst, "[[", "isleaf")]
if(type=="split")
nlst <- nlst[!sapply(nlst, "[[", "isleaf")]
return(structure(nlst, class="node"))
}
print.node <- function(x, digits=3, ...){
if(length(x)==0)
cat("list()\n")
else {
for(i in seq_along(x)) {
cat("\nNode number ", x[[i]]$id, ": ", x[[i]]$nobs, " observations", sep = "")
if (x[[i]]$isleaf)
cat("\n")
else
cat(", complexity param=", format(signif(x[[i]]$complexity, digits)), "\n", sep = "")
cat(x[[i]]$tprint, "\n")
if(!x[[i]]$isleaf){
cat(" left son=", x[[i]]$sons[1L], " (", x[[i]]$sons_n[1L],
" obs)", " right son=", x[[i]]$sons[2L],
" (", x[[i]]$sons_n[2L], " obs)", sep = "")
cat("\n Primary splits:\n")
for(lx in split(x[[i]][["primarysplits"]],
f = 1:nrow(x[[i]][["primarysplits"]]))) {
cat(paste(" ", format(lx$split, justify = "left"),
" ", lx$direction, " improve=", format(signif(lx$improve, digits)),
", (",
lx$missing, " missing)", sep = ""), sep = "\n")
}
if(!is.null(x[[i]]$surrogatesplits)){
cat(" Surrogate splits:\n")
for(lx in split(x[[i]][["surrogatesplits"]],
f = 1:nrow(x[[i]][["surrogatesplits"]]))) {
cat(paste(" ", format(lx$split, justify = "left"),
" ", lx$direction, " agree=", format(round(lx$agree, 3L)),
", adj=", format(round(lx$adj, 3L)),
", (", lx$split.1, " split)",
sep = ""), sep = "\n")
}
}
}
cat("\n")
}
}
}
#' #' @importFrom flipU OutcomeName
#' #' @importFrom stats formula
#' rPartToTreeFrame <- function(obj)
#' {
#' frame <- obj$frame
#' n.nodes <- nrow(frame)
#' splits <- matrix("", n.nodes, 2)
#' nms <- colnames(obj$splits)
#' index.i <- nms == "index"
#' ncat.i <- nms == "ncat"
#' c <- 1
#' for (i in 1:n.nodes)
#' {
#' var.name <- as.character(frame$var[i])
#' if (var.name != "<leaf>")
#' {
#' if (is.factor(obj$model[[var.name]]))
#' {
#' n.levels <- length(attr(obj, "xlevels")[[var.name]])
#' extended.letters <- extendLetters(n.levels)
#' lttrs <- extended.letters[1:n.levels]
#' levels.split <- obj$csplit[obj$splits[c, index.i], ]
#' splits[i, 1] <- paste0(":", paste(lttrs[levels.split == 1], collapse = ""))
#' splits[i, 2] <- paste0(":", paste(lttrs[levels.split == 3], collapse = ""))
#' }
#' else
#' {
#' break.val <- obj$splits[c, index.i]
#' if (obj$splits[c, ncat.i] < 0)
#' {
#' splits[i, 1] <- paste0("<", break.val)
#' splits[i, 2] <- paste0(">=", break.val)
#' }
#' else
#' {
#' splits[i, 1] <- paste0(">=", break.val)
#' splits[i, 2] <- paste0("<", break.val)
#' }
#' }
#' c <- c + frame$ncompete[i] + frame$nsurrogate[i] + 1
#' }
#' }
#' frame$splits <- splits
#'
#' outcome.var <- obj$model[[OutcomeName(formula(obj$terms))]]
#'
#' if (is.factor(outcome.var))
#' frame$yval <- levels(outcome.var)[frame$yval]
#'
#' if (!is.null(frame$yval2))
#' {
#' fitted.levels <- levels(droplevels(outcome.var[obj$subset]))
#' all.levels <- levels(outcome.var)
#' n.levels <- length(fitted.levels)
#' yprob <- frame$yval2[, (n.levels + 2):(2 * n.levels + 1)]
#' empty.levels <- all.levels[!all.levels %in% fitted.levels]
#' yprob <- cbind(yprob, matrix(0, nrow = nrow(yprob), ncol = length(empty.levels)))
#' colnames(yprob) <- c(fitted.levels, empty.levels)
#' frame$yprob <- yprob
#' }
#' frame
#' }
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.