# $Id$

## utility functions for querying the number of

## terminal nodes and the maximal depth of (sub-)trees

nterminal <- function(node) {

    if (node$terminal) return(1)

    nl <- nterminal(node$left)

    nr <- nterminal(node$right)

    return(nl + nr)

}

maxdepth <- function(node) {

    if (node$terminal) return(1)

    nl <- maxdepth(node$left)

    nr <- maxdepth(node$right)

    return(max(c(nl, nr)) + 1)

}

## panel functions for labeling trees:

## inner and terminal nodes and edges.

node_inner <- function(ctreeobj,

                       digits = 3,

               abbreviate = FALSE,

               fill = "white",

               pval = TRUE,

               id = TRUE)

{

    getLabel1 <- function(x) {

        if (x$terminal) return(rep.int("", 2))

        varlab <- ifelse(abbreviate > 0,

            abbreviate(x$psplit$variableName, as.numeric(abbreviate)),

        x$psplit$variableName)

    if(pval) {

            pvalue <- 1 - x$criterion$maxcriterion

            plab <- ifelse(pvalue < 10^(-digits),

                           paste("p <", 10^(-digits)),

                           paste("p =", round(pvalue, digits = digits)))

    } else {

        plab <- ""

    }

        return(c(varlab, plab))

    }

    maxstr <- function(node) {

        lab <- getLabel1(node)

        msl <- ifelse(node$terminal, "", maxstr(node$left))

        msr <- ifelse(node$terminal, "", maxstr(node$right))

        lab <- c(lab, msl, msr)

        return(lab[which.max(nchar(lab))])

    }

    nstr <- maxstr(ctreeobj@tree) 

    ### panel function for the inner nodes

    rval <- function(node) {

        node_vp <- viewport(x = unit(0.5, "npc"),

                        y = unit(0.5, "npc"),

                        width = unit(1, "strwidth", nstr) * 1.3, 

                        height = unit(3, "lines"),

                name = paste("node_inner", node$nodeID, sep = ""))

        pushViewport(node_vp)

        xell <- c(seq(0, 0.2, by = 0.01),

              seq(0.2, 0.8, by = 0.05),

          seq(0.8, 1, by = 0.01))

    yell <- sqrt(xell * (1-xell))

    lab <- getLabel1(node)

    fill <- rep(fill, length.out = 2)

        grid.polygon(x = unit(c(xell, rev(xell)), "npc"),

                     y = unit(c(yell, -yell)+0.5, "npc"),

                     gp = gpar(fill = fill[1]))

        grid.text(lab[1], y = unit(1.5 + 0.5 * pval, "lines"))

        if(pval) grid.text(lab[2], y = unit(1, "lines"))

        if (id) {

            nodeIDvp <- viewport(x = unit(0.5, "npc"), y = unit(1, "npc"),

            width = max(unit(1, "lines"), unit(1.3, "strwidth", as.character(node$nodeID))),

            height = max(unit(1, "lines"), unit(1.3, "strheight", as.character(node$nodeID))))

            pushViewport(nodeIDvp)

            grid.rect(gp = gpar(fill = fill[2]))

            grid.text(node$nodeID)

            popViewport()

        }

        upViewport()

    }

    return(rval)

}

class(node_inner) <- "grapcon_generator"

node_surv <- function(ctreeobj,

              ylines = 2,

              id = TRUE, ...)

