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
137
138
139
140
141
142
|
color.axis<-function(side=1,at=NULL,labels=TRUE,axlab=NA,axlab.at=NA,
col=par("fg"),cex.axis=par("cex.axis"),cex=par("cex")) {
xylim<-par("usr")
if(side %% 2) {
at.ok<-at >= xylim[1] & at <= xylim[2]
if(sum(at.ok) < length(at)) {
at<-at[at.ok]
labels<-labels[at.ok]
}
}
else {
at.ok<-at >= xylim[3] & at <= xylim[4]
if(sum(at.ok) < length(at)) {
at<-at[at.ok]
labels<-labels[at.ok]
}
}
axis(side=side,at=at,labels=rep("",length(at)),col=col)
if(labels[1] == TRUE && length(labels) == 1) labels<-at
mtext(labels,side=side,at=at,line=0.7,col=col,cex=cex.axis)
if(!is.na(axlab)) {
if(is.na(axlab.at))
axlab.at<-ifelse(side%%2,sum(xylim[1:2])/2,sum(xylim[3:4])/2)
mtext(axlab,side=side,at=axlab.at,line=2,col=col,cex=cex)
}
if(side == 1) abline(h=xylim[3],col=col)
if(side == 2) abline(v=xylim[1],col=col)
if(side == 3) abline(h=xylim[4],col=col)
if(side == 4) abline(v=xylim[2],col=col)
}
twoord.plot<-function(lx,ly,rx,ry,data=NULL,main="",xlim=NULL,lylim=NULL,
rylim=NULL,mar=c(5,4,4,4),lcol=1,rcol=2,xlab="",
lytickpos=NA,ylab="",ylab.at=NA,rytickpos=NA,rylab="",rylab.at=NA,
lpch=1,rpch=2,type="b",xtickpos=NULL,xticklab=NULL,halfwidth=0.4,
axislab.cex=1,do.first=NULL,xaxt="s",...) {
if(!is.null(data)) {
ly<-unlist(data[ly])
ry<-unlist(data[ry])
if(missing(lx)) lx<-1:length(ly)
else lx<-unlist(data[lx])
if(missing(rx)) rx <- 1:length(ry)
else rx<-unlist(data[rx])
}
if(missing(lx)) lx<-1:length(ly)
if(missing(ry)) {
if(missing(rx)) {
rx<-1:length(ry)
ry<-ly
ly<-lx
lx<-1:length(ly)
}
else {
ry<-rx
rx<-1:length(ry)
}
}
oldmar<-par("mar")
par(mar=mar)
if(is.null(xlim)) xlim<-range(c(lx,rx))
if(missing(lx)) lx<-1:length(ly)
if(is.null(lylim)) {
lylim<-range(ly,na.rm=TRUE)
lyspan<-diff(lylim)
if(lyspan == 0) lyspan<-lylim[1]
lylim[2]<-lylim[2]+lyspan*0.04
if(lylim[1] != 0) lylim[1]<-lylim[1]-lyspan*0.04
}
if(length(type) < 2) type<-rep(type,2)
# first display the "left" plot
if(match(type[1],"bar",0)) {
oldcex<-par(cex=axislab.cex)
plot(lx,ly,xlim=xlim,ylim=lylim,xlab=xlab,ylab="",yaxs="i",type="n",
main="",axes=FALSE,...)
par(oldcex)
if(!is.null(do.first)) eval(parse(text=do.first))
ybottom<-par("usr")[3]
if (lylim[1] < 0) abline(h=0,lty=2)
rect(lx-halfwidth,ifelse(ly<0,ly,ybottom),lx+halfwidth,
ifelse(ly>0,ly,0),col=lcol)
}
else {
oldcex<-par(cex=axislab.cex)
plot(lx,ly,xlim=xlim,ylim=lylim,xlab=xlab,ylab="",yaxs="i",type="n",
main="",axes=FALSE,...)
par(oldcex)
if(!is.null(do.first)) eval(parse(text=do.first))
points(lx,ly,col=lcol,pch=lpch,type=type[1],...)
}
title(main=main)
xylim<-par("usr")
#mtext(ylab,2,2,col=lcol,cex=axislab.cex)
box()
if(xaxt != "n") {
# display the X axis
if(inherits(lx,"POSIXt")) axis.POSIXct(1)
else {
if(is.null(xticklab)) axis(1,cex.axis=axislab.cex)
else {
if(is.null(xtickpos)) xtickpos<-1:length(xticklab)
axis(1,at=xtickpos,labels=xticklab,cex.axis=axislab.cex)
}
}
}
# display the left axis
if(is.na(lytickpos[1])) lytickpos<-pretty(ly)
if(is.na(ylab.at)) ylab.at<-mean(lytickpos)
color.axis(2,at=lytickpos,axlab=ylab,axlab.at=ylab.at,
col=ifelse(is.na(lcol),1,lcol),cex.axis=axislab.cex,cex = axislab.cex)
# get the "right" y limits
if(is.null(rylim)) {
rylim<-range(ry,na.rm=TRUE)
ryspan<-diff(rylim)
if(ryspan == 0) ryspan<-rylim[1]
rylim[2]<-rylim[2]+ryspan*0.04
if(rylim[1] != 0) rylim[1]<-rylim[1]-ryspan*0.04
}
# multiplier for the "right" y values
ymult<-diff(lylim)/diff(rylim)
# offset for the "right" y values
yoff<-lylim[1]-rylim[1]*ymult
if(match(type[2],"bar",0)) {
if(rylim[1] < 0) abline(h=0,lty=2)
rect(rx-halfwidth,ifelse(ry<0,ry,rylim[1]*ymult+yoff),rx+halfwidth,
ifelse(ry>0,ry*ymult+yoff,0),col=rcol)
}
else points(rx,ry*ymult+yoff,col=rcol,pch=rpch,type=type[2],...)
if(is.na(rytickpos[1])) rylabels<-pretty(rylim)
else rylabels<-rytickpos
if(min(rylabels) < rylim[1]) rylabels<-rylabels[rylabels >= rylim[1]]
if(max(rylabels) > rylim[2]) rylabels<-rylabels[rylabels <= rylim[2]]
axat<-rylabels*ymult+yoff
if(is.na(rylab.at)) rylab.at<-mean(rytickpos)
if(!is.na(rylab.at)) rylab.at<-rylab.at*ymult+yoff
# display the right axis
color.axis(4,at=axat,labels=rylabels,axlab=rylab,
axlab.at=rylab.at,col=ifelse(is.na(rcol),1,rcol),
cex.axis=axislab.cex,cex=axislab.cex)
par(mar=oldmar,new=FALSE,col.axis="black")
}
|
