[R] Creating a Clustered-Stacked Column Chart

[Jim Lemon]

On 10/12/2009 01:53 AM, zhijie zhang wrote:
> Thanks. I think there may be no easy method to achive it.
>    library(lattice)
>    barchart(Titanic, scales = list(x = "free"),auto.key = list(title
> ="Survived"),layout=c(4,1),horizontal = FALSE)
> The above method generates four graphs, two graphs in the left are for
> children's male and female,respectively and the right two graphs are for
> adult's male and female,respectively .
>    Actually, i hope to generate two graphs finally. Say the right two graphs
> for adult are overlaid with the left two graphs for children,respectively.
> Take the  "1st of x variable" as an example, in the place of "1st", the
> stacked bar for both children and adult should be displayed. Maybe the data
> for children and adult should be first shifted certain values to different
> directions and then applying the overlay function to get it.
>    My above ideas to display a data may be bad. Anyway, thanks a lot.
>    
Hi Zhijie,
This looked like an interesting challenge, so I bent the barp function a 
bit to do it. The barp3 function attached will accept a 3D array in 
which the rows represent groups, the columns subgroups and the files 
sub-subgroups. The arrangement of bars is that of the example you gave. 
In order to translate the 2D matrix of the example to the 3D array, I 
have written a little conversion function df2array. Try this:

clustack<-structure(list(Country = structure(c(3L, 2L, 1L),
  .Label = c("Asia","Europe", "N Amer"), class = "factor"),
  Q1.pencils = c(16L, 14L,18L), Q1.pens = c(12L, 9L, 14L),
  Q2.pencils = c(18L, 15L, 18L), Q2.pens = c(14L, 11L, 15L),
  Q3.pencils = c(17L, 11L, 20L), Q3.pens = c(11L, 8L, 15L),
  Q4.pencils = c(20L, 14L, 21L), Q4.pens = c(14L, 12L, 16L)),
  .Names = c("Country", "Q1.pencils","Q1.pens", "Q2.pencils", "Q2.pens", 
"Q3.pencils", "Q3.pens","Q4.pencils", "Q4.pens"),
  class = "data.frame", row.names = c(NA,-3L))

# x is the original data frame with the group names in the
# first column and the column names as in the example
# I read it in as a CSV file.
# depth is the length of the "files" (3rd dimension)
df2array<-function(x,depth) {
  dimx<-dim(x)
  if(dimx[2]%%depth) stop("depth must divide number of columns without 
remainder")
  column.order<-NULL
  for(d in 1:depth)
   column.order<-c(column.order,seq(d,dimx[2]-(depth-d),by=depth))
  return(array(unlist(x[,column.order]),c(dimx[1],dimx[2]/depth,depth)))
}

# this converts the data frame to the array
pp.array<-df2array(clustack[,2:9],2)

# this function is pretty much the same as barp
barp3<-function(height,width=0.4,names.arg=NULL,
  legend.lab=NULL,legend.pos="e",col=NULL,border=par("fg"),
  main=NULL,xlab="",ylab="",xlim=NULL,ylim=NULL,
  staxx=FALSE,staxy=FALSE,height.at=NULL,
  height.lab=NULL,cex.axis=par("cex.axis"),
  do.first=NULL) {

  if(is.data.frame(height)) its_ok<-is.numeric(unlist(height))
  else its_ok<-is.numeric(height)
  if(!its_ok) stop("barp3 can only display bars with numeric heights")
  hdim<-dim(height)
  if(is.null(hdim) || length(hdim) != 3)
   stop("barp3 can only plot 3 dimensional arrays")
  ngroups<-hdim[1]
  if(length(col)==hdim[3])
   barcol<-array(rep(col,each=hdim[1]*hdim[2]),hdim)
  else barcol<-col
  if(is.null(xlim)) xlim<-c(0.4,ngroups+0.6)
  if(any(height<0,na.rm=TRUE))
   stop("Can't have negative bar heights in barp3")
  if(is.null(ylim)) {
   maxstack<-0
   for(group in 1:hdim[1]) {
    for(subgroup in 1:hdim[2]) {
     thistack<-sum(height[group,subgroup,],na.rm=TRUE)
     if(thistack > maxstack) maxstack<-thistack
    }
   }
   ylim<-c(0,maxstack*1.05)
  }
  plot(0,type="n",main=main,xlab=xlab,ylab=ylab,
   axes=FALSE,xlim=xlim,ylim=ylim,xaxs="i",yaxs="i")
  if(!is.null(do.first)) eval(do.first)
  if(is.null(names.arg)) names.arg<-1:ngroups
  if(staxx) {
   axis(1,at=1:ngroups,labels=rep("",ngroups),
    cex.axis=cex.axis)
   staxlab(1,at=1:ngroups,labels=names.arg,cex=cex.axis)
  }
  else axis(1,at=1:ngroups,labels=names.arg,cex.axis=cex.axis)
  if(is.null(height.at)) height.at<-pretty(ylim)
  if(is.null(height.lab)) height.lab<-pretty(ylim)
  if(staxy) {
   axis(2,at=height.at,labels=rep("",length(height.lab)),
    cex.axis=cex.axis)
   staxlab(2,at=height.at,labels=height.lab,cex=cex.axis)
  }
  else axis(2,at=height.at,labels=height.lab,cex.axis=cex.axis)
  barwidth<-2*width/hdim[2]
  for(group in 1:hdim[1]) {
   left<-group-hdim[2]*barwidth/2
   for(subgroup in 1:hdim[2]) {
    bottom<-0
    for(subsub in 1:hdim[3]) {
     rect(left,bottom,left+barwidth,
      bottom+height[group,subgroup,subsub],
      col=barcol[group,subgroup,subsub],border=border)
     bottom<-bottom+height[group,subgroup,subsub]
    }
    left<-left+barwidth
   }
  }
  if(!is.null(legend.lab)) {
   xjust<-yjust<-0.5
   if(is.null(legend.pos)) {
    cat("Click at the lower left corner of the legend\n")
    legend.pos<-locator(1)
    xjust<-yjust<-0
   }
   if(legend.pos[1] == "e")
    legend.pos<-emptyspace(barpinfo,bars=TRUE)
   legend(legend.pos,legend=legend.lab,fill=col,
    xjust=xjust,yjust=yjust)
  }
  box()
}

# the colors should be an array of the same form as the data
barp3(pp.array,col=array(rep(1:8,each=3),c(3,4,2)),
  names.arg=clustack[,1])

Have fun.

Jim