#SCCS @(#)as.tree.s	1.2 03/21/97
# Change an rpart object into a tree object

as.tree <- function(x) {
    if (!inherits(x, 'rpart')) stop ("Only applicable to rpart objects")
  
    temp <- match(c('var', 'n', 'dev', 'yval', 'splits', 'yprob'), 
		          dimnames(x$frame)[[2]], nomatch=0)
    x$frame <- x$frame[,temp]
    x$cptable <- NULL
    x$splits <- NULL
    x$parms <- NULL
    x$control <- NULL
    x$csplit <- NULL
    
    # Fix xlevels, the only hard part
    xlevs <- attr(x, 'xlevels')
    nclass <- length(xlevs)
    xvars <- attr(x$terms, 'term.labels')
    nvar <- length(xvars)

    if (length(xlevs)==0) newlev <- vector('list',nvar)  #no factors
    else {
	temp <- match(1:nvar, as.numeric(names(xlevs)))
	newlev <- xlevs[temp]
        }
    names(newlev) <- xvars
    attr(x, 'xlevels') <- newlev

    class(x) <- 'tree'
    x
    }

	
	
# SCCS @(#)labels.rpart.s	1.2 01/21/97
# Differs from labels.tree only in the processing of xlevels
#
labels.rpart <- function(object, pretty = T, collapse = T)
{
    if(!inherits(object, "rpart"))
	stop("Not legitimate rpart object")
    frame <- object$frame
    xlevels <- attr(object, "xlevels")
    var <- frame$var
    var2 <- as.character(as.numeric(var)-1)
    splits <- frame$splits
    if(!is.null(pretty)) {
      if(pretty) xlevels <- lapply(xlevels, abbreviate, pretty)
      fix <- grep("^:", splits[, 1])
      for(i in fix) 
        for(j in 1:2) {
          # split :cde into c(3,4,5) and look up levels.
          sh <- splits[i, j] 
          nc <- nchar(sh)
          sh <- substring(sh, 2:nc, 2:nc)
          xl <- xlevels[[ var2[i] ]][ match(sh, letters) ]
          splits[i, j] <- paste(":", paste(as.vector(xl), collapse=","), sep="")
        }
    }
    var <- as.character(var)
    if(!collapse)
	return(array(paste(var, splits, sep = ""), dim(splits)))
    node <- as.numeric(row.names(frame))
    parent <- match((node %/% 2), node)
    odd <- as.logical(node %% 2)
    node[odd] <- paste(var[parent[odd]], splits[parent[odd], 2], sep = "")
    node[!odd] <- paste(var[parent[!odd]], splits[parent[!odd], 1], sep = 
		"")
    node[1] <- "root"
    node
}
# SCCS 02/18/97 @(#)meanvar.rpart.s	1.2

meanvar.rpart <- function(tree, xlab = "ave(y)", ylab = "ave(deviance)", ...)

{
	if(!inherits(tree, "rpart"))
		stop("Not legitimate rpart object")
	if(!tree$method=='anova')
		stop("Plot not useful for classification or poisson trees")
	frame <- tree$frame
	frame <- frame[frame$var == "<leaf>",  ]
	x <- frame$yval
	y <- frame$dev/frame$n
	label <- row.names(frame)
	plot(x, y, xlab = xlab, ylab = ylab, type = "n", ...)
	text(x, y, label)
	invisible(list(x = x, y = y, label = label))
}

meanvar <- function(x,...) UseMethod('meanvar')
# sccs @(#)model.frame.rpart.s	1.3 01/21/97
model.frame.rpart <- function(formula, ...)
{
	m <- formula$model
	if(!is.null(m)) return(m)
	oc <- formula$call
	if(substring(deparse(oc[[1]]), 1, 7) == "predict") {
		m <- eval(oc$newdata, local = F)
		if(is.null(attr(m, "terms"))) {
			object <- eval(oc$object, local = F)
			m <- model.frame(object$terms, m, na.rpart)
		}
		return(m)
	}
	while(deparse(oc[[1]]) != "rpart")
          oc <- eval(oc[[2]])$call
	oc$subset <- names(formula$where)
	oc$method <- formula$method
	eval(oc)
}

na.rpart <- function(x)
{
  y <- x[[1]]
  if (is.matrix(y)){
    keep <- apply(y, 1, function(x) !all(is.na(x)))
  } else keep <- !is.na(y)
  xmiss <- is.na(x[,seq(along=names(x))[-1], drop=F])
  keep <- keep & ((xmiss %*% rep(1, ncol(xmiss))) < ncol(xmiss))
  if (all(keep)) x
  else {
    temp <- seq(keep)[!keep]
    names(temp) <- row.names(x)[!keep]
    #the methods for this group are all the same as for na.omit
    attr(temp, "class") <- c('na.rpart', 'omit')
    structure(x[keep,], na.action=temp)
  }
}
## submitted by Anantha Prasad 1/26/98

path.rpart <- function(tree, nodes, pretty = 0, print.it = T)
{
        if(!inherits(tree, "rpart"))
                stop("Not legitimate tree")
        splits <- labels.rpart(tree, pretty = pretty)
        frame <- tree$frame
        n <- row.names(frame)
        node <- as.numeric(n)
        which <- descendants(node)      #ancestors are columns
        path <- list()
        if(missing(nodes)) {
                xy <- rpartco(tree)
                while(length(i <- identify(xy, n = 1, plot = F)) > 0) {
                        path[[n[i]]] <- path.i <- splits[which[, i]]
                        if(print.it) {
                                cat("\n", "node number:", n[i], "\n")
                                cat(paste("  ", path.i), sep = "\n")
                        }
                }
        }
        else {

                if(length(nodes <- node.match(nodes, node)) == 0)
                        return(invisible())
                for(i in nodes)
                       { path[[n[i]]] <- path.i <- splits[which[, i]]
			if(print.it) {
                                cat("\n", "node number:", n[i], "\n")
                                cat(paste("  ", path.i), sep = "\n")
                                }
                       } 
        }
        invisible(path)
}





# @(#)plot.rpart.s	1.5 03/12/97
plot.rpart <- function(tree, uniform=F, branch=1, compress=F, 
			     nspace, margin=0, minbranch=.3, ...){
    if(!inherits(tree, "rpart"))
	    stop("Not an rpart object")

    if (compress & missing(nspace)) nspace <- branch
    if (!compress) nspace <- -1     #means no compression
    assign(paste(".rpart.parms", dev.cur(), sep = "."), 
            list(uniform=uniform, branch=branch, nspace=nspace,
		 minbranch=minbranch), envir=.GlobalEnv)

    #define the plot region
    temp <- rpartco(tree)
    x <- temp$x
    y <- temp$y
    temp1 <- range(x) + diff(range(x))*c(-margin, margin)
    temp2 <- range(y) + diff(range(y))*c(-margin, margin)
    plot(temp1, temp2, type='n', axes=F, xlab='', ylab='', ...)

    # Draw a series of horseshoes or V's, left son, up, down to right son
    #   NA's in the vector cause lines() to "lift the pen"
    node <- as.numeric(row.names(tree$frame))
    temp <- rpart.branch(x, y, node, branch)
	  
    if (branch>0) text(x[1], y[1], '|')
    lines(c(temp$x), c(temp$y))
    invisible(list(x=x, y=y))
}





