r - 显示百分比值的李克特图

Question

下面，我有绘制 Likert 图的 R 代码。

set.seed(1234)
library(e1071)
probs <- cbind(c(.4,.2/3,.2/3,.2/3,.4),c(.1/4,.1/4,.9,.1/4,.1/4),c(.2,.2,.2,.2,.2))
my.n <- 100
my.len <- ncol(probs)*my.n
raw <- matrix(NA,nrow=my.len,ncol=2)
raw <- NULL
for(i in 1:ncol(probs)){
  raw <- rbind(raw, cbind(i,rdiscrete(my.n,probs=probs[,i],values=1:5)))
}

r <- data.frame( cbind(
  as.numeric( row.names( tapply(raw[,2], raw[,1], mean) ) ),
  tapply(raw[,2], raw[,1], mean),
  tapply(raw[,2], raw[,1], mean) + sqrt( tapply(raw[,2], raw[,1], var)/tapply(raw[,2], raw[,1], length) ) * qnorm(1-.05/2,0,1),
  tapply(raw[,2], raw[,1], mean) - sqrt( tapply(raw[,2], raw[,1], var)/tapply(raw[,2], raw[,1], length) ) * qnorm(1-.05/2,0,1)
))
names(r) <- c("group","mean","ll","ul")

gbar <- tapply(raw[,2], list(raw[,2], raw[,1]), length)

sgbar <- data.frame( cbind(c(1:max(unique(raw[,1]))),t(gbar)) )

sgbar.likert<- sgbar[,2:6]



require(grid)
require(lattice)
require(latticeExtra)
require(HH)
sgbar.likert<- sgbar[,2:6]


yLabels = c(expression(a[1*x]),expression(b[2*x]),expression(c[3*x]))

likert(sgbar.likert,
       scales = list(y = list(labels = yLabels)),
       xlab="Percentage",
       main="Example Diverging Stacked Bar Chart for Likert Scale",
       BrewerPaletteName="Blues",
       sub="Likert Scale")

如下所示。但是，我想显示每个类别的百分比值，如下图所示。

我已经尝试过这个:

likert(sgbar.likert,
       scales = list(y = list(labels = yLabels)),
       xlab="Percentage",
       main="Example Diverging Stacked Bar Chart for Likert Scale",
       BrewerPaletteName="Blues",
       plot.percent.low=TRUE, # added this one
       plot.percent.high=TRUE, # added this one, too
       sub="Likert Scale")

但是，它没有任何影响，也没有任何区别。

那么，如何显示每个类别的百分比值？

Answer 1

据我所知，没有任何参数可以实现这一点，因此您需要定义一个自定义面板函数，如下所示:

### just reproduce your input
library(HH)
sgbar.likert <- data.frame(X1 = c(34L, 7L, 13L),X2 = c(1L, 4L, 13L),
                           X3 = c(7L, 84L, 24L), X4 = c(7L, 2L, 27L), X5 = c(51L, 3L, 23L))
yLabels = c(expression(a[1*x]),expression(b[2*x]),expression(c[3*x]))
### 

# store the original col names used in custom panel function
origNames <- colnames(sgbar.likert)

# define a custom panel function
myPanelFunc <- function(...){
  panel.likert(...)
  vals <- list(...)
  DF <- data.frame(x=vals$x, y=vals$y, groups=vals$groups)

  ### some convoluted calculations here...
  grps <- as.character(DF$groups)
  for(i in 1:length(origNames)){
    grps <- sub(paste0('^',origNames[i]),i,grps)
  }

  DF <- DF[order(DF$y,grps),]

  DF$correctX <- ave(DF$x,DF$y,FUN=function(x){
    x[x < 0] <- rev(cumsum(rev(x[x < 0]))) - x[x < 0]/2
    x[x > 0] <- cumsum(x[x > 0]) - x[x > 0]/2
    return(x)
  })

  subs <- sub(' Positive$','',DF$groups)
  collapse <- subs[-1] == subs[-length(subs)] & DF$y[-1] == DF$y[-length(DF$y)]
  DF$abs <- abs(DF$x)
  DF$abs[c(collapse,FALSE)] <- DF$abs[c(collapse,FALSE)] + DF$abs[c(FALSE,collapse)]
  DF$correctX[c(collapse,FALSE)] <- 0
  DF <- DF[c(TRUE,!collapse),]

  DF$perc <- ave(DF$abs,DF$y,FUN=function(x){x/sum(x) * 100})
  ###

  panel.text(x=DF$correctX, y=DF$y, label=paste0(DF$perc,'%'), cex=0.7)
}

# plot passing our custom panel function
likert(sgbar.likert,
       scales = list(y = list(labels = yLabels)),
       xlab="Percentage",
       main="Example Diverging Stacked Bar Chart for Likert Scale",
       BrewerPaletteName="Blues",
       panel=myPanelFunc,
       sub="Likert Scale")

代码相当复杂，但关键是面板函数接收(在省略号 ... 参数中)每个条形的 x,y 对坐标以及每个条形的组因子其中(组是原始 Likert 输入的列)。默认面板函数为panel.likert；因此，调用后，我们可以将更改添加到绘制的面板中(在本例中是根据条形坐标的标签)。

看似简单，但有两个问题:

1. 组在偶数时会被重新定义，因此中心列(在本例中为 "X3")分为两组:"X3" 和 "X3 阳性”。
2. 绘制的条形图是“堆叠的”，因此要正确计算它们的中心(为了放置标签)，您需要使用原始列名称排序来计算坐标的累积和。

上面的代码完成了所有这些计算，希望以一种非常通用的方式(阅读:你可以更改输入，它应该可以工作......)。