{

    survobj <- response(ctreeobj)[[1]]

    if (!("Surv" %in% class(survobj))) 

        stop(sQuote("ctreeobj"), " is not a survival tree")

    ### panel function for Kaplan-Meier curves in nodes

    rval <- function(node) {

        km <- mysurvfit(survobj, weights = node$weights, ...)

        a <- dostep(km$time, km$surv)

        yscale <- c(0,1)

        xscale <- c(0, max(survobj[,1]))

        top_vp <- viewport(layout = grid.layout(nrow = 2, ncol = 3,

                           widths = unit(c(ylines, 1, 1), 

                                         c("lines", "null", "lines")),  

                           heights = unit(c(1, 1), c("lines", "null"))),

                           width = unit(1, "npc"), 

                           height = unit(1, "npc") - unit(2, "lines"),

               name = paste("node_surv", node$nodeID, sep = ""))

        pushViewport(top_vp)

        grid.rect(gp = gpar(fill = "white", col = 0))

        ## main title

        top <- viewport(layout.pos.col=2, layout.pos.row=1)

        pushViewport(top)

    mainlab <- paste(ifelse(id, paste("Node", node$nodeID, "(n = "), "n = "),

                     sum(node$weights), ifelse(id, ")", ""), sep = "")

        grid.text(mainlab)

        popViewport()

        plot <- viewport(layout.pos.col=2, layout.pos.row=2,

                         xscale=xscale, yscale=yscale,

             name = paste("node_surv", node$nodeID, "plot", 

                         sep = ""))

        pushViewport(plot)

        grid.lines(a$x/max(survobj[,1]), a$y)

        grid.xaxis()

        grid.yaxis()

        grid.rect(gp = gpar(fill = "transparent"))

        upViewport(2)

    }

    return(rval)

}

class(node_surv) <- "grapcon_generator"

node_barplot <- function(ctreeobj,

                         col = "black",

                     fill = NULL,

             beside = NULL,

                 ymax = NULL,

                 ylines = NULL,

                 widths = 1,

                 gap = NULL,

             reverse = NULL,

                 id = TRUE)

{   

    getMaxPred <- function(x) {

      mp <- max(x$prediction)

      mpl <- ifelse(x$terminal, 0, getMaxPred(x$left))

      mpr <- ifelse(x$terminal, 0, getMaxPred(x$right))

      return(max(c(mp, mpl, mpr)))

    }

    y <- response(ctreeobj)[[1]]

    if(is.factor(y) || class(y) == "was_ordered") {

        ylevels <- levels(y)

    if(is.null(beside)) beside <- if(length(ylevels) < 3) FALSE else TRUE

        if(is.null(ymax)) ymax <- if(beside) 1.1 else 1

    if(is.null(gap)) gap <- if(beside) 0.1 else 0

    } else {

        if(is.null(beside)) beside <- FALSE

        if(is.null(ymax)) ymax <- getMaxPred(ctreeobj@tree) * 1.1

        ylevels <- seq(along = ctreeobj@tree$prediction)

        if(length(ylevels) < 2) ylevels <- ""

    if(is.null(gap)) gap <- 1

    }

    if(is.null(reverse)) reverse <- !beside

    if(is.null(fill)) fill <- gray.colors(length(ylevels))

    if(is.null(ylines)) ylines <- if(beside) c(3, 2) else c(1.5, 2.5)

    ### panel function for barplots in nodes

    rval <- function(node) {

        ## parameter setup

        pred <- node$prediction

    if(reverse) {

      pred <- rev(pred)

      ylevels <- rev(ylevels)

    }

        np <- length(pred)

    nc <- if(beside) np else 1

    fill <- rep(fill, length.out = np)  

        widths <- rep(widths, length.out = nc)

    col <- rep(col, length.out = nc)

    ylines <- rep(ylines, length.out = 2)

    gap <- gap * sum(widths)

        yscale <- c(0, ymax)

        xscale <- c(0, sum(widths) + (nc+1)*gap)

        top_vp <- viewport(layout = grid.layout(nrow = 2, ncol = 3,

                           widths = unit(c(ylines[1], 1, ylines[2]), c("lines", "null", "lines")),

                           heights = unit(c(1, 1), c("lines", "null"))),

                           width = unit(1, "npc"), 

                           height = unit(1, "npc") - unit(2, "lines"),

               name = paste("node_barplot", node$nodeID, sep = ""))

        pushViewport(top_vp)

        grid.rect(gp = gpar(fill = "white", col = 0))

        ## main title

        top <- viewport(layout.pos.col=2, layout.pos.row=1)

        pushViewport(top)

    mainlab <- paste(ifelse(id, paste("Node", node$nodeID, "(n = "), "n = "),

                     sum(node$weights), ifelse(id, ")", ""), sep = "")

        grid.text(mainlab)

        popViewport()

        plot <- viewport(layout.pos.col=2, layout.pos.row=2,

                         xscale=xscale, yscale=yscale,

             name = paste("node_barplot", node$nodeID, "plot", 

                         sep = ""))

        pushViewport(plot)

    if(beside) {

      xcenter <- cumsum(widths+gap) - widths/2

      for (i in 1:np) {

            grid.rect(x = xcenter[i], y = 0, height = pred[i], 

                      width = widths[i],

                  just = c("center", "bottom"), default.units = "native",

                  gp = gpar(col = col[i], fill = fill[i]))

      }

          if(length(xcenter) > 1) grid.xaxis(at = xcenter, label = FALSE)

      grid.text(ylevels, x = xcenter, y = unit(-1, "lines"), 

                    just = c("center", "top"),

                default.units = "native", check.overlap = TRUE)

          grid.yaxis()

    } else {

      ycenter <- cumsum(pred) - pred

      for (i in 1:np) {

            grid.rect(x = xscale[2]/2, y = ycenter[i], height = min(pred[i], ymax - ycenter[i]), 

                      width = widths[1],

                  just = c("center", "bottom"), default.units = "native",

                  gp = gpar(col = col[i], fill = fill[i]))

      }

          if(np > 1) {

        grid.text(ylevels[1], x = unit(-1, "lines"), y = 0,

                      just = c("left", "center"), rot = 90,

                  default.units = "native", check.overlap = TRUE)

        grid.text(ylevels[np], x = unit(-1, "lines"), y = ymax,

                      just = c("right", "center"), rot = 90,

                  default.units = "native", check.overlap = TRUE)

      }

          if(np > 2) {

        grid.text(ylevels[-c(1,np)], x = unit(-1, "lines"), y = ycenter[-c(1,np)],

                      just = "center", rot = 90,

                  default.units = "native", check.overlap = TRUE)

      }

          grid.yaxis(main = FALSE)  

    }

        grid.rect(gp = gpar(fill = "transparent"))

        upViewport(2)

    }

    return(rval)

}