# SCCS @(#)plotcp.s	1.1 02/08/98
# Contributed by B.D. Ripley 97/07/17
#
plotcp <- function(x, minline=T, lty=3, col=1, 
		   upper=c("size", "splits", "none"), ...)
{
  if(!inherits(x, "rpart")) stop("Not legitimate rpart object")
  upper <- match.arg(upper)
  p.rpart <- x$cptable
  if(ncol(p.rpart) < 5)
    stop("cptable does not contain cross-validation results")
  xstd <- p.rpart[, 5]
  xerror <- p.rpart[, 4]
  nsplit <- p.rpart[, 2]
  ns <- seq(along=nsplit)
  cp0 <- p.rpart[ ,1]
  cp <- sqrt(cp0 * c(Inf, cp0[-length(cp0)]))
  ylim <- c(min(xerror - xstd) - 0.1, max(xerror + xstd) + 0.1)
  plot(ns, xerror, axes = F, xlab = "cp", ylab = 
       "X-val Relative Error", ylim = ylim, type = "o", ...)
  box()
  axis(2, ...)
  segments(ns, xerror - xstd, ns, xerror + xstd)
  axis(1, at = ns, lab = as.character(signif(cp, 2)), ...)
  switch(upper,
	 size = {
           axis(3, at = ns, lab = as.character(nsplit+1), ...)
           mtext("size of tree", side=3, line=3)
	 },
	 splits = {
           axis(3, at = ns, lab = as.character(nsplit), ...)
           mtext("number of splits", side=3, line=3)
	 },)
  minpos <- min(seq(along=xerror)[xerror==min(xerror)])
  if(minline) abline(h=(xerror+xstd)[minpos], lty=lty, col=col)
  invisible()
}
# SCCS 03/03/98 @(#)post.rpart.s	1.11
#
post.rpart <- function(tree, title., 
		       filename=paste(deparse(substitute(tree)),".ps",sep=""),
		       digits=.Options$digits - 3, pretty=T, 
		       use.n=T,  horizontal=T, ...)
{
  if(filename !=""){
    postscript(file = filename, horizontal=horizontal, ...)
    par(mar=c(2,2,4,2)+.1)
    on.exit(dev.off())
  } else {
    oldpar <- par(mar=c(2,2,4,2)+.1)
    on.exit(invisible(par(oldpar)))
  }

  plot(tree, uniform=T, branch=.2, compress=T, margin=.1)
  text(tree, all=T, use.n=use.n, fancy=T, digits=digits, pretty=pretty)
  method <- tree$method

  if(missing(title.)) {
    temp  <- attr(tree$terms,'variables')[2]	      
    title(paste("Endpoint =",temp),cex=.8)
  } else if (title. !="") title(title.,cex=.8)
}

## SCCS @(#)post.s	1.3 02/27/98
post <- function(tree, ...) UseMethod("post")

# SCCS @(#)pred.rpart.s	1.3 09/03/97
#
# Do Rpart predictions given a tree and a matrix of predictors
pred.rpart <- function(fit, x) {

    frame <- fit$frame
    nc <- frame[, c('ncompete', 'nsurrogate')]
    frame$index <- 1 + c(0, cumsum((frame$var != "<leaf>") + 
                                       nc[[1]] + nc[[2]]))[-(nrow(frame)+1)]
    frame$index[frame$var == "<leaf>"] <- 0
    vnum <- match(dimnames(fit$split)[[1]], dimnames(x)[[2]])
    if (any(is.na(vnum))) stop("Tree has variables not found in new data")
    temp <- .C("pred_rpart",
		    as.integer(dim(x)),
		    as.integer(dim(frame)[1]),
		    as.integer(dim(fit$splits)),
		    as.integer(if(is.null(fit$csplit)) rep(0,2)
		               else dim(fit$csplit)),
		    as.integer(row.names(frame)),
		    as.integer(unlist(frame[,
			     c('n', 'ncompete', 'nsurrogate', 'index')])),
		    as.integer(vnum),
		    as.double(fit$splits),
		    as.integer(fit$csplit -2),
		    as.integer((fit$control)$usesurrogate),
		    as.double(x),
		    as.integer(is.na(x)),
		    where = integer(dim(x)[1]),
		    NAOK =T)
    temp <- temp$where
    names(temp) <- dimnames(x)[[1]]
    temp
    }
## SCCS @(#)predict.rpart.s	1.7 02/12/98

predict.rpart <-
function(object, newdata = list(), type = c("vector", "tree", "class"))
{
    if(!inherits(object, "rpart"))
	stop("Not legitimate tree")
    type <- match.arg(type)
    if(missing(newdata) & type == "tree")
	return(object)  #idiot proofing
    if(missing(newdata))
	where <- object$where
    else {
	if(is.null(attr(newdata, "terms"))) {
	    Terms <- delete.response(object$terms)
	    act <- (object$call)$na.action
	    if (is.null(act)) act<- na.rpart
	    newdata <- model.frame(Terms, newdata, na.action = act,
                                      xlev=attr(object, "xlevels"))
	    }
	where <- pred.rpart(object, rpart.matrix(newdata))
	}
    frame <- object$frame
    method <- object$method
    ylevels <- attr(object,'ylevels')
    if(type == "vector") {
      if(length(ylevels)>0){
	frame <- frame$yprob[where,]
	dimnames(frame)[[1]] <- names(where)
      } else {
	frame <- frame$yval[where]
	names(frame) <- names(where)
      }
      return(frame)
    } else if(type == "class") {
      if(length(ylevels) == 0)
	stop("Type class is only appropriate for classification")
      frame <- factor(ylevels[frame$yval[where]], levels=ylevels)
      names(frame) <- names(where)
      return(frame)
    } else stop("Cannot do rpart objects yet")
}

#SCCS  @(#)print.rpart.s	1.11 09/03/97
print.rpart <- function(x, pretty=0, spaces=2, cp, 
               digits=.Options$digits-3, ...) {
    if(!inherits(x, "rpart")) stop("Not legitimate rpart object")

    #This is stolen, unabashedly, from print.tree
    if (x$method=='class')
         cat("node), split, n, loss, yval, (yprob)\n")
    else cat("node), split, n, deviance, yval\n")
    cat("      * denotes terminal node\n\n")
  
    if (!missing(cp)) x <- prune.rpart(x, cp=cp)
    frame <- x$frame
    ylevel <- attr(x,'ylevels')
    node <- as.numeric(row.names(frame))
    depth <- tree.depth(node)
    indent <- paste(rep(" ", spaces * 32), collapse = "")   
    #32 is the maximal depth
    if(length(node) > 1) {
        indent <- substring(indent, 1, spaces * seq(depth))
        indent <- paste(c("", indent[depth]), format(node), ")", sep = "")
        }
    else indent <- paste(format(node), ")", sep = "")
    if (x$method=='class') {
        if(!is.null(ylevel)) 
           yval <- paste(as.character(ylevel[frame$yval]),
                                  " (", sep = "")
        else
           yval <- paste(as.character(frame$yval),
                                     " (", sep = "")
        yprob <- format(frame$yprob,digits=digits)
        for(i in 1:ncol(yprob))
            yval <- paste(yval, yprob[, i])
        yval <- paste(yval, ")")
        }
    else yval <- format(signif(frame$yval, digits = digits))
    term <- rep(" ", length(depth))
    term[frame$var == "<leaf>"] <- "*"
    z <- labels(x, pretty = pretty)
    n <- frame$n
    z <- paste(indent, z, n, format(signif(frame$dev, digits = digits)), 
            yval, term)
    cat(z, sep = "\n")
    return(invisible(x))
    #end of the theft
    }
