### StackedBars.R ### $Revision: 1.4 $ ### $Date: 2010/02/03 21:18:16 $ ### Authors: Russell Almond "stackedBarplot" <- function (height, width = 1, space = 0.2, names.arg = NULL, legend.text = NULL, horiz = FALSE, density = NULL, angle = 45, col = NULL, border = par("fg"), main = NULL, sub = NULL, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, xpd = TRUE, axes = TRUE, axisnames = TRUE, cex.axis = par("cex.axis"), cex.names = par("cex.axis"), newplot = TRUE, axis.lty = 0, offset = 0, ...) { space <- space * mean(width) if (axisnames && missing(names.arg)) names.arg <- if (is.matrix(height)) colnames(height) else names(height) if (is.vector(height) || (is.array(height) && (length(dim(height)) == 1))) { height <- cbind(height) if (is.null(col)) col <- "grey" } else if (is.matrix(height)) { if (is.null(col)) col <- grey.colors(nrow(height)) } else stop("'height' must be a vector or a matrix") if (is.logical(legend.text)) legend.text <- if (legend.text && is.matrix(height)) rownames(height) NR <- nrow(height) NC <- ncol(height) { width <- rep(width, length.out = NC) height <- rbind(0, apply(height, 2, cumsum)) } offset <- rep(as.vector(offset), length.out = length(width)) delta <- width/2 w.r <- cumsum(space + width) w.m <- w.r - delta w.l <- w.m - delta if (horiz) { if (missing(xlim)) xlim <- range(-0.01 * height + offset, height + offset, na.rm = TRUE) if (missing(ylim)) ylim <- c(min(w.l), max(w.r)) } else { if (missing(xlim)) xlim <- c(min(w.l), max(w.r)) if (missing(ylim)) ylim <- range(-0.01 * height + offset, height + offset, na.rm = TRUE) } opar <- if (horiz) par(xaxs = "i", xpd = xpd) else par(yaxs = "i", xpd = xpd) on.exit(par(opar)) if (newplot) { plot.new() plot.window(xlim, ylim, log = "", ...) } xyrect <- function(x1, y1, x2, y2, horizontal = TRUE, ...) { if (horizontal) rect(x1, y1, x2, y2, ...) else rect(y1, x1, y2, x2, ...) } for (i in 1:NC) { xyrect(height[1:NR, i] + offset[i], w.l[i], height[-1, i] + offset[i], w.r[i], horizontal = horiz, angle = angle, density = density, col = col, border = border) } if (axisnames && !is.null(names.arg)) { at.l <- if (length(names.arg) != length(w.m)) { if (length(names.arg) == NC) colMeans(w.m) else stop("incorrect number of names") } else w.m axis(if (horiz) 2 else 1, at = at.l, labels = names.arg, lty = axis.lty, cex.axis = cex.names, ...) } if (!is.null(legend.text)) { legend.col <- rep(col, length.out = length(legend.text)) if (!horiz) { legend.text <- rev(legend.text) legend.col <- rev(legend.col) density <- rev(density) angle <- rev(angle) } xy <- par("usr") legend(xy[2] - xinch(0.1), xy[4] - yinch(0.1), legend = legend.text, angle = angle, density = density, fill = legend.col, xjust = 1, yjust = 1) } if (newplot) title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...) if (axes) axis(if (horiz) 1 else 2, cex.axis = cex.axis, ...) invisible(w.m) } ### This graph produces Jodi Underwood's stacked bar breakdown charts. ### Data is assumed to be a matrix with useful row and column labels. ### data --- Data matrix (rows are levels, columns are groups) ### digits --- number of significant digits to use when printing labels ### Percent --- report scores as percents rather than fractions "stackedBars" <- function (data, profindex, ..., ylim = c(min(offsets)-.25,max(1+offsets)), cex.names=par("cex.axis"), percent=TRUE, digits=2*(1-percent),labrot=FALSE) { data <- as.matrix(data) ngroups <- ncol(data) nlevels <- nrow(data) normdata <- sweep(data,2,apply(data,2,sum),"/") if (profindex == 1) { offsets <- - normdata[1,] } else { offsets <- -apply(normdata[1:profindex,],2,sum) } xmid <- barplot(normdata,offset=offsets, axes=FALSE,cex.names=cex.names, ylim = ylim, ## xlim=c(0,ngroups+2.5),width=.75,legend.text=TRUE, ...) xmid <- matrix(rep(xmid,each=nlevels),dim(data)) ## Vertical Line lines(c(0,ngroups*1.25),c(0,0)) ymid <- sweep(apply(normdata,2,cumsum),2,offsets,"+") - normdata/2 labels <- paste(round(data,digits)) if (percent) labels <- paste(round(normdata*100,digits)) srt <- par("srt") if (labrot) srt <- srt+90 text(xmid[data!=0],ymid[data!=0],labels[data!=0],cex=cex.names,srt=srt) } ### This is a variant on the stacked bars graph meant to show ### prior/posterior comparisons. It assumes the pairs come in ### groups and are labeled "skill.prior" "skill.post" "compareBars" <- function (data1, data2, profindex, groupNames=c(deparse(data1),deparse(data2)),..., ylim = c(min(offsets)-.25,max(1+offsets)), cex.names=par("cex.axis"), digits=2, legend.loc=c(0,1),legend.cex=par("cex"), col=NULL, col1= NULL, col2=NULL, main=NULL, sub=NULL, xlab=NULL, ylab=NULL,rotlab=FALSE){ if (missing(col1) && !missing(col)) col1 <- col if (missing(col1) && !missing(col)) col2 <- col data1 <- as.matrix(data1) data2 <- as.matrix(data2) npair <- ncol(data1) gaps <- rep(c(.3,.1),npair) gaps1 <- rep(1.4,npair) gaps1[1] <- .3 gaps2 <- rep(1.4,npair) data <- cbind(data1[,1],data2[,1]) for (icol in 2:npair) data <- cbind(data,data1[,icol],data2[,icol]) if (profindex == 1) { offsets <- - data[1,] offsets1 <- - data1[1,] offsets2 <- - data2[1,] } else { offsets <- -apply(data[1:profindex,],2,sum) offsets1 <- -apply(data1[1:profindex,],2,sum) offsets2 <- -apply(data2[1:profindex,],2,sum) } xlim <- c(0,npair*2.4) # Calculate positions xpos <- barplot(data,space=gaps,offset=offsets, width=1, cex.names=cex.names, xlim=xlim, ylim=ylim, plot=FALSE, ...) plot.new() plot.window(xlim=xlim, ylim=ylim,log="", ...) title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...) names <- rep("",npair) xpos1 <- stackedBarplot(data1,space=gaps1,offset=offsets1, width=1, cex.names=cex.names, col=col1, newplot=FALSE, axes=FALSE,names.arg=names,...) xpos2 <- stackedBarplot(data2,space=gaps2,offset=offsets2, width=1, cex.names=cex.names, col=col2, newplot=FALSE, axes=FALSE,names.arg=names,...) abline(h=0) xposave <- (xpos[(1:npair)*2-1] + xpos[(1:npair)*2])/2 yl <- ylim[2]-ylim[1] srt <- par("srt") if (rotlab) srt <- srt + 90 # text(xpos,min(offsets)-.05*yl,rep(groupNames,npair),cex=cex.names,xpd=NA,srt=srt) text(xposave,min(offsets)-.1*yl,dimnames(data1)[[2]],cex=cex.names,xpd=NA,srt=srt) xpos <- rep(xpos,each=nrow(data)) ypos <- sweep(apply(data,2,cumsum),2,offsets,"+") - data/2 labels <- paste(round(data,digits)) text(xpos[data!=0],ypos[data!=0],labels[data!=0],cex=cex.names,srt=srt) ### Legend labels <- as.vector(t(outer(groupNames,dimnames(data1)[[1]],paste,sep=":"))) legend(legend.loc,legend=labels,fill=c(col1,col2), cex=legend.cex) invisible(xpos) } ### This is a variant on the stacked bars graph meant to show ### prior/posterior comparisons. It assumes the pairs come in ### groups and are labeled "skill.prior" "skill.post" "compareBars2" <- function (data1, data2, profindex,groupNames=c("Prior","Post"), error.bars=2,scale=100,err.col="gray20",..., ylim = NULL) { if (any(error.bars <1) || any(error.bars>2) || abs(error.bars - round(error.bars)) > .00001 ) { stop("Expected error.bars to be 1 or 2.") } data1 <- as.matrix(data1) data2 <- as.matrix(data2) npair <- ncol(data1) gaps <- rep(c(.3,.1),npair) data <- cbind(data1[,1],data2[,1]) for (col in 2:npair) data <- cbind(data,data1[,col],data2[,col]) ss <- matrix(colSums(data),nrow(data),ncol(data),byrow=TRUE) ## Set up list of which error bars to show. nbars <- nrow(data) whichbars <- 1:(nbars*npair*2) if (length(error.bars) < 2) { whichbars <- rep(((1:npair)*2-3+error.bars)*nbars, each=nbars)+1:nbars } if (profindex == 1) { offsets <- -data[profindex,] } else { offsets <- -apply(data[1:profindex,],2,sum) } ci <- proflevelci(data,profindex) ## Rescale data ci.ll <- ci$lower*scale ci.ul <- ci$upper*scale data <- data/ss*scale offsets <- offsets/ss[1,]*scale data1 <- sweep(data1,2,colSums(data1),"/")*scale data2 <- sweep(data2,2,colSums(data2),"/")*scale ## Barplot if (!is.numeric(ylim)) { ylim <- c(min(data-offsets,ci.ll[whichbars],ci.ul[whichbars])-scale/10, max(data-offsets,ci.ll[whichbars],ci.ul[whichbars])+scale/10) } xpos <- compareBars(data1,data2,profindex,groupNames, ylim=ylim,...) xpos <- matrix(xpos,nrow=nbars) ## Now add error bar segments ## Add a small offset to each error bar xpos <- xpos + (1:nbars)/(nbars+1) -.5 ## Now for the segments segments(xpos[whichbars],ci.ll[whichbars], xpos[whichbars],ci.ul[whichbars], col=err.col, lwd=1.5) invisible(list(xpos=xpos,ci.ul=ci.ul,ci.ll=ci.ll)) } ## ### Test Graphs ## #postscript("~/text/david/likelihood.eps",onefile=FALSE,horizontal=FALSE, ## # paper="special",width=5,height=3) ## compareBars(likelihood,3,main="Likelihoods for Medium TroubleShooting Task", ## sub="Observables: cfgCor=Medium, logCor=High, logEff=Medium", ## cex.names=.75, ## names.arg=c("Troubleshoot","","NDK","","Modeling","")) ## #dev.off() ## #postscript("~/text/david/margins.eps",onefile=FALSE,horizontal=FALSE, ## # paper="special",width=5,height=3) ## compareBars(margins,3,main="Margins before/after Medium TroubleShooting Task", ## sub="Observables: cfgCor=Medium, logCor=High, logEff=Medium", ## cex.names=.75, ## names.arg=c("Troubleshoot","","NDK","","Modeling","")) ## #dev.off() ## #postscript("~/text/david/forcast.eps",onefile=FALSE,horizontal=FALSE, ## # paper="special",width=5,height=3) ## compareBars(forcast,1,main="Predicted distributions for observables", ## sub="Observables: cfgCor=Medium, logCor=High, logEff=Medium", ## cex.names=.75, ## names.arg=c("cfg-Cor","","dgm-Cor","","flst-Cor","","log-Cor","","log-Eff","")) ## #dev.off() ## #postscript("~/text/david/CNAPscore.eps",onefile=FALSE,horizontal=FALSE, ## paper="special",width=5,height=3) ## stackedBars(posterior,3,main="Sample score report", ## sub="Third Semester Student", cex.names=.75) ## #dev.off()