r - 带有 Y 轴中断和误差条的条形图

Question

我正在尝试制作一个带有错误条 y 轴中断的条形图。我知道 plotrix 包的 gap.plot 可以做到这一点，但我不喜欢锅的外观。我遵循了 HERE 给出的代码 它对我有用，只是我不知道如何放置错误栏。我的代码是这样的

# dataset:
data=data.frame(CAx=c(120),CAp=c(32),CTAx=c(12),CTAp=c(4),MTAX=c(6),MTSAx=c(3))

lower=c(0,55)
upper=c(95,140)
y_outer=21

lowspan=c(0,11)
topspan=c(lowspan[2]+1,21)

ylabel="y-axis value"
xlabel="x-axis value"
legendtext=c('C-Ax','C-Ap','CT-Ax','CT-Ap','MT-AX','MTS-Ax')

cnvrt.coords <-function(x,y=NULL){
  xy <- xy.coords(x,y, recycle=TRUE)
  cusr <- par('usr')
  cplt <- par('plt')  
  plt <- list()
  plt$x <- (xy$x-cusr[1])/(cusr[2]-cusr[1])
  plt$y <- (xy$y-cusr[3])/(cusr[4]-cusr[3])
  fig <- list()
  fig$x <- plt$x*(cplt[2]-cplt[1])+cplt[1]
  fig$y <- plt$y*(cplt[4]-cplt[3])+cplt[3]
  return( list(fig=fig) )
}

subplot <- function(fun, x, y=NULL){
  old.par <- par(no.readonly=TRUE)
  on.exit(par(old.par))
  xy <- xy.coords(x,y)
  xy <- cnvrt.coords(xy)$fig
  par(plt=c(xy$x,xy$y), new=TRUE)
  fun
  tmp.par <- par(no.readonly=TRUE)
  return(invisible(tmp.par))
}

plot(c(0,1),c(0,y_outer),type='n',axes=FALSE,ylab=ylabel,xlab='',lwd=7)
subplot(barplot(as.matrix(data),col=heat.colors(2),ylim=lower,xpd=FALSE,las=3),x=c(0,1),y=lowspan)

subplot(barplot(
as.matrix(data),
col=heat.colors(2),
ylim=upper,
xpd=FALSE,
names.arg=vector(mode="character",length=length(data))), 
x=c(0,1),
y=topspan)

lowertop=lowspan[2]+0.1     # Where to end the lower axis
breakheight=0.5   # Height of the break
upperbot=lowertop+breakheight # Where to start the upper axes
markerheight=0.4 # Heightdifference for the break markers
markerwidth=.04  # With of the break markers
abline(h = 0, col = "black")
lines(c(0,0),c(1,lowertop))
lines(c(markerwidth/-2,markerwidth/2),c(lowertop-        
markerheight/2,lowertop+markerheight/2))
lines(c(0,0),c(upperbot,14))
lines(c(markerwidth/-2,markerwidth/2),c(upperbot-    
markerheight/2,upperbot+markerheight/2))

情节是这样的

Answer 1

使用 subplot 对您有利，即它使用 cnvrt.coords 计算正确的坐标，并且 fun 可以是计算的任何表达式有了这些新坐标

因此，如果我们在子图函数中创建所需图形，则应使用新坐标。

data=data.frame(CAx=120,CAp=32,CTAx=12,CTAp=4,MTAX=6,MTSAx=3)

lower=c(0,55)
upper=c(95,140)
y_outer=21

lowspan=c(0,11)
topspan=c(lowspan[2]+1,21)

ylabel="y-axis value"
xlabel="x-axis value"
legendtext=c('C-Ax','C-Ap','CT-Ax','CT-Ap','MT-AX','MTS-Ax')

plot(c(0,1),c(0,y_outer),type='n',axes=FALSE,ylab=ylabel,xlab='',lwd=7)
subplot({
  y <- as.matrix(data)
  bp <- barplot(y,col=heat.colors(2),ylim=lower,xpd=FALSE,las=3)
  arrows(bp, y * .95, bp, y * 1.05, xpd = NA, angle = 90, code = 3,
         length = .1, col = ifelse(y > max(lower), 0, 1))
},x=c(0,1),y=lowspan)

subplot({
  bp <- barplot(y, col=heat.colors(2), ylim=upper, xpd=FALSE,
          names.arg=vector(mode="character",length=length(data)))
  arrows(bp, y * .95, bp, y * 1.05, xpd = NA, angle = 90, code = 3,
         length = .1, col = ifelse(y > max(lower), 1, 0))
}, x=c(0,1), y=topspan)