#SCCS  @(#)printcp.s	1.5 09/03/97
# print out the cptable, along with some summary of the tree
printcp <- function(x, digits=.Options$digits-2) {
    if (!inherits(x, 'rpart')) stop ("Must be an rpart x")
    cat(switch(x$method,anova = "\nRegression tree:\n" ,
			class = "\nClassification tree:\n" ,
			poisson="\nRates regression tree:\n",
			exp = "\nSurvival regression tree:\n")
			)

    if(!is.null(cl <- x$call)) {
	dput(cl)
	cat("\n")
      }
    frame <- x$frame
    leaves <- frame$var == "<leaf>"
    used <- unique(frame$var[!leaves])

    if(!is.null(used)) {
		cat("Variables actually used in tree construction:\n")
		print(sort(as.character(used)), quote=F)
		cat("\n")
	}


    cat("Root node error: ", format(frame$dev[1], digits=digits), '/', 
			frame$n[1], ' = ',
		         format(frame$dev[1]/frame$n[1], digits=digits), 
 			'\n\n', sep='')

    print (x$cptable, digits=digits)
    invisible(x$cptable)
    }

#SCCS @(#)prune.rpart.s	1.8 02/27/98
prune.rpart <- function(tree, cp) {
     ff <- tree$frame
     id <- as.integer(row.names(ff))
     toss <- id[ff$complexity <= cp &  ff$var!='<leaf>'] #not a leaf
     if (length(toss)==0) return(tree)   #all the tree is retained

     newx <- snip.rpart(tree, toss)

     # Now cut down the CP table
     temp <- pmax(tree$cptable[,1], cp)
     keep <- match(unique(temp), temp)
     newx$cptable <- tree$cptable[keep,]
     newx$cptable[max(keep),1] <- cp

     newx
     }
# SCCS @(#)prune.s	1.2 02/12/98
# This should be part of Splus proper -- make prune a method
prune <- function(tree, ...)  UseMethod("prune")
#SCCS  @(#)residuals.rpart.s	1.5 04/23/97

residuals.rpart <- function(object, type)
    {

    if(!inherits(object, "rpart"))
	    stop("Not legitimate rpart object")

    if (object$method=='anova' || object$method=='class')
      { ## code taken directly from residuals.tree
        if(is.null(y <- object$y))
                y <- model.extract(model.frame(object), "response")
        frame <- object$frame
        if(is.null(ylevels <- attr(object, "ylevels")))
                return(y - frame$yval[object$where])    #       y <- unclass(y)
        if(missing(type))
                type <- "usual"
        else if(is.na(match(type, c("usual", "pearson", "deviance"))))
                stop("Don't know about this type of residual")
        if(type == "usual")
                yhat <- frame$yval[object$where]
        else yhat <- frame$yprob[object$where,  ][cbind(seq(y), unclass(y))]
        r <- switch(type,
                usual = as.integer(y != yhat),
                # misclassification
                pearson = (1 - yhat)/yhat,
                # sum((obs-fitted)/fitted)
                deviance = -2 * log(yhat))
        names(r) <- names(y)
        r
       }

    else {
	if(is.null(y <- object$y))
		y <- model.extract(model.frame(object), "response")
	lambdat  <- (object$frame$yval)[object$where] * y[,1]

	events <- y[,2]
	temp <- pmax(events, 1)
	sign(events-lambdat) *
		  sqrt(-2*((events - lambdat) + events*log(lambdat/temp)))
	}
    }
#SCCS @(#)rpart.anova.s	1.1 09/19/95
rpart.anova <- function(y, offset, parms) {
    if (!is.null(offset)) y <- y-offset
    list(y=y, parms=0, numresp=1)
    }
#SCCS @(#)rpart.branch.s	1.2 01/25/97
#
# Compute the "branches" to be drawn for an rpart object
#
rpart.branch <- function(x, y, node, branch) {
    if (missing(branch)) {
	if (exists(parms <-paste(".rpart.parms", dev.cur(), sep="." ))) {
#	    parms <- get(parms, frame=0)
          parms <- get(parms, inherits=T)
          branch <- parms$branch
        }
	else branch <- 0
      }

    # Draw a series of horseshoes, left son, up, over, down to right son
    #   NA's in the vector cause lines() to "lift the pen"
    is.left <- (node%%2 ==0)        #left hand sons
    node.left <- node[is.left]
    parent <- match(node.left/2, node)
    sibling <- match(node.left+1, node) 
    temp <- (x[sibling] - x[is.left])*(1-branch)/2
    xx <- rbind(x[is.left], x[is.left]+ temp, 
                x[sibling]- temp, x[sibling], NA)
    yy <- rbind(y[is.left], y[parent], y[parent], y[sibling], NA)
    list(x=xx, y=yy)
    }
#SCCS @(#)rpart.class.s	1.2 02/19/97
rpart.class <- function(y, offset, parms) {
    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 <- table(factor(y, levels=1:numclass))  #in case of zeros
    numresp <- 1+numclass
    if (missing(parms) || is.null(parms))
	parms <- c(counts/sum(counts), rep(1,numclass^2)-diag(numclass),1)
    else if (is.list(parms)) {
	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(apply(temp2,1,sum)==0))
			stop("Loss matrix has a row of zeros")
	    }

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

    list(y=y, parms=parms, numresp=numclass+1, counts=counts,
		ylevels= levels(fy))
    }

#SCCS @(#)rpart.control.s	1.4 01/31/97
rpart.control <-
  function(minsplit=20, minbucket= round(minsplit/3), cp=.01,
	   maxcompete=4, maxsurrogate=5, usesurrogate=2, xval=10, ... ) {

	if (maxcompete<0) {
	    warning("The value of maxcompete supplied is <0; the value 0 was used instead")
	    maxcompete <-0
	    }
	if (any(xval<0)) {
	    warning("The value of xval supplied is <0; the value 0 was used instead")
	    xval <-0
	    }

	if (missing(minsplit) && !missing(minbucket)) minsplit <- minbucket*3

	list(minsplit=minsplit, minbucket=minbucket, cp=cp,
	     maxcompete=maxcompete, maxsurrogate=maxsurrogate,
	     usesurrogate=usesurrogate, xval=xval)
	}
