1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
|
drawNestedBars<-function(x,start,end,shrink=0.1,errbars=FALSE,
label1="Overall",col=NA,labelcex=1,lineht=NA,showall=TRUE,
barlabels=NULL,showlabels=TRUE,arrow.cap=NA) {
barcol<-ifelse(is.list(col),col[[1]],col)
# may be only one bar per call
if(!is.null(x[[1]][[1]]) && (showall | length(x[[1]]) == 1))
rect(start,0,end,unlist(x[[1]][[1]]),col=barcol)
if(showlabels && !is.null(x[[1]][[1]])) {
if(!is.null(barlabels)) barlabel<-barlabels[[1]]
else
barlabel<-names(x[[1]][[1]])
labely<--lineht*length(x[[1]])
par(xpd=TRUE)
segments(c(start,end,start),c(0,0,labely),c(start,end,end),rep(labely,3))
boxed.labels((start+end)/2,labely,barlabel,ypad=1.4,
bg=ifelse(is.na(barcol),"white",barcol),cex=labelcex)
par(xpd=FALSE)
}
if(errbars && length(x[[1]])==1)
dispersion((start+end)/2,x[[1]][[1]],x[[2]][[1]],x[[3]][[1]],
intervals=errbars<3,arrow.cap=arrow.cap)
# remove the first component of each element of x displayed above
for(xcomp in 1:length(x)) x[[xcomp]][[1]]<-NULL
# if there are any more bars to display, set up the call
if(length(x[[1]])) {
# number of values in the new first component of x
nvalues<-length(unlist(x[[1]][[1]]))
# drop the color of the last bar
if(is.list(col)) col[[1]]<-NULL
# drop the top level barlabels if present
if(!is.null(barlabels) && length(barlabels) > 1) barlabels[[1]]<-NULL
# width of all the spaces between the next group of bars
barspace<-(end-start)*shrink
# width of each bar
barwidth<-((end-start)-barspace)/nvalues
# width of each space between bars
barspace<-barspace/(nvalues+1)
# step through the values for this group of bars
for(nextval in 1:nvalues) {
newx<-list()
# slice the x arrays for this set of values
for(xcomp in 1:length(x))
newx[[xcomp]]<-lapply(x[[xcomp]],sliceArray,nextval)
newbarlabels<-barlabels
start<-start+barspace
newcol<-col
if(is.list(col)) newcol[[1]]<-col[[1]][nextval]
if(!is.null(barlabels)) newbarlabels[[1]]<-barlabels[[1]][nextval]
drawNestedBars(newx,start,start+barwidth,shrink=shrink,
errbars=errbars,col=newcol,labelcex=labelcex,lineht=lineht,
showall=showall,barlabels=newbarlabels,showlabels=showlabels,
arrow.cap=arrow.cap)
#else print(newx)
start<-start+barwidth
}
}
}
|