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 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
|
# Try to rewrite this for an arbitrary number of gaps
gap.plot<-function(x,y,gap,gap.axis="y",bgcol="white",breakcol="black",
brw=0.02,xlim,ylim,xticlab,xtics=NA,yticlab,ytics=NA,lty=rep(1,length(x)),
col=rep(par("col"),length(x)),pch=rep(1,length(x)),add=FALSE,...) {
if(missing(y) && !missing(x)) {
y<-x
x<-1:length(y)
}
if(missing(gap)) stop("gap must be specified")
gapsize<-diff(gap)
xaxl<-par("xlog")
yaxl<-par("ylog")
if(missing(ylim)) {
if(gap.axis == "y") {
if(length(gap) > 3) ylim<-c(min(y),max(y) - (gapsize[1] + gapsize[3]))
else ylim<-c(min(y),max(y)-gapsize[1])
if(missing(xlim)) xlim<-range(x)
}
}
if(missing(xlim)) {
if(gap.axis == "x") {
if(length(gap) > 3) xlim<-c(min(x),max(x) - (gapsize[1] + gapsize[3]))
else xlim<-c(min(x),max(x)-gapsize[1])
if(missing(ylim)) ylim<-range(y)
}
}
rangexy <- c(range(xlim),range(ylim))
xgw<-(rangexy[2]-rangexy[1])*brw
ygw<-(rangexy[4]-rangexy[3])*brw
if(is.na(xtics[1])) xtics<-pretty(x)
if(is.na(ytics[1])) ytics<-pretty(y)
if(missing(xticlab)) xticlab<-xtics
if(missing(yticlab)) yticlab<-ytics
if(length(col) < length(y)) col<-rep(col,length.out=length(y))
if(gap.axis == "y") {
littleones<-which(y < gap[1])
if(length(gap) > 3) {
middleones<-which(y >= gap[2] + ygw & y < gap[3])
bigones<-which(y >= gap[4] + ygw)
lostones<-sum(c(y > gap[1] & y < gap[2] + ygw,y > gap[3] & y < gap[4] + ygw))
}
else {
middleones<-NA
bigones<-which(y >= gap[2] + ygw)
lostones<-sum(y > gap[1] & y < gap[2] + ygw)
}
if(lostones) warning("some values of y will not be displayed")
}
else {
littleones<-which(x < gap[1])
if(length(gap) > 3) {
middleones<-which(x >= gap[2] + xgw & x < gap[3])
bigones<-which(x >= gap[4] + xgw)
lostones<-sum(c(x > gap[1] & x < gap[2] + xgw,x > gap[3] & x < gap[4] + xgw))
if(missing(xlim)) xlim<-c(min(x),max(x) - (gapsize[1] + gapsize[3]))
}
else {
middleones<-NA
bigones<-which(x >= gap[2])
lostones<-sum(x > gap[1] & x < gap[2] + xgw)
if(missing(xlim)) xlim<-c(min(x),max(x) - gapsize[1])
}
if(lostones) warning("some values of x will not be displayed")
if(missing(ylim)) ylim<-range(y)
}
if(length(lty) < length(x)) lty<-rep(lty,length.out=length(x))
if(length(col) < length(x)) col<-rep(col,length.out=length(x))
if(length(pch) < length(x)) pch<-rep(pch,length.out=length(x))
if(add) {
points(x[littleones],y[littleones],lty=lty[littleones],
col=col[littleones],pch=pch[littleones],...)
if(gap.axis == "y") {
if(length(gapsize) > 2) {
points(x[middleones],y[middleones]-gapsize[1],
lty=lty[middleones],col=col[middleones],pch=pch[middleones],...)
points(x[bigones],y[bigones] - (gapsize[1] + gapsize[3]),
lty=lty[bigones],col=col[bigones],pch=pch[bigones],...)
}
else points(x[bigones],y[bigones]-gapsize[1],
lty=lty[bigones],col=col[bigones],pch=pch[bigones],...)
}
else {
if(length(gapsize) > 2) {
points(x[middleones] - gapsize[1],y[middleones],
lty=lty[middleones],col=col[middleones],pch=pch[middleones],...)
points(x[bigones] - (gapsize[1] + gapsize[3]),y[bigones],
lty=lty[bigones],col=col[bigones],pch=pch[bigones],...)
}
else points(x[bigones]-gapsize[1],y[bigones],
lty=lty[bigones],col=col[bigones],pch=pch[bigones],...)
}
}
else {
plot(x[littleones],y[littleones],xlim=xlim,ylim=ylim,axes=FALSE,
lty=lty[littleones],col=col[littleones],pch=pch[littleones],...)
box()
if(gap.axis == "y") {
if(!is.na(xtics[1])) axis(1,at=xtics,labels=xticlab)
littletics<-which(ytics < gap[1])
if(length(gapsize) > 2) {
middletics<-which(ytics >= gap[2] & ytics <= gap[3])
bigtics<-which(ytics >= gap[4])
show.at<-c(ytics[littletics],ytics[middletics] - gapsize[1],
ytics[bigtics]-(gapsize[1] + gapsize[3]))
show.labels<-c(yticlab[littletics],yticlab[middletics],yticlab[bigtics])
}
else {
bigtics<-which(ytics >= gap[2])
show.at<-c(ytics[littletics],ytics[bigtics] - gapsize[1])
show.labels<-c(ytics[littletics],yticlab[bigtics])
}
axis(2,at=show.at,labels=show.labels)
axis.break(2,gap[1],style="gap",bgcol=bgcol,
breakcol=breakcol,brw=brw)
if(length(gapsize) > 2) {
axis.break(2,gap[3]-gapsize[1],style="gap",bgcol=bgcol,
breakcol=breakcol,brw=brw)
points(x[middleones],y[middleones]-gapsize[1],
lty=lty[middleones],col=col[middleones],pch=pch[middleones],...)
points(x[bigones],y[bigones]-(gapsize[1]+gapsize[3]),
lty=lty[bigones],col=col[bigones],pch=pch[bigones],...)
}
else points(x[bigones],y[bigones]-gapsize[1],
lty=lty[bigones],col=col[bigones],pch=pch[bigones],...)
}
# x gaps need to be fixed
else {
if(!is.na(ytics[1])) axis(2,at=ytics,labels=yticlab)
littletics<-which(xtics<gap[1])
if(length(gapsize) > 2) {
middletics<-which(xtics >= gap[2] & xtics <= gap[3])
bigtics<-which(xtics >= gap[4])
show.at<-c(xtics[littletics],xtics[middletics]-gapsize[1],
xtics[bigtics]-(gapsize[1]+gapsize[3]))
show.labels<-c(xticlab[littletics],xticlab[middletics],xticlab[bigtics])
}
else {
bigtics<-which(xtics >= gap[2])
show.at<-c(xtics[littletics],xtics[bigtics]-gapsize[1])
show.labels<-c(xticlab[littletics],xticlab[bigtics])
}
axis(1,at=show.at,labels=show.labels)
axis.break(1,gap[1],style="gap")
if(length(gapsize) > 2) {
axis.break(1,gap[3]-gapsize[1],style="gap")
points(x[middleones]-gapsize[1],y[middleones],
lty=lty[middleones],col=col[middleones],pch=pch[middleones],...)
points(x[bigones]-(gapsize[1]+gapsize[3]),y[bigones],
lty=lty[bigones],col=col[bigones],pch=pch[bigones],...)
}
else points(x[bigones]-gapsize[1],y[bigones],
lty=lty[bigones],col=col[bigones],pch=pch[bigones],...)
}
}
}
|