#SCCS @(#)rpart.exp.s	1.3 01/21/97
# rescaled exponential splitting
rpart.exp <- function(y, offset, parms=1) {
    # if both a time and an offset occur, apply the offset AFTER rescaling
    #
    late.off <-1

    if (!inherits(y, "Surv")) stop("Response must be a survival object - use the Surv() function")


    if (is.matrix(y)) {
	if (ncol(y)!=2) stop("response must be a 2 column matrix or a vector")
	if (!is.null(offset)) late.off <- exp(offset)
	}
    else {
	if (is.null(offset)) stop("No time value given")
	else  y <- cbind( exp(offset), y)
	}

    if (any(y[,1]<=0)) stop("Observation time must be >0")
    if (any(y[,2]!=0 & y[,2]!=1))  stop("Number of events must be 0 or 1")

    stat <- y[,2]
    dtime <- sort(unique(y[stat==1,1]))
    # Next line avoids round off errors that effect pcount.  Pyears2 counts
    #  forward in time, and dtime exactly= death times is not good.
    dtime2 <- dtime + max(dtime)*sqrt(.Machine$double.eps)
    
    n <- length(stat)
    nd<- length(dtime)
    fit <- .C("pyears2", sn=as.integer(n),
			 sny=as.integer(2),
			 sdoevent=as.integer(1),
	                 sy=y,
			 sodim=as.integer(1),
			 ofac=as.integer(0),
			 odim=as.integer(nd),
			 socut=c(0,dtime2),
			 odata=double(n),  #a vector of zeros
			 pyears= double(nd),
			 pn = double(nd),
			 pcount = double(nd),
			 offtable = 0)

    tmp <- y[,1] #no hazard accumulates if no more deaths
    tmp[tmp>max(dtime)] <- max(dtime,na.rm=T)

    y[,1] <- approx(c(0,dtime2), cumsum(c(0, 
                   (fit$pcount/fit$pyears)*diff(c(0,dtime2)))),tmp)$y*late.off 
    list(y=y, parms=parms, numresp=2)
    }
# SCCS @(#)rpart.matrix.s	1.3 01/21/97
#
# This differs from tree.matrix in xlevels -- we don't keep NULLS in
#   the list for all of the non-categoricals
#
rpart.matrix <- function(frame)
    {
    if(!inherits(frame, "data.frame"))
	    return(as.matrix(frame))
    frame$"(weights)" <- NULL
    terms <- attr(frame, "terms")
    if(is.null(terms)) predictors <- names(frame)
    else predictors <- as.character(attr(terms, "term.labels"))
    frame <- frame[predictors]
#     else {
#       a <- attributes(terms)
#       predictors <- as.character(a$variables)[-1]
#       removals <- NULL
#       if ((TT <- a$response) > 0) {
#         removals <- TT
#       }
#       if (!is.null(TT <- a$offset)) {
#         removals <- c(removals, TT)
#       }
#       if (!is.null(removals)) {
#         predictors <- predictors[-removals]
#         frame <- frame[, -removals]
#       }
#     }

    factors <- sapply(frame, function(x) !is.null(levels(x)))
    characters <- sapply(frame, is.character)
    if(any(factors | characters)) {
	# change characters to factors
	for (preds in predictors[characters])
		frame[preds] <- as.factor(frame[preds])
        factors <- factors | characters
        column.levels <- lapply(frame[factors], levels)
	names(column.levels) <- (1:ncol(frame))[factors]

	# Now make them numeric
	for (preds in predictors[factors])
	     frame[[preds]] <- as.numeric(frame[[preds]])
	x <- as.matrix(frame)
	attr(x, "column.levels") <- column.levels
	}
    else x <- as.matrix(frame)
    class(x) <- "matrix"
    x
    }


#SCCS @(#)rpart.poisson.s	1.2 02/16/97
rpart.poisson <- function(y, offset, parms=1) {
    if (is.matrix(y)) {
	if (ncol(y)!=2) stop("response must be a 2 column matrix or a vector")
	if (!is.null(offset)) y[,1] <- y[,1] + exp(offset)
	}
    else {
	if (is.null(offset)) y <- cbind(1,y)
	else  y <- cbind( exp(offset), y)
	}
    if (any(y[,1] <=0)) stop("Observation time must be >0")
    if (any(y[,2] <0))  stop("Number of events must be >=0")

    list(y=y, parms=parms, numresp=2)
    }