class(node_barplot) <- "grapcon_generator"

node_boxplot <- function(ctreeobj,

                         col = "black",

                 fill = "lightgray",

                 width = 0.5,

                 yscale = NULL,

                 ylines = 3,

             cex = 0.5,

                 id = TRUE)

{

    y <- response(ctreeobj)[[1]]

    if (!is.numeric(y))

        stop(sQuote("ctreeobj"), " is not a regression tree")

    if (is.null(yscale)) 

        yscale <- range(y) + c(-0.1, 0.1) * diff(range(y))

    ### panel function for boxplots in nodes

    rval <- function(node) {

        ## parameter setup

    x <- boxplot(rep.int(y, node$weights), plot = FALSE)

        top_vp <- viewport(layout = grid.layout(nrow = 2, ncol = 3,

                           widths = unit(c(ylines, 1, 1), 

                                         c("lines", "null", "lines")),  

                           heights = unit(c(1, 1), c("lines", "null"))),

                           width = unit(1, "npc"), 

                           height = unit(1, "npc") - unit(2, "lines"),

               name = paste("node_boxplot", node$nodeID, sep = ""))

        pushViewport(top_vp)

        grid.rect(gp = gpar(fill = "white", col = 0))

        ## main title

        top <- viewport(layout.pos.col=2, layout.pos.row=1)

        pushViewport(top)

    mainlab <- paste(ifelse(id, paste("Node", node$nodeID, "(n = "), "n = "),

                     sum(node$weights), ifelse(id, ")", ""), sep = "")

        grid.text(mainlab)

        popViewport()

        plot <- viewport(layout.pos.col = 2, layout.pos.row = 2,

                         xscale = c(0, 1), yscale = yscale,

             name = paste("node_boxplot", node$nodeID, "plot", 

                         sep = ""))

        pushViewport(plot)

    xl <- 0.5 - width/4

    xr <- 0.5 + width/4

        ## box & whiskers

        grid.lines(unit(c(xl, xr), "npc"), 

                   unit(x$stats[1], "native"), gp = gpar(col = col))

        grid.lines(unit(0.5, "npc"), 

                   unit(x$stats[1:2], "native"), gp = gpar(col = col, lty = 2))

        grid.rect(unit(0.5, "npc"), unit(x$stats[2], "native"), 

                  width = unit(width, "npc"), height = unit(diff(x$stats[c(2, 4)]), "native"),

                  just = c("center", "bottom"), 

                  gp = gpar(col = col, fill = fill))

        grid.lines(unit(c(0.5 - width/2, 0.5+width/2), "npc"), 

                   unit(x$stats[3], "native"), gp = gpar(col = col, lwd = 2))

        grid.lines(unit(0.5, "npc"), unit(x$stats[4:5], "native"), 

                   gp = gpar(col = col, lty = 2))

        grid.lines(unit(c(xl, xr), "npc"), unit(x$stats[5], "native"), 

                   gp = gpar(col = col))

        ## outlier

        n <- length(x$out)

        if (n > 0) {

            index <- 1:n ## which(x$out > yscale[1] & x$out < yscale[2])

            if (length(index) > 0)

                grid.points(unit(rep.int(0.5, length(index)), "npc"), 

                            unit(x$out[index], "native"),

                            size = unit(cex, "char"), gp = gpar(col = col))

        }

        grid.yaxis()

        grid.rect(gp = gpar(fill = "transparent"))

        upViewport(2)

    }

    return(rval)

}

