R/renderGraph.R

In kasperdanielhansen/Rgraphviz: Provides plotting capabilities for R graph objects

## Mechanism to draw render information from a graph or from the
## defaults if not specified in the graph. The hierarchy is:
##   1. graph package defaults as set by graph.par
##   2. graph object defaults set by parRenderInfo in the renderInfo@pars slot
##   3. node or edge specific settings set by edgeRenderInfo or nodeRenderInfo
##      in slots renderInfo@edges and renderInfo@nodes
getRenderPar <-
    function(g, name, what = c("nodes", "edges", "graph"))
{
    what <- match.arg(what)
    nms <- switch(what, nodes=nodes(g),
                  edges=edgeNames(g, recipEdges=graphRenderInfo(g,
                                     "recipEdges")),
                  graph="graph") #FIXME: Deal with graph names 
    ans <- switch(what,
                  nodes = nodeRenderInfo(g, name), 
                  edges = edgeRenderInfo(g, name),
                  graph = graphRenderInfo(g, name))
    if (!is.null(ans) && !any(is.na(ans))){
        if(!is.null(names(ans)))
            ans <- ans[nms]
    }else{
        default <- parRenderInfo(g, what)[[name]][1]
        if (is.null(default)) default <- graph.par.get(what)[[name]][1]
        if (is.null(ans)){
            ans <- rep(default, length(nms))
        }else{
            if(!is.null(default))
                ans[is.na(ans)] <- default
            ans <- ans[nms]
        }
    }
    ans
}