# SCCS @(#)rpart.s	1.23 02/12/98
#
#  The recursive partitioning function, for S
#
rpart <- function(formula, data=NULL, weights, subset,
		   na.action=na.rpart, method, model=F, x=F, y=T,
		   parms, control, ...) {


    call <- match.call()
    if (is.data.frame(model)) {
	m <- model
	model <- F
	}
    else {
	m <- match.call(expand=F)
	m$model <- m$method <- m$control<- NULL
	m$x <- m$y <- m$parms <- m$... <- NULL
	m$na.action <- na.action
	m[[1]] <- as.name("model.frame.default")
	m <- eval(m, sys.frame(sys.parent()))
	}
    Terms <- attr(m, "terms")
    if(any(attr(Terms, "order") > 1))
	stop("Trees cannot handle interaction terms")

    Y <- model.extract(m, "response")
    if (missing(method)) {
	if (is.factor(Y))      method <- 'class'
        else if (is.Surv(Y))   method <- 'exp'
	else if (is.matrix(Y)) method<- 'poisson'
	else                   method<- 'anova'
	}
    method.int <- pmatch(method, c("anova", "poisson", "class", "exp"))
    if (is.na(method.int)) stop("Invalid method")
    method <- c("anova", "poisson", "class", "exp")[method.int]
    if (method.int==4) method.int <- 2

    w <- model.extract(m, "weights")
    if(length(w)) warning("Weights ignored")
    offset <- attr(Terms, "offset")

    if (missing(parms))
	  init <- (get(paste("rpart", method, sep='.')))(Y,offset)
    else
	  init <- (get(paste("rpart", method, sep='.')))(Y,offset, parms)
    Y <- init$y
    X <- rpart.matrix(m)
    nobs <- nrow(X)

    xlevels <- attr(X, "column.levels")
    cats <- rep(0,ncol(X))	
    if(!is.null(xlevels)) {
	cats[as.numeric(names(xlevels))] <- unlist(lapply(xlevels, length))
	}

    controls <- rpart.control(...)
    if (!missing(control)) controls[names(control)] <- control

    xval <- controls$xval
    if (is.null(xval) || (length(xval)==1 && xval==0)) {
	xgroups <-0
	xval <- 0
	}
    else if (length(xval)==1) {
	# make random groups
        xgroups <- sample(rep(1:xval, length=nobs), nobs, replace=F)
	}
    else if (length(xval) == nobs) {
	xgroups <- xval
	xval <- length(unique(xgroups))
	}
    else stop("Invalid value for xval")

    # 
    # Have s_to_rp consider ordered categories as continuous
    #
    isord <- sapply(m, is.ordered)[-1]
    rpfit <- .C("s_to_rp",
		    n = as.integer(nobs),
		    nvarx = as.integer(ncol(X)),
		    ncat = as.integer(cats* !isord),
		    method= as.integer(method.int),
		    as.double(unlist(controls)),
		    parms = as.double(init$parms),
		    as.integer(xval),
		    as.integer(xgroups),
		    as.double(t(init$y)),
		    as.double(X),
		    as.integer(is.na(X)),
		    error = character(1),
		    NAOK=T )
    if (rpfit$n == -1)  stop(rpfit$error)

    # rpfit$newX[1:n] contains the final sorted order of the observations
    nodes <- rpfit$n          # total number of nodes
    nsplit<- rpfit$nvarx      # total number of splits, primary and surrogate
    numcp <- rpfit$method     # number of lines in cp table
    ncat  <- rpfit$ncat[1]    #total number of categorical splits
    numresp<- init$numresp    # length of the response vector

    if (nsplit==0) stop("No splits found")
    cpcol <- if (xval>0) 5 else 3
    if (ncat==0) catmat <- 0
    else         catmat <- matrix(integer(1), ncat, max(cats))
    rp    <- .C("s_to_rp2",
		       as.integer(nobs),
		       as.integer(nsplit),
		       as.integer(nodes),
		       as.integer(ncat),
		       as.integer(cats *!isord),
		       as.integer(max(cats)),
		       as.integer(xval),
		       which = integer(nobs),
		       cptable = matrix(double(numcp*cpcol), nrow=cpcol),
		       dsplit =  matrix(double(1),  nsplit,2),
		       isplit =  matrix(integer(1), nsplit,3),
		       csplit =  catmat,
		       dnode  =  matrix(double(1),  nodes, 2+numresp),
		       inode  =  matrix(integer(1), nodes, 6))
    tname <- c("<leaf>", dimnames(X)[[2]])

    if (cpcol==3) temp <- c("CP", "nsplit", "rel error")
    else          temp <- c("CP", "nsplit", "rel error", "xerror", "xstd")
    dimnames(rp$cptable) <- list(temp, 1:numcp)

    splits<- matrix(c(rp$isplit[,2:3], rp$dsplit), ncol=4,
		     dimnames=list(tname[rp$isplit[,1]+1],
			      c("count", "ncat", "improve", "index")))
    index <- rp$inode[,2]  #points to the first split for each node

    # Now, make ordered categories look like categories again (a printout
    #  choice)
    nadd <- sum(isord[rp$isplit[,1]])
    if (nadd >0) {
	newc <- matrix(integer(1), nadd, max(cats))
	cvar <- rp$isplit[,1]
	indx <- isord[cvar]		     # vector of T/F
	cdir <- splits[indx,2]               # which direction splits went
	ccut <- floor(splits[indx,4])        # cut point	
	splits[indx,2] <- cats[cvar[indx]]   #Now, # of categories instead
	splits[indx,4] <- ncat + 1:nadd      # rows to contain the splits

	# Next 4 lines can be done without a loop, but become indecipherable
	for (i in 1:nadd) {
	    newc[i, 1:(cats[(cvar[indx])[i]])] <- -1*as.integer(cdir[i])
	    newc[i, 1:ccut[i]] <- as.integer(cdir[i])
	    }
	if (ncat==0) catmat <- newc
	else         catmat <- rbind(rp$csplit, newc)
	ncat <- ncat + nadd
	}
    else catmat <- rp$csplit

    rplab <- .C("rplabel", as.integer(nodes),
			   as.integer(index),
			   splits[index, c(2,4)],
			   as.integer(ncat),
			   as.integer(catmat),
			   cutleft = character(nodes),
			   cutright= character(nodes))[6:7]

    temp <- ifelse(index==0, 1, index)
    svar <- ifelse(index==0, 0, rp$isplit[temp,1]) #var number for each node
    frame <- data.frame(row.names=rp$inode[,1],
			   var=  factor(svar, 0:ncol(X), tname),
			   n =   rp$inode[,5],
			   dev=  rp$dnode[,1],
			   yval= rp$dnode[,3],
			   complexity=rp$dnode[,2],
			   ncompete  = pmax(0, rp$inode[,3]-1),
			   nsurrogate=rp$inode[,4])

    frame$splits <- matrix(unlist(rplab), ncol=2,
			   dimnames=list(NULL, c("cutleft", "cutright")))
    if (method=='class') {
        numclass <- init$numresp -1
        temp <- rp$dnode[,-(1:3)] %*% diag(init$parms[1:numclass]*nobs /
						 init$counts)
        frame$yprob <- matrix(temp /c(temp %*% rep(1,numclass)) ,
			   ncol=numclass, dimnames=list(NULL, init$ylevels))
        frame$yval2 <- matrix(rp$dnode[, -(1:3)], ncol=numclass,
        		    dimnames=list(NULL, init$ylevels))
	}	
    else if (method=='poisson' | method=='exp') frame$yval2 <- rp$dnode[,4]

    ans <- list(frame = frame, 
                where = structure(rp$which, names = row.names(m)),
                call=call, terms=Terms, 
    		cptable =  t(rp$cptable),
		splits = splits,
		method = method,
		parms  = init$parms,
		control= controls)

    if (ncat>0) ans$csplit <- catmat +2
    if (model) {
	ans$model <- m
	if (missing(y)) y <- F
	}
    if (y) ans$y <- Y
    if (x) ans$x <- X
    ans$control <- controls
    if (!is.null(xlevels)) attr(ans, 'xlevels') <- xlevels
    if(method=='class') attr(ans, "ylevels") <- init$ylevels
    class(ans) <- c("rpart")
    ans
    }
