###################################################################### # SPLUS Mosaic Graphical Procedure # # Jay Emerson, Yale University, February 1998 # ###################################################################### ###################################################################### ###################################################################### ## Copyright (C) 1998 John W. Emerson ## ## This document 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, or (at your option) ## 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. ## ## A copy of the GNU General Public License is available via WWW at ## http://www.gnu.org/copyleft/gpl.html. You can also obtain it by ## writing to the Free Software Foundation, Inc., 675 Mass Ave, ## Cambridge, MA 02139, USA. ## ## Bug reports to emerson@stat.yale.edu ###################################################################### ###################################################################### ###################################################################### # Plot Mosaic # # # # DESCRIPTION: # # Plots a mosaic on the current graphics device. # # # # USAGE: # # mosaic(X, main=NA, sort=NA, off=NA, dir=NA, color=F) # # # # REQUIRED ARGUMENTS: # # X: a contingency table, with optional category labels # # specified in the dimnames(X) attribute. The table is best # # created by the table() command, which produces an object # # of type array. # # # # OPTIONAL ARGUMENTS: # # main: character string for the mosaic title. # # sort: vector ordering of the variables, containing a permutation # # of the integers 1:length(dim(X)) (the default). # # off: vector of offsets to determine percentage spacing at each # # level of the mosaic (appropriate values are between 0 and # # 20, and the default is 10 at each level). There should be # # one offset for each dimension of the contingency table. # # dir: vector of split directions ("v"=vertical and # # "h"=horizontal) for each level of the mosaic, one # # direction for each dimension of the contingency table. # # The default consists of alternating directions, beginning # # with a vertical split. # # color: (TRUE or vector of integer colors) for color shading or # # (FALSE, the default) for empty boxes with no shading. # ###################################################################### ###################################################################### # NOTES: # # 1. Use of the par(fin) environment variable can be helpful # # when the desired mosaic is not square. # # 2. When using the student version of S-PLUS for Windows, # # limitations on the version may prevent drawing # # high-dimensional mosaics. # # 3. This file should be run (or source("mosaic.code")) with # # each new .Data directory. # ###################################################################### mosaic.cell <- function(X, x1, y1, x2, y2, off, dir, color, lablevx, lablevy, maxdim, currlev, label) { if (dir[1] == "v") { # split here on the X-axis. xdim <- maxdim[1] XP <- rep(0, xdim) for (i in 1:xdim) { XP[i] <- sum(X[X[,1]==i,ncol(X)]) / sum(X[,ncol(X)]) } white <- off[1] * (x2 - x1) / (max(1, xdim-1)) x.l <- x1 x.r <- x1 + (1 - off[1]) * XP[1] * (x2 - x1) if (xdim > 1) { for (i in 2:xdim) { x.l <- c(x.l, x.r[i-1] + white) x.r <- c(x.r, x.r[i-1] + white + (1 - off[1]) * XP[i] * (x2 - x1)) } } if (lablevx > 0) { if (is.na(label[[1]][1])) { this.lab <- paste(rep(as.character(currlev), length(currlev)), as.character(1:xdim), sep=".") } else { this.lab <- label[[1]] } text(x=(x.l + (x.r - x.l) / 2), y=(965 + 22 * (lablevx - 1)), srt=0,adj=.5, cex=.5, this.lab) } if (ncol(X) > 2) { # recursive call. for (i in 1:xdim) { if (XP[i] > 0) { mosaic.cell(as.matrix(X[X[,1]==i,2:ncol(X)]), x.l[i], y1, x.r[i], y2, off[2:length(off)], dir[2:length(dir)], color, lablevx-1, (i==1)*lablevy, maxdim[2:length(maxdim)], currlev+1, label[2:ncol(X)]) } else { segments(rep(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5, rep(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5) } } } else { for (i in 1:xdim) { if (XP[i] > 0) { polygon(c(x.l[i], x.r[i], x.r[i], x.l[i]), c(y1, y1, y2, y2), col=color[i]) segments(c(rep(x.l[i],3),x.r[i]), c(y1,y1,y2,y2), c(x.r[i],x.l[i],x.r[i],x.r[i]), c(y1,y2,y2,y1)) } else { segments(rep(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5, rep(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5) } } } } else { # split here on the Y-axis. ydim <- maxdim[1] YP <- rep(0, ydim) for (j in 1:ydim) { YP[j] <- sum(X[X[,1]==j,ncol(X)]) / sum(X[,ncol(X)]) } white <- off[1] * (y2 - y1) / (max(1, ydim - 1)) y.b <- y2 - (1 - off[1]) * YP[1] * (y2 - y1) y.t <- y2 if (ydim > 1) { for (j in 2:ydim) { y.b <- c(y.b, y.b[j-1] - white - (1 - off[1]) * YP[j] * (y2 - y1)) y.t <- c(y.t, y.b[j-1] - white) } } if (lablevy > 0) { if (is.na(label[[1]][1])) { this.lab <- paste(rep(as.character(currlev), length(currlev)), as.character(1:ydim), sep=".") } else { this.lab <- label[[1]] } text(x=(35 - 20 * (lablevy - 1)), y=(y.b + (y.t - y.b) / 2), srt=90, adj=.5, cex=.5, this.lab) } if (ncol(X) > 2) { # recursive call. for (j in 1:ydim) { if (YP[j] > 0) { mosaic.cell(as.matrix(X[X[,1]==j,2:ncol(X)]), x1, y.b[j], x2, y.t[j], off[2:length(off)], dir[2:length(dir)], color, (j==1)*lablevx, lablevy-1, maxdim[2:length(maxdim)], currlev+1, label[2:ncol(X)]) } else { segments(x1+(x2-x1)*c(0,2,4)/5, rep(y.b[j],3), x1+(x2-x1)*c(1,3,5)/5, rep(y.b[j],3)) } } } else{ # final split polygon and segments. for (j in 1:ydim) { if (YP[j] > 0) { polygon(c(x1,x2,x2,x1), c(y.b[j],y.b[j],y.t[j],y.t[j]), col=color[j]) segments(c(x1,x1,x1,x2), c(y.b[j],y.b[j],y.t[j],y.t[j]), c(x2,x1,x2,x2), c(y.b[j],y.t[j],y.t[j],y.b[j])) } else { segments(x1+(x2-x1)*c(0,2,4)/5, rep(y.b[j],3), x1+(x2-x1)*c(1,3,5)/5, rep(y.b[j],3)) } } } } } # end(function mosaic.cell) mosaic <- function(X, main=NA, sort=NA, off=NA, dir=NA, color=FALSE) { frame() par(usr=c(1,1000,1,1000)) if (is.vector(X)) { X <- array(X) } dimd <- length(dim(X)) if (!is.null(dimnames(X))) { label <- dimnames(X) } else { label <- NA } if (dimd>1) { Ind <- rep(1:(dim(X)[1]), prod(dim(X)[2:dimd])) for (i in 2:dimd) { Ind <- cbind(Ind, c(matrix(1:(dim(X)[i]), byrow=T, prod(dim(X)[1:(i-1)]), prod(dim(X)[i:dimd])))) } } else { Ind <- 1:(dim(X)[1]) } Ind <- cbind(Ind, c(X)) if (!is.na(main)) { title(main) } # Make the title. if ((is.na(off[1]))||(length(off)!=dimd)) { # Initialize spacing. off <- rep(10,50)[1:dimd] } if (is.na(dir[1])||(length(dir)!=dimd)) { # Initialize directions. dir <- rep(c("v","h"),50)[1:dimd] } if ((!is.na(sort[1]))&&(length(sort)==dimd)) { # Sort columns. Ind <- Ind[,c(sort,dimd+1)] off <- off[sort] dir <- dir[sort] label <- label[sort] } ncolors <- length(tabulate(Ind[,dimd])) if (is.na(color[1])) { color <- rep(0, ncolors) } else { if (length(color) != ncolors) { if (!color[1]) { color <- rep(0, ncolors) } else { color <- 2:(ncolors+1) } } } mosaic.cell(Ind, 50, 5, 950, 950, off/100, dir, color, 2, 2, apply(as.matrix(Ind[,1:dimd]), 2, max), 1, label) } ############################################################################# # Below is code to produce a sample mosaic. # # Y <- table(trunc(3*runif(1000)), trunc(3*runif(1000)), # trunc(5*runif(1000))-10, trunc(3*runif(1000))) # # dimnames(Y)[[2]] <- c("Cat", "Dog", "Horse") # # mosaic(Y, main="Sample Mosaic")