R/gPlots.R

In arulesVizOld: arulesViz - Visualizing Association Rules and Frequent Itemsets

#######################################################################
# arulesViz - Visualizing Association Rules and Frequent Itemsets
# Copyrigth (C) 2011 Michael Hahsler and Sudheer Chelluboina
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.


## simple image plot using grid

gTitle <- function(main, height=unit(4, "lines"), 
	gp=gpar(fontface="bold", cex=1.2), name=NULL) {
    pushViewport(viewport(y=1, height=height,
		    just = c("top"), name=name))
    grid.text(main,
	    gp=gp)
    upViewport(1)
}

gImage <- function(m, 
	xScale = NULL, yScale = NULL, xlab=NULL, ylab=NULL,
	name = NULL, gp = gpar()) {

    df <- which(!is.na(m), arr.ind=TRUE)
    y <- df[,1] -1L
    x <- df[,2] -1L
    z <- as.vector(m[!is.na(m)])
    

    if(is.null(xScale)) {
	width <- 1
	xScale <- c(1,ncol(m)+1L)-.5
	x <- x+.5
    } else {
	width <- diff(xScale)/ncol(m)
	xS <- c(xScale[1] + width/2, xScale[2] - width/2) - width/2
	x <- map(x, xS)
    }

    if(is.null(yScale)) {
	height <- 1
	yScale <- c(0,nrow(m))+.5
	y <- y+.5
    } else {
	height <- diff(yScale)/nrow(m)
	yS <- c(yScale[1] + height/2, yScale[2] - height/2) - height/2
	y <- map(y, yS)
    }

    ## create viewport
    vp <- viewport(
	    xscale = xScale, yscale = yScale,
	    default.units = "native", name = name)
    pushViewport(vp)

    ## draw squares
    grid.rect(x = x, y = y, width, height,
	    gp = gpar(fill = z, col=0), just=c("left","bottom"),
	    default.units = "native")

    ## border and axes
    gp_border       <- gp
    gp_border$fill  <- "transparent"
    grid.rect(x = 0, y = 0,
	    width = 1, height = 1, just=c("left","bottom"),
	    default.units = "npc", gp = gp_border)
    grid.xaxis(gp = gp)
    grid.yaxis(gp = gp)
    
    ## labels
    if(!is.null(xlab)) grid.text(xlab, 0.5, unit(-3, "lines"))
    if(!is.null(ylab))  grid.text(ylab, unit(-3, "lines"), 0.5, rot=90)
    
    upViewport(1)
}


gScatterplot <- function(x, y=NULL, xlim = NULL, ylim = NULL,
	xlab = "x", ylab="y", 
	col="black", cex=1, pch=1, alpha = NULL,
	new = TRUE, main = "Scatterplot", 
	name = NULL, 
	gp = gpar()) {

    if(is(x, "matrix") || is(x, "data.frame")) {
	y <- x[,2]
	x <- x[,1]
    }

    ## scale and filter points
    if(is.null(xlim)) xlim <- range(x, na.rm=TRUE)
    else x[x<xlim[1] | x>xlim[2]] <- NA
    if(is.null(ylim)) ylim <- range(y, na.rm=TRUE)
    else y[y<ylim[1] | y>ylim[2]] <- NA

    ## make plotting region 5% larger
    width <- diff(xlim)
    height <- diff(ylim)
    xlim[1] <- xlim[1]-width*0.025
    xlim[2] <- xlim[2]+width*0.025
    ylim[1] <- ylim[1]-height*0.025
    ylim[2] <- ylim[2]+height*0.025

    ## new plot
    if(new) {
	grid.newpage()
	pushViewport(plotViewport())
	grid.text(main, .5, unit(1, "npc")+unit(2, "lines"),
		gp=gpar(fontface="bold", cex=1.2))
    }

    pushViewport(viewport(clip=FALSE, xscale=xlim, yscale=ylim, 
		    name= name))
    ## axes
    grid.xaxis()
    grid.yaxis()
    grid.text(xlab, .5, unit(-3, "lines"))
    grid.text(ylab, unit(-3.5, "lines"), .5, rot=90)

    ## points
    grid.points(x, y, pch=pch, 
	    gp=gpar(col=col, fill=col, alpha=alpha, cex=cex))

    ## box
    grid.rect(x = 0, y = 0, width = 1, height = 1,
	    just = c("left", "bottom"), default.units = "npc",
	    gp = gpar(fill = "transparent"))

    upViewport(1)
    if(new) upViewport(1)
}