## This function will plot individual nodes on the plotting device.
## Update: This is now in a vectorized form (user can still
## supply a function, but that has to deal with vectorized data for now)
renderNodes <- function(g) 
{
    ## get necessary render parameters from the graph or use defaults
    ## these are generated by the layout algorithm
    nodeX <- getRenderPar(g, "nodeX", "nodes")
    nodeY <- getRenderPar(g, "nodeY", "nodes")
    lw <- getRenderPar(g, "lWidth", "nodes")
    rw <- getRenderPar(g, "rWidth", "nodes")
    height <- getRenderPar(g, "height", "nodes")
    labelX <- getRenderPar(g, "labelX", "nodes")
    labelY <- getRenderPar(g, "labelY", "nodes")
    
    #labelJust <- getRenderPar(g, "labelJust", "nodes") ## FIXME: do we need this
    #labelJust <- as.numeric(gsub("l", 0, gsub("n", -0.5, gsub("r", -1,
    #                        labelJust))))
    ## these only live within R
    fill <- unlist(getRenderPar(g, "fill", "nodes"))
    col <- unlist(getRenderPar(g, "col", "nodes"))
    lwd <- unlist(getRenderPar(g, "lwd", "nodes"))
    lty <- unlist(getRenderPar(g, "lty", "nodes"))
    textCol <- unlist(getRenderPar(g, "textCol", "nodes"))
    style <- unlist(getRenderPar(g, "style", "nodes"))
    shape <- getRenderPar(g, "shape", "nodes")
    label <- unlist(getRenderPar(g, "label", "nodes"))
    fontsize <- unlist(getRenderPar(g, "fontsize", "nodes"))
    if (is.null(label)) label <- nodes(g)
   

    ## deal with different shapes
    ## first deal with user-defined functions
    funs <- sapply(shape, is.function)
    if(any(funs)){
        for(i in which(funs)){
            bbox <- matrix(c(nodeX[i]-lw[i], nodeX[i]+rw[i], nodeY[i]-height[i]/2,
                             nodeY[i]+height[i]/2), ncol=2)
            try(shape[[i]](bbox, labelX=labelX[i], labelY=labelY[i], fill=fill[i],
                           col=col[i], lwd=lwd[i], lty=lty[i], textCol=textCol[i],
                           style=style[i], label=label[i], fontsize=fontsize[i]))
        }
    }

    ## now the default shapes
    possible.shapes <-
        c("circle", "ellipse", "box", "rectangle", "plaintext", "triangle", "diamond")
    shape <-
        possible.shapes[pmatch(shape,
                               possible.shapes,
                               duplicates.ok = TRUE,
                               nomatch=5)]
    ## shape == circle
    i <- shape == "circle"
    if (any(i, na.rm=TRUE))
    {
        rad <- pmin(height, (lw+rw))/2
        wh <- which(i)
        sapply(wh, function(ww) {
            symbols(nodeX[ww], nodeY[ww], circles = rad[ww],
                fg = col[ww], bg = fill[ww], lwd = lwd[ww], lty = lty[ww],
                inches = FALSE, add = TRUE)
        }) ## we need to do this because symbols does not recycle lwd
    }
    ## shape == box, rect, etc
    i <- shape %in% c("box", "rectangle", "rect")
    if (any(i, na.rm=TRUE))
    {
        rect(nodeX[i] - lw[i], nodeY[i] - (height[i] / 2),
             nodeX[i] + rw[i], nodeY[i] + (height[i] / 2),
             col = fill[i], border = col[i], lty = lty[i], lwd = lwd[i])
    }
    ## shape == triangle
    ## FIXME: The edges are not computed for triangle shapes in Graphviz
    ##        allthough the correct shape is stored in the agraph object.
    ##        There must be something weird going on internally in the
    ##        C code....
    i <- shape == "triangle"
    if (any(i, na.rm=TRUE))
    {
        wh <- which(i)
        sapply(wh, function(ww) {
            polygon(x = c(nodeX[ww] - lw[ww], nodeX[ww], nodeX[ww] + lw[ww]),
                    y = c(nodeY[ww] - (height[ww] / 2),
                    nodeY[ww] + (height[ww] / 2),
                    nodeY[ww] - (height[ww] / 2)),
                    col = fill[ww], border = col[ww], lty = lty[ww],
                    lwd = lwd[ww])
        })
    }
    ## shape == ellipse
    i <- shape == "ellipse"
    if (any(i, na.rm=TRUE))
    {
        rad <- (lw+rw)/2
        npoints <- 101
        tt <- c(seq(-pi, pi, length = npoints), NA)
        wh <- which(i)
        sapply(wh, function(ww) {
            polygon(nodeX[ww] + sin(tt) * rad[ww],
                    nodeY[ww] + cos(tt) * height[ww]/2,
                    border = col[ww], col = fill[ww], lwd = lwd[ww],
                    lty = lty[ww])
        }) ## we need to do this because polygon does not recycle lwd
    }

    ## shape == diamond
    i <- shape == "diamond"
    if (any(i, na.rm=TRUE))
    {
        for(j in which(i)) polygon(x=c(nodeX[j] - lw[j], nodeX[j], nodeX[j] + rw[j], nodeX[j]),
        y=c(nodeY[j], nodeY[j] + (height[j] / 2), nodeY[j], nodeY[j] - (height[j] / 2)),
        col = fill[j], border = col[j], lty = lty[j], lwd = lwd[j])
    }

    ## shape == plaintext
    ## nothing to do (for style = "filled", use fill = "grey")
    
    ## compute label cex from node dimensions if not set
    cex <- getRenderPar(g, "cex", "nodes")
    if(is.null(cex)){
        nodeDims <- cbind(lw+rw, height)
        stw <- strwidth(label)
        sth <- strheight(label)
        strDims  <- cbind(stw*1.1, sth*1.4)
        strDims[!nzchar(label),] <- c(strwidth(" "), strheight(" "))
        cex <- min(nodeDims / strDims)
    }
    
    ## draw labels
    text(labelX, labelY, label, col=textCol,
         cex=cex*as.numeric(fontsize)/14)
}



## rotate a karthesian coordinate system around its origin by alpha
## and retain x and y values through a translocation by offset.
rotate <- function(x, y, alpha, offset){
    xn <- x*cos(alpha)-y*sin(alpha)+offset[1]
    yn <- x*sin(alpha)+y*cos(alpha)+offset[2]
    list(x=xn,y=yn)
}