class(node_boxplot) <- "grapcon_generator"

node_hist <- function(ctreeobj,

                      col = "black",

              fill = "lightgray",

              freq = FALSE,

              horizontal = TRUE,

              xscale = NULL,

              ymax = NULL,

              ylines = 3,

              id = TRUE,

              ...)

{

    y <- response(ctreeobj)[[1]]

    if (!is.numeric(y))

        stop(sQuote("ctreeobj"), " is not a regression tree")

    y <- rep.int(y, ctreeobj@tree$weights)

    yhist <- hist(y, plot = FALSE, ...)

    if (is.null(xscale)) 

        xscale <- range(yhist$breaks) + 

                        c(-0.05, 0.05) * diff(range(yhist$breaks))

    if (is.null(ymax)) {

        if (is.null(ymax)) 

            ymax <- if (freq) 0.7 * max(yhist$counts) 

                else 2.5 * max(yhist$density)

    }

    yscale <- c(0, ymax)

    if (horizontal) {

        yyy <- xscale

        xscale <- yscale

        yscale <- yyy

    }

    ### panel function for histograms in nodes

    rval <- function(node) {

        ## parameter setup

    yhist <- hist(rep.int(y, node$weights), plot = FALSE, ...)

        top_vp <- viewport(layout = grid.layout(nrow = 2, ncol = 3,

                           widths = unit(c(ylines, 1, 1), 

                                         c("lines", "null", "lines")),  

                           heights = unit(c(1, 1), c("lines", "null"))),

                           width = unit(1, "npc"), 

                           height = unit(1, "npc") - unit(2, "lines"),

               name = paste("node_hist", node$nodeID, sep = ""))

        pushViewport(top_vp)

        grid.rect(gp = gpar(fill = "white", col = 0))

        ## main title

        top <- viewport(layout.pos.col=2, layout.pos.row=1)

        pushViewport(top)

    mainlab <- paste(ifelse(id, paste("Node", node$nodeID, "(n = "), "n = "),

                     sum(node$weights), ifelse(id, ")", ""), sep = "")

        grid.text(mainlab)

        popViewport()

        plot <- viewport(layout.pos.col = 2, layout.pos.row = 2,

                         xscale = xscale, yscale = yscale,

             name = paste("node_hist", node$nodeID, "plot", 

                         sep = ""))

        pushViewport(plot)

        ## histogram

        xpos <- yhist$breaks[-1]

    ypos <- 0

    yheight <- if (freq) yhist$counts else yhist$density

    xwidth <- diff(yhist$breaks)

        if (horizontal) {

              yyy <- xpos

              xpos <- ypos

              ypos <- yyy

              yyy <- xwidth

              xwidth <- -yheight

              yheight <- yyy

        }

    grid.rect(x = xpos, y = ypos,

              width = xwidth, height = yheight,

          just = c("right", "bottom"), default.units = "native",

          gp = gpar(col = col, fill = fill))

        grid.xaxis()

        grid.yaxis()

        grid.rect(gp = gpar(fill = "transparent"))

        upViewport(2)

    }

    return(rval)

}