#SCCS @(#)rpartco.s	1.6 03/12/97
# Compute the x-y coordinates for a tree
rpartco <- function(tree, parms =  paste(".rpart.parms", dev.cur(), sep = "."))
    {

    frame <- tree$frame
    method <- tree$method
    node <- as.numeric(row.names(frame))
    depth <- tree.depth(node)
    is.leaf <- (frame$var == '<leaf>')
    if (exists(parms)) {
	parms <- get(parms)
	uniform <- parms$uniform
	nspace <-parms$nspace
	minbranch <- parms$minbranch
	}
    else {
	uniform <- F
	nspace <- -1	
	minbranch <- .3
        }
   
    if(uniform) y <- (1 + max(depth) -depth) / max(depth,4)
    else {                    #make y- (parent y) = change in deviance
	y <- dev <- frame$dev  
        temp <- split(seq(node), depth)     #depth 0 nodes, then 1, then ...
        parent <- match(floor(node/2), node)
        sibling <- match(ifelse(node %% 2, node - 1, node + 1), node)

	# assign the depths
        for(i in temp[-1]) {
	    temp2 <- dev[parent[i]] - (dev[i] + dev[sibling[i]])
            y[i] <- y[parent[i]] - temp2
	    }
	#
	# For some problems, classification & loss matrices in particular
	#   the gain from a split may be 0.  This is ugly on the plot.
	# Hence the "fudge" factor of  .3* the average step
	#
	fudge <-  minbranch * diff(range(y)) / max(depth)
        for(i in temp[-1]) {
	    temp2 <- dev[parent[i]] - (dev[i] + dev[sibling[i]])
	    haskids <- !(is.leaf[i] & is.leaf[sibling[i]])
	    y[i] <- y[parent[i]] - ifelse(temp2<=fudge & haskids, fudge, temp2)
	    }
	y <- y / (max(y))
        }
    
    # Now compute the x coordinates, by spacing out the leaves and then
    #   filling in
    x   <-  double(length(node))         #allocate, then fill it in below
    x[is.leaf] <- seq(sum(is.leaf))      # leaves at 1, 2, 3, ....
    left.child <- match(node * 2, node)
    right.child <- match(node * 2 + 1, node)

    # temp is a list of non-is.leaf, by depth
    temp <- split(seq(node)[!is.leaf], depth[!is.leaf])  
    for(i in rev(temp))
            x[i] <- 0.5 * (x[left.child[i]] + x[right.child[i]])

    if (nspace < 0) return(list(x=x, y=y))

    #
    # Now we get fancy, and try to do overlapping
    #	
    #  The basic algorithm is, at each node:
    #      1: get the left & right edges, by depth, for the left and
    #           right sons, of the x-coordinate spacing. 
    #      2: find the minimal free spacing.  If this is >0, slide the
    #           right hand son over to the left
    #      3: report the left & right extents of the new tree up to the
    #           parent
    #   A way to visualize steps 1 and 2 is to imagine, for a given node,
    #      that the left son, with all its descendants, is drawn on a
    #      slab of wood.  The left & right edges, per level, give the
    #      width of this board.  (The board is not a rectangle, it has
    #      'stair step' edges). Do the same for the right son.  Now
    #      insert some spacers, one per level, and slide right hand
    #      board over until they touch.  Glue the boards and spacer
    #      together at that point. 
    #
    #  If a node has children, its 'space' is considered to extend left
    #    and right by the amount "nspace", which accounts for space
    #    used by the arcs from this node to its children.  For 
    #    horseshoe connections nspace usually is 1.
    #
    #  To make it global for a recursive function, the x coordinate list
    #    is written into frame 0.
    #
    compress <- function(me, depth) {
        lson <- me +1
	if (is.leaf[lson]) left <- list(left=x[lson], right=x[lson], 
						depth=depth+1, sons=lson)
        else               left <- compress(me+1, depth+1)

        rson <- me + 1 + length(left$sons)        #index of right son
	if (is.leaf[rson]) right<- list(left=x[rson], right=x[rson], 
						depth=depth+1, sons=rson)
	else               right<- compress(rson, depth+1)
     
	maxd <- max(left$depth, right$depth) - depth
        mind <- min(left$depth, right$depth) - depth

	# Find the smallest distance between the two subtrees
	#   But only over depths that they have in common
	# 1 is a minimum distance allowed
	slide <- min(right$left[1:mind] - left$right[1:mind]) -1
	if (slide >0) { # slide the right hand node to the left
	    x[right$sons] <- x[right$sons] - slide;
	    x[me] <- (x[right$sons[1]] + x[left$sons[1]])/2
	    assign("x", x)
	    }
	else slide <- 0

	# report back 
        if (left$depth > right$depth) {
	    templ <- left$left
            tempr <- left$right
            tempr[1:mind] <- pmax(tempr[1:mind], right$right -slide)
	    }
        else {
	    templ <- right$left  - slide
	    tempr <- right$right - slide
	    templ[1:mind] <- pmin(templ[1:mind], left$left)
	    }
	     
	list(left = c(x[me]- nspace*(x[me] -x[lson]), templ),
	     right= c(x[me]- nspace*(x[me] -x[rson]), tempr),
	     depth= maxd+ depth, sons=c(me, left$sons, right$sons))
	}
    assign('compress', compress)
    assign('x', x)
    assign('is.leaf', is.leaf)
    assign('nspace', nspace) 

    temp <- compress(1, 1)
    x <- get('x') 
#    remove(c('compress', 'x', 'is.leaf', 'nspace'))
    list(x = x, y = y)
}

## This function plots the approximate r-square for the different
## splits (assumes using anova method). 

## SCCS @(#)rsq.rpart.s	1.6 08/28/97
 
rsq.rpart <- function(x) {

  if(!inherits(x,'rpart')) stop("Not legitimate rpart")

  p.rpart <- printcp(x)
  xstd <- p.rpart[,5]
  xerror <- p.rpart[,4]
  rel.error <- p.rpart[,3]
  nsplit <- p.rpart[,2]
  method <- x$method

  if(!method=='anova') cat("May not be applicable for this method\n")

  plot(nsplit, 1-rel.error, xlab='Number of Splits', ylab='R-square', 
       ylim=c(0,1), type='o')
  par(new=T)
  plot(nsplit, 1-xerror, type='o', ylim=c(0,1),lty=2, xlab=' ', ylab=' ')
  legend(0,1, c('Apparent','X Relative'), lty=1:2)


  ylim <- c(min(xerror-xstd) -.1, max(xerror + xstd) + .1) 
  plot(nsplit, xerror, xlab='Number of Splits', ylab='X Relative Error', 
       ylim=ylim, type='o')
  segments(nsplit, xerror - xstd, nsplit, xerror + xstd)
  invisible()

  }

# SCCS %W% %G%
#
#  Interactively snip off part of a tree
#

snip.rpart.mouse <- function(tree, 
		      parms=paste(".rpart.parms", dev.cur(), sep = ".")) {
    xy <- rpartco(tree)
    toss <- NULL
    ff <- tree$frame
    if (exists(parms)) {
        parms <- get(parms)
	branch <- parms$branch
	}
    else branch <- 1

    node <- as.numeric(row.names(tree$frame))
    draw <- rpart.branch(xy$x,xy$y, node, branch)

    lastchoice <- 0
    while (length(choose <- identify.rpart(tree)) >0 ) {
	if (ff$var[choose] == '<leaf>') {
		cat("Terminal node -- try again\n")
		next
		}

	if (choose != lastchoice) {
	    # print out some info on the click
	    cat("node number:", node[choose], " n=", ff$n[choose], "\n")
	    cat("    response=", format(ff$yval[choose]))
	    if (is.null(ff$yval2)) cat ("\n")
	    else if (is.matrix(ff$yval2)) 
		  cat(" (", format(ff$yval2[choose,]), ")\n")
	    else  cat(" (", format(ff$yval2[choose]), ")\n")
	    cat("    Error (dev) = ", format(ff$dev[choose]), "\n")
	    lastchoice <- choose
	    }
	else {
	    # second click-- erase all of the descendants
	    #   (stolen from snip.tree)
	    id  <- node[choose]
	    id2 <- node
	    while (any(id2>1)) {
		id2 <- floor(id2/2)
		temp  <- (match(id2, id, nomatch=0) >0)	
  	        id <- c(id, node[temp])
		id2[temp] <- 0
		}
	    temp <- match(id, node[ff$var != '<leaf>'], nomatch=0)
	    lines(c(draw$x[,temp]), c(draw$y[,temp]), col=0)
	    toss <- c(toss, node[choose])
	    }
	}
    toss
    }