## draw different types of arrowheads
drawHead <- function(type, xy, bbox, col, lwd, lty, len, out=TRUE){
    db <- as.numeric(diff(bbox))
    dxy <- diff(xy)*db
    alpha <- atan(dxy[2]/dxy[1])
    ## This computes the arrowhead size from the total graph bounding box.
    ## Not optimal, but computing from the terminal spline sections seems
    ## not to work...
    r <- max(bbox)/130
    warn=FALSE
    ## the default arrow. We want to be able to reuse this...
    normArrow <- function(r, alpha, xy, col, lwd, lty, out)
    {
        r <- r*0.5
        x <- c(-1,0,1)*r
        y <- c(-1,1,-1)*r
        off <- if(out) 90 else -90
        alpha <- alpha-off*(pi/180)
        xyr <- rotate(x,y,alpha, xy[2,])
        polygon(xyr, col=col, border=col, lwd=lwd, lty=lty)
    }
    switch(unlist(type),
           "none"={},
           "box"={
               x <- c(-1,-1,1,1)*r
               y <- c(-1,1,1,-1)*r
               xyr <- rotate(x,y,alpha, xy[2,])
               polygon(xyr, col=col, border=col, lwd=lwd, lty=lty)
           },
           "obox"={
               x <- c(-1,-1,1,1)*r
               y <- c(-1,1,1,-1)*r
               xyr <- rotate(x,y,alpha, xy[2,])
               polygon(xyr, border=col, col="white", lwd=lwd, lty=lty)
           },
           "dot"={
               symbols(xy[2,1], xy[2,2], circles=r, inches=FALSE, add=TRUE, fg=col,
                       lwd=lwd, lty=lty, bg=col)
           },
           "odot"={
               symbols(xy[2,1], xy[2,2], circles=r, inches=FALSE, add=TRUE, fg=col,
                       lwd=lwd, lty=lty, bg="white")
           },
           "diamond"={
               x <- c(-1,-1,1,1)*r
               y <- c(-1,1,1,-1)*r
               xyr <- rotate(x,y,alpha+45*(pi/180), xy[2,])
               polygon(xyr, col=col, border=col, lwd=lwd, lty=lty)
           },
           "odiamond"={
               x <- c(-1,-1,1,1)*r
               y <- c(-1,1,1,-1)*r
               xyr <- rotate(x,y,alpha+45*(pi/180), xy[2,])
               polygon(xyr, col="white", border=col, lwd=lwd, lty=lty)
           },
           "tee"={
               x <- c(0, 0)*r
               y <- c(-1,1)*r
               xyr <- rotate(x,y,alpha, xy[2,])
               lines(xyr, col=col, lwd=lwd, lty=lty)
           },
           "normal"={
               normArrow(r, alpha, xy, col, lwd, lty, out)
           },
           "open"={
               ## normArrow(r, alpha, xy, col, lwd, lty, out)
	       arrows(xy[1], xy[3], xy[2], xy[4], length=len, col=col,
                      lwd=lwd, lty=lty)
            },
           "vee"={
               arrows(xy[1], xy[3], xy[2], xy[4], length=len, col=col,
                      lwd=lwd, lty=lty)
           },{
               warn <- TRUE
               ##normArrow(r, alpha, xy, col, lwd, lty, out)
	       arrows(xy[1], xy[3], xy[2], xy[4], length=len, col=col,
                      lwd=lwd, lty=lty)
           }
       )
    warn
}
           

## A vectorized function that draws the splines for the edges
renderSpline <-
    function(spline, arrowhead = FALSE, arrowtail = FALSE, len = 1,
             col = "black", lwd=1, lty="solid", bbox, ...)
{
    ## may get numerics as characters (e.g. "1") which doesn't work
    ## for 'lines'
    mylty <- as.numeric(lty)
    if(!is.na(mylty)) lty <- mylty
    lapply(spline, lines, col = col, lwd=lwd, lty=lty, ...)
    warn <- FALSE

    ## the arrow heads, both head or tail may be a user supplied function
    ## or one of the following predefined shapes: nomal, none, box, obox, dot, odot
    ## the default shape will always be "normal".
    xyhead <- tail(bezierPoints(spline[[length(spline)]]), 2)
    if(is.function(arrowhead[[1]])){
        xy <- list(x=xyhead[2,1], y=xyhead[2,2])
        try(arrowhead[[1]](xy, col=col, lwd=lwd, lty=lty))
    }else{
        warn <- drawHead(arrowhead, xyhead, bbox, col, lwd, lty, len, out=TRUE)
    }
    ## now the arrow tails
    xytail <- head(bezierPoints(spline[[length(spline)]]), 2)
    if(is.function(arrowtail[[1]])) {
        xy <- list(x=xytail[1,1], y=xytail[1,2])
        try(arrowtail[[1]](xy, col=col, lwd=lwd, lty=lty))
    } else {
        warn <- warn | drawHead(arrowtail, xytail[2:1,], bbox, col, lwd,
                                lty, len, out=FALSE)
    }
    warn
}