class(node_hist) <- "grapcon_generator"

node_density <- function(ctreeobj,

                         col = "black",

                 rug = TRUE,

                 horizontal = TRUE,

                 xscale = NULL,

                 yscale = NULL,

                 ylines = 3,

                 id = TRUE)

{

    y <- response(ctreeobj)[[1]]

    if (!is.numeric(y))

        stop(sQuote("ctreeobj"), " is not a regression tree")

    y <- rep.int(y, ctreeobj@tree$weights)

    ydens <- density(y)

    if (is.null(xscale)) 

        xscale <- range(ydens$x) + c(-0.05, 0.05) * diff(range(ydens$x))

    if (is.null(yscale)) {

        ymin <- if (rug) -max(ydens$y) * 0.1 else 0    

        yscale <- c(ymin, max(ydens$y) * 2.5)

    }

    xr <- xscale

    yr <- 0

    if (horizontal) {

        yyy <- xscale

        xscale <- yscale

        yscale <- yyy

    }

    ### panel function for density plots in nodes

    rval <- function(node) {

        ## parameter setup

    ydens <- density(rep.int(y, node$weights))

        top_vp <- viewport(layout = grid.layout(nrow = 2, ncol = 3,

                           widths = unit(c(ylines, 1, 1), 

                                         c("lines", "null", "lines")),  

                           heights = unit(c(1, 1), c("lines", "null"))),

                           width = unit(1, "npc"), 

                           height = unit(1, "npc") - unit(2, "lines"),

               name = paste("node_density", node$nodeID, sep = ""))

        pushViewport(top_vp)

        grid.rect(gp = gpar(fill = "white", col = 0))

        ## main title

        top <- viewport(layout.pos.col=2, layout.pos.row=1)

        pushViewport(top)

    mainlab <- paste(ifelse(id, paste("Node", node$nodeID, "(n = "), "n = "),

                     sum(node$weights), ifelse(id, ")", ""), sep = "")

        grid.text(mainlab)

        popViewport()

        plot <- viewport(layout.pos.col = 2, layout.pos.row = 2,

                         xscale = xscale, yscale = yscale,

             name = paste("node_density", node$nodeID, "plot", 

                         sep = ""))

        pushViewport(plot)

        ## density

        yd <- ydens$y

    xd <- ydens$x

        if (horizontal) {

            yyy <- xd

            xd <- yd

            yd <- yyy

            yyy <- xr

            xr <- yr

            yr <- yyy

        }

    if (rug) {

            if (horizontal)

            grid.rect(x = xscale[1], y = y[node$weights > 0],

                      height = 0, width = xscale[1],

                  default.units = "native", 

                          just = c("right", "bottom"))

            else

                grid.rect(x = y[node$weights > 0], y = yscale[1],

                      width = 0, height = abs(yscale[1]),

                  default.units = "native", 

                          just = c("center", "bottom"))

            grid.lines(x = xr, y = yr, gp = gpar(col = "lightgray"), 

                       default.units = "native")

            grid.lines(x = xr, y = yr, gp = gpar(col = "lightgray"), 

                       default.units = "native")

    }

    grid.lines(x = xd, y = yd, default.units = "native",

           gp = gpar(col = col))

        grid.xaxis()

        grid.yaxis()

        grid.rect(gp = gpar(fill = "transparent"))

        upViewport(2)

    }

    return(rval)

}

class(node_density) <- "grapcon_generator"