identify.rpart <- function(x)
{
  xy <- treeco(x)
#  identify(xy$x, xy$y, n=1, plot=F)
  uin <- 1/xyinch()
  repeat{
    XY <- locator(1)
    if(is.null(XY)) return(NULL)
    else {
      ux <- xy$x
      uy <- xy$y
      xp <- XY$x
      yp <- XY$y
      d2 <- ((xp - ux) * uin[1])^2 + ((yp - uy) * uin[2])^2
      dist <- min(d2)
      indx <- if(dist > 0.25) 0 else seq(along=ux)[d2 == dist][1]
      if(!indx) {
        cat("No node close to point, try again\n")
      } else return(indx)
    }
  }
}
#SCCS @(#)snip.rpart.s	1.6 10/16/97
#
#  This routine "throws away" branches 
#
snip.rpart <- function(x, toss) {
    if (!inherits(x, 'rpart')) stop("Not an rpart object")

    if (missing(toss) || length(toss)==0) { 
        toss <- snip.rpart.mouse(x)
	if (length(toss)==0) return(x)
	}

    where <- x$where
    ff   <- x$frame
    id    <- as.numeric(row.names(ff))
    index <- ff$index
    ff.n  <- length(id)

    toss <- unique(toss)	
    toss.idx <- match(toss, id, nomatch=0) #the rows of the named nodes
    if (any(toss.idx ==0)) {
	warning(paste("Nodes", toss[toss.idx==0], "are not in this tree"))
	toss <- toss[toss.indx>0]
        toss.idx <- toss.idx[toss.idx>0]
        }

    if (any(toss==1))  {
	# a special case that causes grief later
	warning("Can't prune away the root node and still have a tree!")
        return(NULL)
	}

    # Now add all of the descendants of the selected nodes
    #   We do this be finding all node's parents. 
    #        (Division by 2 gives the parent of any node.) 
    #   At each step we make id2 <- parent(id2), and augment 'toss' with
    #     found children.  The loop should take <  log_2(maxdepth)/2 steps
    id2 <- id
    while (any(id2>1)) {
	id2 <- floor(id2/2)
	xx <- (match(id2, toss, nomatch=0) >0)
	toss <- c(toss, id[xx])
        id2[xx] <- 0
	}

    # Now "toss" contains all of the nodes that should not be splits
    temp <- match(floor(toss/2) , toss, nomatch=0)  #which are leaves?
    newleaf <- match(toss[temp==0], id)             # row numbers, leaves
    keepit <- (1:ff.n)[is.na(match(id,toss))]  # row numbers to be let be

    # Compute the parent row for each row in the splits structure
    #  Then "thin out" the splits and csplit components
    n.split <- rep((1:ff.n), ff$ncompete + ff$nsurrogate+ 1*(ff$var!='<leaf>'))
    split <- x$splits[match(n.split, keepit, nomatch=0) >0, ]
    temp <- split[,2] >1      #which rows point to categoricals?
    if (any(temp)) {
        x$csplit <- x$csplit[split[temp,4], , drop=F]
	split[temp,4] <- 1
        if(is.matrix(x$csplit)) split[temp,4] <- 1:nrow(x$csplit)
	}
    else x$csplit <- NULL
    x$splits <- split

    # Thin out unneeded rows in the frame component
    ff$ncompete[newleaf] <- ff$nsurrogate[newleaf] <- 0
    ff$var[newleaf]     <- "<leaf>"
    ff$splits[newleaf,] <- ""
    x$frame <- ff[sort(c(keepit, newleaf)),]

    # Now do the 'parents' loop one more time, to fix up the "where"
    #   vector
    # This pass requires log_2(depth) iterations
    #
    id2 <- id[x$where]         #the list of old leaf nodes
    id3 <- id[sort(c(keepit, newleaf))]
    temp <- match(id2, id3, nomatch=0)
    while (any(temp==0)) {
	id2[temp==0] <- floor(id2[temp==0]/2)
	temp <- match(id2, id3, nomatch=0)
	}
    x$where <- match(id2, id3)
   
    x	
    }
#SCCS  @(#)summary.rpart.s	1.9 02/12/98
summary.rpart <- function(x, cp=0, digits=.Options$digits-3,
			file,  ...) {
    if(!inherits(x, "rpart")) stop("Not legitimate rpart object")

     if (!missing(file)) {
	  sink(file)
	  on.exit(sink())
	  }

    if(!is.null(x$call)) {
        cat("Call:\n")
        dput(x$call)
        cat('\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)))

     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])
     cuts <- paste(cuts, ifelse(temp >=2, ",",
			 ifelse(temp==1, " to the right,", " to the left, ")),
			 sep = '')
     for (i in rows) {
	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="")

	if (x$method=='anova')
	    cat("  mean=", format(signif(ff$yval[i], digits)),
		" , SS/n=" , format(signif(ff$dev[i]/nn, digits)),"\n",
		sep = "")
	else if (x$method=='class') {
            if(!is.null(ylevel)) 
	       yval <- ylevel[ff$yval]
	    else
	       yval <- ff$yval
	    cat("  predicted class=", format(yval[i]),
		" expected loss=", format(signif(ff$dev[i]/nn, digits)),"\n",
		"    class counts: ", format(ff$yval2[i,]),"\n",
		"   probabilities: ", format(round(ff$yprob[i,], digits)),"\n")
	  }
	else if (x$method=='poisson'|x$method=='exp')
	    cat("  events=", format(ff$yval2[i]),
		",  estimated rate=" , format(signif(ff$yval[i], digits)),
		" , deviance/n=" , format(signif(ff$dev[i]/nn, digits)),"\n",
		sep = "")
	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>0) cat(", ", j, " observations remain\n", sep='')
	    else     cat("\n")
	    cat("  Primary splits:\n")
	    j <- seq(index[i], length=1+ff$ncompete[i])
	    cat(paste("      ", format(sname[j]), " ", cuts[j],
		      " 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=ff$nsurrogate[i])
		agree <- x$splits[j,3]
# I had to remove the "adjusted": to be correct the temp variable must be
#   based on "node->lastsurrogate", which is not retained in the S object
		temp  <- max(sons.n)/ nn
		cat(paste("      ", format(sname[j]), " ", cuts[j],
		      " agree=", format(signif(agree, digits)),
#                     ", adj=" , format(signif((agree-temp)/(1-temp), digits)),
		      ", (", x$splits[j,1], " split)", sep=''),
		      sep="\n")
		}
	    }
	}
    cat("\n")
    invisible(x)
    }
#sccs @(#)text.rpart.s	1.7 02/18/97
# This is a modification of text.tree.  
# Fancy option has been added in (to mimic post.tree)
#