gColorkey <- function(range, col, label = NULL,
	name = "colorkey", gp = gpar()) {

    n <- length(col) 
    height <- diff(range)/n
    ys <- seq(range[1] + height/2, range[2] - height/2, length.out = n)

    vp <- viewport(
	    xscale = c(0,1), yscale = c(range[1]+height/2, range[2]+height/2), 
	    default.units = "native", name = name)
    pushViewport(vp)

    ## col
    gp_col      <- gp
    gp_col$col  <- 0
    gp_col$fill <- col
    grid.rect(x = 0, y = ys, width = 1, height = height,
	    just = c("left", "bottom"), default.units = "native",
	    gp = gp_col)


    ## box
    gp_border       <- gp
    gp_border$fill  <- "transparent"
    grid.rect(x = 0, y = 0, width = 1, height = 1,
	    just = c("left", "bottom"), default.units = "npc",
	    gp = gp_border)

    grid.yaxis(gp = gp, main=FALSE)

    ## label
    if(!is.null(label)) grid.text(label,0.5,unit(-1, "lines"))
	
    upViewport(1)
}

gParacoords <- function(m, discreteNames=NULL,
	col=NULL, lwd=NULL, arrowPos=NULL, 
	xlab=NULL, name=NULL, gp=gpar(), gp_lines=gpar()) {

    if(is.null(col)) col <- 1
    if(length(col)==1) col <- rep(col, nrow(m))
    if(is.null(lwd)) lwd <- 1
    if(length(lwd)==1) lwd <- rep(lwd, nrow(m))
    if(is.null(arrowPos)) arrowPos <- 0
    if(length(arrowPos)==1) arrowPos <- rep(arrowPos, nrow(m))
    
    arrow_type <- arrow(angle = 15)
    
    if(is.null(discreteNames)) {
	leftSpace <- unit(3, "lines")
	yscale <- range(as.numeric(m), na.rm=TRUE)
    }else{ 
	leftSpace <- max(stringWidth(discreteNames))
	yscale <- c(.5, length(discreteNames)+.5)
    }
    
    pushViewport(viewport(xscale = c(.5, ncol(m)+.5), 
		    yscale = yscale,
		    default.units = "native", gp=gp,
		    name=name))

    ## axes
    grid.xaxis(at=1:ncol(m), label=colnames(m))
    if(is.null(discreteNames)) grid.yaxis()
    else grid.yaxis(at= 1:length(discreteNames), label=discreteNames)
    if(!is.null(xlab)) grid.text(xlab, .5, unit(-3, "lines"))

    ## box
    grid.rect(x = 0, y = 0, width = 1, height = 1,
	    just = c("left", "bottom"), default.units = "npc",
	    gp = gpar(fill = "transparent"))

    ## grid
    gp_grid <- gpar(col="gray", lty=3)
    for(i in 1:ncol(m))  grid.lines(x = c(i,i), y=unit(c(0,1), "npc"),
	    default.units = "native", gp=gp_grid)

    ## draw lines
    for(i in 1:nrow(m)) {
	line <- m[i,]
	gp_lines$lwd <- lwd[i]
	gp_lines$col <- col[i]
	arr <- arrowPos[i]

	for(j in 1:length(line)) {
	    grid.lines(y=line[j:(j+1L)], x=c(j, j+1L),
		    default.units = "native", gp=gp_lines,
		    arrow= if((j+1L)==arr) arrow_type else NULL)
	}
    }

    upViewport(1)
}