node_terminal <- function(ctreeobj,

                          digits = 3,

                  abbreviate = FALSE,

                  fill = c("lightgray", "white"),

                  id = TRUE)

{

    getLabel1 <- function(x) {

        if (!x$terminal) return(rep.int("", 2))

        nlab <- paste("n =", sum(x$weights))

        ylab <- if (length(x$prediction) > 1)

                    paste("y =", paste("(", paste(round(x$prediction, digits),

                  collapse = ", "), ")", sep =""))

                else

                paste("y =", round(x$prediction, digits))

      return(c(nlab, ylab))

    }

    maxstr <- function(node) {

        lab <- getLabel1(node)

        msl <- ifelse(node$terminal, "", maxstr(node$left))

        msr <- ifelse(node$terminal, "", maxstr(node$right))

        lab <- c(lab, msl, msr)

        return(lab[which.max(nchar(lab))])

    }

    nstr <- maxstr(ctreeobj@tree)

    ### panel function for simple n, Y terminal node labelling

    rval <- function(node) {

        fill <- rep(fill, length.out = 2)   

        node_vp <- viewport(x = unit(0.5, "npc"),   

                       y = unit(0.5, "npc"),   

                       width = unit(1, "strwidth", nstr) * 1.1,

                       height = unit(3, "lines"),

               name = paste("node_terminal", node$nodeID, sep = ""))

        pushViewport(node_vp)

        lab <- getLabel1(node)

        grid.rect(gp = gpar(fill = fill[1]))

        grid.text(y = unit(2, "lines"), lab[1])

        grid.text(y = unit(1, "lines"), lab[2])

        if (id) {

            nodeIDvp <- viewport(x = unit(0.5, "npc"), y = unit(1, "npc"),

            width = max(unit(1, "lines"), unit(1.3, "strwidth", as.character(node$nodeID))),

            height = max(unit(1, "lines"), unit(1.3, "strheight", as.character(node$nodeID))))

            pushViewport(nodeIDvp)

            grid.rect(gp = gpar(fill = fill[2], lty = "solid"))

            grid.text(node$nodeID)

            popViewport()

    }

        upViewport()

    }

    return(rval)

}

class(node_terminal) <- "grapcon_generator"

edge_simple <- function(treeobj, digits = 3, abbreviate = FALSE)

{

    ### panel function for simple edge labelling

    function(split, ordered = FALSE, left = TRUE) {

        if (is.numeric(split)) 

            split <- round(split, digits = digits)

        if (is.character(split) & abbreviate > 0) 

            split <- abbreviate(split, as.numeric(abbreviate))

        if (!ordered) {

            if (length(split) > 1) 

                split <- paste("{", paste(split, collapse = ", "), 

                               "}", sep="")

        } else {

            ### <FIXME> phantom and . functions cannot be found by

            ###         codetools

            ### </FIXME>

            if (left) split <- as.expression(bquote(phantom(0) <= .(split)))

                else split <- as.expression(bquote(phantom(0) > .(split)))

        }

        grid.rect(gp = gpar(fill = "white", col = 0), 

                  width = unit(1, "strwidth", split)) 

        grid.text(split, just = "center")

    }

}

class(edge_simple) <- "grapcon_generator"