text.rpart <-  function(x, splits = T, label = "yval", FUN = text, all=F,
		        pretty = NULL, digits = .Options$digits - 3, 
                        use.n=F, fancy=F, fwidth=.8, fheight =.8, ...)
{
  FUN1 <- function(x, y, lab,...){
    ind <- lab != "NA"
    FUN(x[ind], y[ind], lab[ind], ...)
  }
	if(!inherits(x, "rpart")) stop("Not legitimate rpart")
	frame <- x$frame
	col <- names(frame)
	method <- x$method
	ylevels <- attr(x,'ylevels')
	if(!is.null(ylevels <- attr(x, "ylevels")))
		col <- c(col, ylevels)
	if(is.na(match(label, col)))
		stop("Label must be a column label of the frame component of the tree"
			)
        charw <- diff(par("usr")[1:2])/ par("pin")[1]
        charht <- diff(par("usr")[3:4])/ par("pin")[2]
        if(!is.null(srt <- list(...)$srt) && srt == 90){
          cxy <- c(charw*par("cin")[2], charht*par("cin")[1])
        } else {
          cxy <- c(charw*par("cin")[1], charht*par("cin")[2])
        }
	xy <- rpartco(x)

        node <- as.numeric(row.names(x$frame))
        is.left <- (node%%2 ==0)        #left hand sons
        node.left <- node[is.left]
	parent <- match(node.left/2, node)

#Put left splits at the parent node

	if(splits) {
		left.child <- match(2 * node, node)
		right.child <- match(node * 2 + 1, node)
		rows <- labels(x, pretty = pretty)

		if(fancy) {
		  ## put split labels on branches instead of nodes

		  xytmp <- rpart.branch(x=xy$x,y=xy$y,node=node)
		  leftptx <- (xytmp$x[2,]+xytmp$x[1,])/2
		  leftpty <- (xytmp$y[2,]+xytmp$y[1,])/2
		  rightptx <- (xytmp$x[3,]+xytmp$x[4,])/2
		  rightpty <- (xytmp$y[3,]+xytmp$y[4,])/2

		  FUN1(leftptx,leftpty+.52*cxy[2],
		      rows[left.child[!is.na(left.child)]])
		  FUN1(rightptx,rightpty-.52*cxy[2],
		      rows[right.child[!is.na(right.child)]])
		}

		else FUN1(xy$x, xy$y + 0.5 * cxy[2], rows[left.child], ...)
	}
	leaves <- if(all) rep(T, nrow(frame)) else frame$var == "<leaf>"
        if(method=='class') { 
            if (label=='yval') stat <- ylevels[frame$yval[leaves]]
	    else  if(!is.na(lev <- match(label, ylevels)))
		stat <- format(signif(frame$yprob[leaves, lev],
				      digits = digits))
            else stat <- frame$yval[leaves]
            if(use.n) 
		  stat <- paste(stat,'\n','(',
			   apply(frame$yval2[leaves,], 1, paste, collapse='/'),
      			     ')', sep='') 
	      }
	else if(method=='anova') {
	    stat <- format(signif(frame[leaves, label], digits =digits))
            if(use.n) stat <-
	       paste(stat,'\n',' n=',frame$n[leaves], sep='')
	   }
	else if(method=='poisson'|method=='exp')
	  {
	   stat <- format(signif(frame[leaves, label], digits = digits))
	   if(use.n)
             { stat <-
	     paste(stat,'\n', frame$yval2[leaves],'/',frame$n[leaves], sep="")
	       }	    
     
	 }

        oval <- function(middlex,middley,a,b) {

             theta <- seq(0,2*pi,pi/30)
	     newx <- middlex + a*cos(theta)
	     newy <- middley + b*sin(theta)

	     polygon(newx,newy,border=T,col=0)
#	     polygon(newx,newy,border=T)
	   }
  
        rectangle <- function(middlex, middley,a,b) {

	  newx <- middlex + c(a,a,-a,-a)
	  newy <- middley + c(b,-b,-b,b)

	  polygon(newx,newy,border=T,col=0)
#	  polygon(newx,newy,border=T)
          }

        if(fancy) {

	        ## find maximum length of stat
	        maxlen <- max(string.bounding.box(stat)$columns) + 1
	        maxht <- max(string.bounding.box(stat)$rows) +1

		if(fwidth<1)  a.length <- fwidth*cxy[1]*maxlen
		else a.length <- fwidth*cxy[1]

		if(fheight<1) b.length <- fheight*cxy[2]*maxht
		else b.length <- fheight*cxy[2]
		
	        ### create ovals and rectangles here
		## sqrt(2) creates the smallest oval that fits around the
		## best fitting rectangle
		for(i in parent) oval(xy$x[i],xy$y[i],
  			          a=sqrt(2)*a.length/2, b=sqrt(2)*b.length/2)
		child <- match(node[frame$var=="<leaf>"],node)
		for(i in child) rectangle(xy$x[i],xy$y[i],
				  a=a.length/2,b=b.length/2)
	      }

#if FUN=text then adj=1 puts the split label to the left of the 
#    split rather than centered
#Allow labels at all or just leaf nodes

	## stick values on nodes
	if(fancy) FUN(xy$x[leaves], xy$y[leaves] + .5 * cxy[2], stat, ...)
	else FUN(xy$x[leaves], xy$y[leaves] - 0.5 * cxy[2], stat, adj=.5, ...)

	invisible()
}



# SCCS @(#)xpred.rpart.s	1.13 02/18/97
#
#  Get a set of cross-validated predictions
#

xpred.rpart <- function(fit, xval=10, cp) {
    if (!inherits(fit, 'rpart')) stop("Invalid fit object")

    method <- fit$method
    method.int <- pmatch(method, c("anova", "poisson", "class", "exp"))
    if (method.int==4) method.int <- 2
    Terms <- fit$terms

    Y <- fit$y
    X <- fit$x
    if (is.null(Y) || is.null(X)) {
	m <- fit$model
	if (is.null(m)) {
	    m <-fit$call[match(c("", 'formula', 'data', 'weights', 'subset',
					 'na.action'),
				names(fit$call), nomatch=0)]
	    if (is.null(m$na.action)) m$na.action<- na.rpart
	    m[[1]] <- as.name("model.frame.default")
	    m <- eval(m, sys.frame(sys.parent()))
	    }
	if (is.null(X)) X <- rpart.matrix(m)
	if (is.null(Y)) {
	    Y <- model.extract(m, "response")
            offset <- attr(Terms, "offset")
	    init <- (get(paste("rpart", method, sep='.')))(Y,offset, NULL)
	    Y <- init$y
	    }
	}

    Y <- as.matrix(Y)
    nobs <- nrow(Y)

    cats <- rep(0, ncol(X))
    xlevels <- attr(fit, "xlevels")
    if (!is.null(xlevels)){
        cats[as.numeric(names(xlevels))] <- unlist(lapply(xlevels, length))
        }

    controls <- fit$control
    if (missing(cp)) {
	cp<- fit$cptable[,1]
	cp <- sqrt(cp * c(1, cp[-length(cp)]))
	}
    ncp <- length(cp)

    if (length(xval)==1) {
	# make random groups
	xgroups <- sample(rep(1:xval, length=nobs), nobs, replace=F)
	}
    else if (length(xval) == nrow(Y)) {
	xgroups <- xval
	xval <- length(unique(xgroups))
	}
    else stop("Invalid value for xval")

    rpfit <- .C("s_xpred",
		    n = as.integer(nobs),
		    nvarx = as.integer(ncol(X)),
		    ncat = as.integer(cats),
		    method= as.integer(method.int),
		    as.double(unlist(controls)),
		    parms = as.double(fit$parms),
		    as.integer(xval),
		    as.integer(xgroups),
		    as.double(t(Y)),
		    as.double(X),
		    as.integer(is.na(X)),
		    pred = double(ncp* nobs),
		    as.integer(ncp),
		    as.double(cp * fit$frame[1,"dev"]),
		    error = character(1),
		    NAOK=T )
    if (rpfit$n == -1)  stop(rpfit$error)

    matrix(rpfit$pred, ncol=ncp, byrow=T,
		dimnames=list(dimnames(X)[[1]], format(cp)) )
    }
.First.lib <- function(lib, pkg) library.dynam("rpart", pkg, lib)

if(version$major == "0" && version$minor < "0.63")
  labels <- function(object, ...) UseMethod("labels")

is.Surv <- function(x) inherits(x, "Surv")

tree.depth <- function (nodes) 
{
  depth <- floor(log(nodes, base = 2) + 1e-7)
  as.vector(depth - min(depth))
}

string.bounding.box <- function(s)
{
  s2 <- strsplit(s, "\n")
  rows <- sapply(s2, length)
  columns <- sapply(s2, function(x) max(nchar(x)))
  list(columns=columns, rows=rows)
}