## find R's resolution for the current device
devRes <- function(){
    if(current.viewport()$name != "ROOT"){
        vpt <- current.vpTree()
        popViewport(0)
        xres <- abs(as.numeric(convertWidth(unit(1, "inches"), "native")))
        yres <- abs(as.numeric(convertHeight(unit(1, "inches"), "native")))
    pushViewport(vpt)
    }else{
        xres <- abs(as.numeric(convertWidth(unit(1, "inches"), "native")))
        yres <- abs(as.numeric(convertHeight(unit(1, "inches"), "native")))
    }
    retval <- c(xres, yres)
    names(retval) <- c("xres", "yres")
    retval
}



## This function will plot individual edges on the plotting device.
renderEdges <- function(g)
{
    ## get necessary render parameters
    ## these are generated by the layout algorithm
    lw <- getRenderPar(g, "lWidth", "nodes")
    rw <- getRenderPar(g, "rWidth", "nodes")
    height <- getRenderPar(g, "height", "nodes")
    splines <- getRenderPar(g, "splines", "edges")
    ## direction <- getRenderPar(g, "direction", "edges") ## UNUSED (isn't this redundant?)
    arrowhead <- unlist(getRenderPar(g, "arrowhead", "edges"))# != "none"
    arrowtail <- getRenderPar(g, "arrowtail", "edges")# != "none"
    label <- getRenderPar(g, "label", "edges")
    labelX <- getRenderPar(g, "labelX", "edges")
    labelY  <- getRenderPar(g, "labelY", "edges")
    #labelJust <- getRenderPar(g, "labelJust", "edges") ## FIXME:do we need this
    #labelJust <- as.numeric(gsub("l", 0, gsub("n", -0.5, gsub("r", -1,
    #                        labelJust))))              
    #labelWidth <- getRenderPar(g, "labelWidth", "edges")
    ## these only live within R
    fontsize <- getRenderPar(g, "fontsize", "edges")
    textCol <- getRenderPar(g, "textCol", "edges")
    col <- unlist(getRenderPar(g, "col", "edges"))
    lty <- getRenderPar(g, "lty", "edges")
    lwd <- unlist(getRenderPar(g, "lwd", "edges"))
    cex <- getRenderPar(g, "cex", "edges")
    
    ## set the arrow size
    minDim <- min(max(rw + lw), max(height))
    arrowLen <- par("pin")[1] / diff(par("usr")[1:2]) * minDim / (1.5*pi)

    ## plot the edge splines
    warn <- FALSE
    for (i in seq_along(splines))
    {
        warn <- warn | suppressWarnings(renderSpline(splines[[i]],
                                                     arrowhead = arrowhead[i],
                                                     arrowtail = arrowtail[i],
                                                     len = arrowLen,
                                                     col = col[i], lty = lty[i],
                                                     lwd = lwd[i],
                                                     bbox= getRenderPar(g, "bbox", "graph")))
    }
    if(warn)
        warning("Unknown or unsupported arrowhead type. Using default instead.")

    ## draw text labels
    text(labelX, labelY, label, col=textCol,
         cex=cex*as.numeric(fontsize)/14)
}

## render graph to plotting device
setGeneric("renderGraph",
           function(x, ...) standardGeneric("renderGraph"))