plotTree <- function(node, xlim, ylim, nx, ny, 

               terminal_panel, inner_panel, edge_panel,

           tnex = 2, drop_terminal = TRUE, debug = FALSE) {

    ### the workhorse for plotting trees

    ### set up viewport for terminal node

    if (node$terminal) {

        x <- xlim[1] + diff(xlim)/2

        y <- ylim[1] + 0.5

        tn_vp <- viewport(x = unit(x, "native"),

                          y = unit(y, "native") - unit(0.5, "lines"),

                          width = unit(1, "native"), 

                          height = unit(tnex, "native") - unit(1, "lines"),

              just = c("center", "top"),

                          name = paste("Node", node$nodeID, sep = ""))

        pushViewport(tn_vp)

        if (debug)

            grid.rect(gp = gpar(lty = "dotted", col = 4))

        terminal_panel(node) 

        upViewport()

        return(NULL)

    }    

    ### number of left leafs

    nl <- nterminal(node$left)

    ### number of right leafs

    nr <- nterminal(node$right)

    ### position of inner node

    x0 <- xlim[1] + (nl / (nl + nr)) * diff(xlim)

    y0 <- max(ylim)

    ### proportion of left terminal nodes in left node

    if (node$left$terminal) {

        lf <- 1/2

    } else {

        lf <- nterminal(node$left$left) / (nterminal(node$left$left) + 

                                           nterminal(node$left$right))

    }

    ### proportion of left terminal nodes in right node

    if (node$right$terminal) {

        rf <- 1/2

    } else {

        rf <- nterminal(node$right$left) / (nterminal(node$right$left) + 

                                            nterminal(node$right$right))

    }

    ### position of left and right daugher node

    x1l <- xlim[1] + (x0 - xlim[1]) * lf

    x1r <- x0 + (xlim[2] - x0) * rf

    if (!drop_terminal) {

        y1l <- y1r <- y0 - 1

    } else {

        y1l <- if (node$left$terminal) tnex - 0.5 else y0 - 1

        y1r <- if (node$right$terminal) tnex - 0.5 else y0 - 1

    }

    ### draw edges

    grid.lines(x = unit(c(x0, x1l), "native"), 

               y = unit(c(y0, y1l), "native"))

    grid.lines(x = unit(c(x0, x1r), "native"), 

               y = unit(c(y0, y1r), "native"))

    ### create viewport for inner node

    in_vp <- viewport(x = unit(x0, "native"),

                      y = unit(y0, "native"),

                      width = unit(1, "native"),

                      height = unit(1, "native") - unit(1, "lines"), 

                      name = paste("Node", node$nodeID, sep = ""))

    pushViewport(in_vp)

    if (debug)

        grid.rect(gp = gpar(lty = "dotted"))

    inner_panel(node)

    upViewport()

    ps <- node$psplit

    if (ps$ordered) {

        if (!is.null(attr(ps$splitpoint, "levels"))) {

            split <- attr(ps$splitpoint, "levels")[ps$splitpoint]

        } else {

            split <- ps$splitpoint

        }

    } else {

        ### <FIXME>: always to the left? </FIXME>

        split <- attr(ps$splitpoint, "levels")[as.logical(ps$splitpoint) & (ps$table > 0)]

    }

    ### position of labels

    y1lr <- max(y1l, y1r)

    ypos <- y0 - (y0 - y1lr) * 0.5

    xlpos <- x0 - (x0 - x1l) * 0.5 * (y0 - y1lr)/(y0 - y1l)

    xrpos <- x0 - (x0 - x1r) * 0.5 * (y0 - y1lr)/(y0 - y1r)

    ### setup left label

    lsp_vp <- viewport(x = unit(xlpos, "native"),

                       y = unit(ypos, "native"),

                       width = unit(xlpos - xrpos, "native"),

                       height = unit(1, "lines"), 

                       name =  paste("lEdge", node$nodeID, sep = ""))

    pushViewport(lsp_vp)

    if (debug)

        grid.rect(gp = gpar(lty = "dotted", col = 2))

    edge_panel(split, ordered = ps$ordered, left = TRUE)

    upViewport()

    ### setup right label

    if (ps$ordered) {

        if (!is.null(attr(ps$splitpoint, "levels"))) {

            split <- attr(ps$splitpoint, "levels")[ps$splitpoint]

        } else {

            split <- ps$splitpoint

        }

    } else {

        split <- attr(ps$splitpoint, "levels")[!as.logical(ps$splitpoint) & (ps$table > 0)]

    }

    rsp_vp <- viewport(x = unit(xrpos, "native"),

                       y = unit(ypos, "native"),

                       width = unit(xlpos - xrpos, "native"),

                       height = unit(1, "lines"),

                       name =  paste("rEdge", node$nodeID, sep = ""))

    pushViewport(rsp_vp) 

    if (debug)

        grid.rect(gp = gpar(lty = "dotted", col = 2))

    edge_panel(split, ordered = ps$ordered, left = FALSE)

    upViewport()

    plotTree(node$left, c(xlim[1], x0), c(y1l, 1), nx, ny, 

      terminal_panel, inner_panel, edge_panel,

      tnex = tnex, drop_terminal = drop_terminal, debug = debug)

    plotTree(node$right, c(x0, xlim[2]), c(y1r, 1), nx, ny,

      terminal_panel, inner_panel, edge_panel,

      tnex = tnex, drop_terminal = drop_terminal, debug = debug)

}

