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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
barp<-function(height,width=0.4,names.arg=NULL,legend.lab=NULL,legend.pos=NULL,
col=NULL,border=par("fg"),main=NULL,xlab="",ylab="",xlim=NULL,ylim=NULL,x=NULL,
staxx=FALSE,staxy=FALSE,height.at=NULL,height.lab=NULL,cex.axis=par("cex.axis"),
pch=NULL,cylindrical=FALSE,shadow=FALSE,do.first=NULL,ylog=FALSE,srt=NULL,...) {
height.class<-attr(height,"class")
if(!is.null(height.class)) {
if(inherits(height.class,"dstat")) {
md1<-length(height)
md2<-dim(height[[1]])[2]
meanmat<-matrix(NA,nrow=md1,ncol=md2)
colnames(meanmat)<-colnames(height[[1]])
for(row in 1:md1) meanmat[row,]<-height[[row]][1,]
height<-meanmat
}
if(inherits(height.class,"freq")) height<-height[[1]]
}
if(is.data.frame(height)) its_ok<-is.numeric(unlist(height))
else its_ok<-is.numeric(height)
if(!its_ok) stop("barp can only display bars with numeric heights")
hdim<-dim(height)
if(is.null(x)) x<-1:length(height)
if(is.null(hdim) || length(hdim) == 1) {
ngroups<-length(height)
barcol<-col
barpinfo<-list(x=x,y=height)
hdim<-NULL
}
else {
ngroups<-hdim[2]
x<-1:ngroups
if(!is.matrix(col) && length(col)==hdim[1])
barcol<-matrix(rep(col,each=ngroups),nrow=hdim[1],byrow=TRUE)
else barcol<-col
if(!is.matrix(pch) && length(pch)==hdim[1])
pch<-matrix(rep(pch,ngroups),nrow=hdim[1])
barpinfo<-list(x=matrix(rep(1:ngroups,each=hdim[1]),ncol=hdim[2]),
y=as.matrix(height))
}
if(is.null(xlim)) xlim<-range(x)+c(-0.6,0.6)
negy<-any(height<0,na.rm=TRUE)
if(is.null(ylim)) {
if(negy) miny<-min(height,na.rm=TRUE)*1.05
else miny<-ifelse(ylog,min(height)/10,0)
ylim<-c(miny,max(height,na.rm=TRUE)*1.05)
}
else miny<-ylim[1]
plot(ylim[1],type="n",main=main,xlab=xlab,ylab=ylab,axes=FALSE,xlim=xlim,
ylim=ylim,xaxs="i",yaxs="i",log=ifelse(ylog,"y",""),...)
if(!is.null(do.first)) eval(parse(text=do.first))
if(negy) abline(h=0)
if(is.null(names.arg)) names.arg<-x
# staxx=NA omits x axis
if(!is.na(staxx)) {
if(staxx) {
axis(1,at=x,labels=rep("",ngroups),cex.axis=cex.axis)
staxlab(1,at=x,labels=names.arg,cex=cex.axis,srt=srt)
}
else axis(1,at=x,labels=names.arg,cex.axis=cex.axis)
if(is.null(height.at)) {
if(ylog) height.at<-axTicks(2,log=TRUE)
else height.at<-pretty(ylim)
if(max(height.at) > max(height,na.rm=TRUE))
height.at<-height.at[-length(height.at)]
}
if(is.null(height.lab)) height.lab<-height.at
}
if(!is.na(staxy)) {
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,srt=srt)
}
else axis(2,at=height.at,labels=height.lab,cex.axis=cex.axis)
}
bottoms<-ifelse(negy,0,miny)
if(is.null(hdim)) {
if(shadow) {
for(bar in 1:ngroups)
polygon.shadow(c(x[bar]-width,x[bar]-width,x[bar]+width,x[bar]+width),
c(bottoms,height[bar],height[bar],bottoms),
offset=c(0.2*width,0.05*(height[bar]-ylim[2])))
}
if(cylindrical)
cylindrect(x-width,bottoms,x+width,height,col=barcol,
border=border)
else {
if(is.null(pch))
rect(x-width,bottoms,x+width,height,col=barcol,border=border)
else
rectFill(x-width,bottoms,x+width,height,bg="white",fg="black",
pch=pch)
}
}
else {
bottoms<-matrix(bottoms,nrow=hdim[1],ncol=hdim[2])
barwidth<-2*width/hdim[1]
for(subgroup in 1:hdim[1]) {
barpinfo$x[subgroup,]<-1:ngroups-width+(subgroup-0.5)*barwidth
if(shadow) {
for(bar in 1:ngroups) {
barleft<-bar-width+(subgroup-1)*2*width/hdim[1]
barright<-barleft+2*width/hdim[1]
polygon.shadow(c(barleft,barleft,barright,barright),
c(bottoms[bar],height[subgroup,bar],height[subgroup,bar],bottoms[bar]),
offset=c(0.2*width,0.05*(height[subgroup,bar]-ylim[2])))
}
}
if(cylindrical)
cylindrect(1:ngroups-width+(subgroup-1)*barwidth,bottoms[subgroup,],
1:ngroups-width+(subgroup)*barwidth,height[subgroup,],
col=barcol[subgroup,],border=border)
else {
if(is.null(pch))
rect(1:ngroups-width+(subgroup-1)*barwidth,bottoms[subgroup,],
1:ngroups-width+(subgroup)*barwidth,height[subgroup,],
col=barcol[subgroup,],border=border)
else
rectFill(1:ngroups-width+(subgroup-1)*barwidth,bottoms[subgroup,],
1:ngroups-width+(subgroup)*barwidth,height[subgroup,],
bg="white",fg="black",pch=pch[subgroup,])
}
}
}
if(!is.null(legend.lab)) {
xjust<-0
yjust<-1
if(is.null(legend.pos)) {
cat("Click at the upper left corner of the legend\n")
legend.pos<-locator(1)
}
legend(list(x=legend.pos[1],y=legend.pos[2]),legend=legend.lab,
fill=col,xjust=xjust,yjust=yjust)
}
box()
invisible(barpinfo)
}
|