setMethod("renderGraph", "graph", function(x, ..., drawNodes = "renderNodes",
                                           drawEdges = renderEdges, graph.pars=list()) {
    ## evaluate defaults passed in via the graph.pars argument
    old.graph.pars <- graph.par(graph.pars)
    on.exit(graph.par(old.graph.pars))
    
    ## check that the graph has been laid out
    laidout <- getRenderPar(x, "laidout", "graph")
    bbox <- getRenderPar(x, "bbox", "graph")
    if(!laidout)
        stop("Graph has not been laid out yet. Please use function ",
             "'layoutGraph'")
    plot.new()
    
    ## eliminate all plot borders but leave space for title and
    ## subtitle if needed
    sub <-  getRenderPar(x, "sub", "graph")
    main <- getRenderPar(x, "main", "graph")
    cex.main <- getRenderPar(x, "cex.main", "graph")
    cex.sub <- getRenderPar(x, "cex.sub", "graph")
    mheight <- if(!is.null(main) && nchar(main)>0)
        sum(strheight(main, "inches", cex.main))+0.3 else 0.1
    sheight <- if(!is.null(sub) && nchar(sub)>0)
        sum(strheight(sub, "inches", cex.sub))+0.2 else 0.1
    old.pars <- par(mai=c(sheight, 0, mheight,0))
    on.exit(par(old.pars), add=TRUE)
    
    ## set coordinate system to the values of the bounding box
    ## and keep aspect ratio fixed when margins increase due to
    ## title and subtitle
    aspFact <- (sheight+mheight)/par("din")[2]
    usr <- c(bbox[1,1] - (bbox[2,1] * (aspFact/2)),
             bbox[2,1] + (bbox[2,1] * (aspFact/2)),
             bbox[,2])
    plot.window(xlim=usr[1:2], ylim=usr[3:4],
                log="", asp=NA)
    old.pars <- append(old.pars, par(usr=usr))
    
    ## Add title and subtitle if available
    old.pars <- append(old.pars, par(xpd=NA))
    if(mheight>0.1){
        col.main <- getRenderPar(x, "col.main", "graph")
        moffset <- (bbox[2,2]/par("pin")[2] * mheight)/2
        text(bbox[2,1]/2, bbox[2,2] + moffset, main,
             cex=cex.main, col=col.main, adj=c(0.5))
    }
    if(sheight>0.1){
        col.sub<- getRenderPar(x, "col.sub", "graph")
        soffset <- (bbox[2,2]/par("pin")[2] * sheight)/2
        text(bbox[2,1]/2, bbox[1,2] - soffset,
             sub, cex=cex.sub, col=col.sub, adj=c(0.5))
    }
    
    ## Draw Nodes, using default vectorized function or a
    ## node-by-node user-defined function   
    if(is.character(drawNodes)){
        if(match.arg(drawNodes)=="renderNodes")
                      renderNodes(x)
    }else  drawNodes(x)
    
    
    ## Draw edges using default edge rendering function
    drawEdges(x)
    
    ## compute native node coordinates for imageMaps
    x1 <- {getRenderPar(x, "nodeX", "nodes") -
               getRenderPar(x, "lWidth", "nodes")}
    y1 <- {getRenderPar(x, "nodeY", "nodes") -
               getRenderPar(x, "height", "nodes")/2}
    x2 <- {getRenderPar(x, "nodeX", "nodes") +
               getRenderPar(x, "rWidth", "nodes")}
    y2 <- {getRenderPar(x, "nodeY", "nodes") +
               getRenderPar(x, "height", "nodes")/2}
    figDims <- par("din")
    ## these factors should accomodate for any figure margins
          xfac <- diff(par("plt")[1:2])
    xoffset <- par("plt")[1]
    yfac <- diff(par("plt")[3:4])
    yoffset <- par("plt")[3]
    ## need to take into account the aspect factor for x values
    x1n <- {((x1/diff(usr[1:2])) * xfac) + xoffset +
                (bbox[1,1]-usr[1])/diff(usr[1:2])}
    x2n <- {((x2/diff(usr[1:2])) * xfac) + xoffset +
                (bbox[1,1]-usr[1])/diff(usr[1:2])}
    ## invert y values because [0,0] is on top left for imageMap
          y1n <- 1-(((y1/bbox[2,2])*yfac)+yoffset)
    y2n <- 1-(((y2/bbox[2,2])*yfac)+yoffset)
    nativeCoords <- cbind(x1n, y1n, x2n,y2n)
    
    ## store information about the rendering process in the graph
    graphRenderInfo(x) <- list(nativeCoords=nativeCoords,
                               figDim=figDims*devRes(),
                               usr=usr, mai=par("mai"))
    
    return(invisible(x))
})