plot.BinaryTree <- function(x, main = NULL, type = c("extended", "simple"),

                            terminal_panel = NULL, tp_args = list(),

                inner_panel = node_inner, ip_args = list(),

                            edge_panel = edge_simple, ep_args = list(),

                drop_terminal = (type[1] == "extended"),

                tnex = (type[1] == "extended") + 1, 

                newpage = TRUE,

                pop = TRUE,

                ...) {

    ### plot BinaryTree objects

    ### extract tree

    ptr <- x@tree

    ### total number of terminal nodes

    nx <- nterminal(ptr)

    ### maximal depth of the tree

    ny <- maxdepth(ptr)

    ### compute default settings

    type <- match.arg(type)

    if (type == "simple") {

        if (is.null(terminal_panel)) 

            terminal_panel <- node_terminal

        if (is.null(tnex)) tnex <- 1

    } else {

        if (is.null(terminal_panel))

            terminal_panel <- switch(class(response(x)[[1]])[1],

                                 "Surv" = node_surv,

                                     "factor" = node_barplot,

                                     "was_ordered" = node_barplot,

                                     "ordered" = node_barplot,

                                     node_boxplot)

        if (is.null(tnex)) tnex <- 2

    }

    ## setup newpage

    if (newpage) grid.newpage()

    ## setup root viewport

    root_vp <- viewport(layout = grid.layout(3, 3, 

                heights = unit(c(ifelse(is.null(main), 0, 3), 1, 1), 

                                      c("lines", "null", "lines")),

                widths = unit(c(1, 1, 1), 

                                     c("lines", "null", "lines"))), 

                name = "root")       

    pushViewport(root_vp)

    ## viewport for main title (if any)

    if (!is.null(main)) {

        main_vp <- viewport(layout.pos.col = 2, layout.pos.row = 1, 

                            name = "main")

        pushViewport(main_vp)

        grid.text(y = unit(1, "lines"), main, just = "center")

        upViewport()

    }

    ## setup viewport for tree

    tree_vp <- viewport(layout.pos.col = 2, layout.pos.row = 2, 

                xscale = c(0, nx), yscale = c(0, ny + (tnex - 1)), 

                        name = "tree")

    pushViewport(tree_vp)

    ### setup panel functions (if necessary)

    ### the heuristic is as follows: If the first argument

    ### is `ctreeobj' than we assume a panel generating function, 

    ### otherwise the function is treated as a panel function

    if(inherits(terminal_panel, "grapcon_generator"))

      terminal_panel <- do.call("terminal_panel", c(list(x), as.list(tp_args)))

    if(inherits(inner_panel, "grapcon_generator"))

      inner_panel <- do.call("inner_panel", c(list(x), as.list(ip_args)))

    if(inherits(edge_panel, "grapcon_generator"))

      edge_panel <- do.call("edge_panel", c(list(x), as.list(ep_args)))

    if((nx <= 1 & ny <= 1)) {

      pushViewport(plotViewport(margins = rep(1.5, 4), name = paste("Node", ptr$nodeID, sep = "")))

      terminal_panel(ptr)    

    } else {

      ## call the workhorse

      plotTree(ptr,

        xlim = c(0, nx), ylim = c(0, ny - 0.5 + (tnex - 1)),

        nx = nx, ny = ny, 

        terminal_panel = terminal_panel,

        inner_panel = inner_panel,

        edge_panel = edge_panel,

        tnex = tnex,

        drop_terminal = drop_terminal,

        debug = FALSE)

    }

    upViewport()

    if (pop) popViewport() else upViewport()

}