displaying percentage per category in likert stacked proportion barplots

Question

I'm a newbie (so sorry if this is too basic but) I'm trying to display percentages for each of my answer options in a Likert type dataset using the plot.likert() from 'HH' package. And, to some extent, I'm getting the desired result using the code below (which I took from likert plot showing percentage values), but the problem is that if there are no values for a particular category (= 0%) this would then clash with % value of the central category. see my output here

• Is there a way in which this code can be modified to prevent this from happening (e.g., not displaying category percentages that equal 0, or put them side-by-side)?

My df looks like this:

      Question Entirely Disagree Disagree Neutral Agree Entirely Agree
TQ_3      TQ_3                 3        4       4     2              1
TQ_4      TQ_4                 1        2       6     5              0
TQ_5      TQ_5                 2        3       3     5              1
TQ_6      TQ_6                 5        5       0     3              1
TQ_7      TQ_7                 0        1       1     6              6
TQ_8      TQ_8                 0        2       0     7              5
TQ_9      TQ_9                 2        1       4     3              4
TQ_10    TQ_10                 2        5       3     2              2

And the whole code I'm using is as follows:

# store the original col names used in custom panel function
origNames = colnames(summd_trDat)

# 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 <- round(ave(DF$abs,DF$y,FUN=function(x){x/sum(x) * 100}), 0)
  ###

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

# plot passing our custom panel function
plot.likert(summd_trDat,
            as.percent=TRUE, 
            main = "Graph title",
            xlab = "Percent",  
            positive.order = F, 
            ylab = "Question",    
            key.border.white=F,
            panel=myPanelFunc,    # ***
            rightAxis=F   
)

I've tried to solve this overplotting by including the following lines of code at the end of the function, just before calling panel.text(), but then it applies that to every instance of zeroes, even though the fixed=T argument of the gsub() is supposed to take the exact string as replacement criterion. So in the case where there should be a '50%' plotted, I get just a '5' instead. my output with this fix

new.labels = paste0(DF$perc,'%')
new.labels = gsub("0%", " ", new.labels, fixed = T)

I would really appreciate any help in this regard, I couldn't find an argument in the plot.likert() function that would do this, but as I mentioned, I'm not really experienced with this kind of things.

Answer 1

you should just replace the part about labels inside the custom function.

library(HH)

text <- "ID Question Entirely_Disagree Disagree Neutral Agree Entirely_Agree
TQ_3      TQ_3                 3        4       4     2              1
TQ_4      TQ_4                 1        2       6     5              0
TQ_5      TQ_5                 2        3       3     5              1
TQ_6      TQ_6                 5        5       0     3              1
TQ_7      TQ_7                 0        1       1     6              6
TQ_8      TQ_8                 0        2       0     7              5
TQ_9      TQ_9                 2        1       4     3              4
TQ_10    TQ_10                 2        5       3     2              2"

df <- read.table(text=text, header = TRUE)


origNames = colnames(df)

# 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 <- round(ave(DF$abs,DF$y,FUN=function(x){x/sum(x) * 100}), 0)


  ## Here goes 6 lines that have been changes - AK
  # here we modify the column with labels a bit:
  DF$perc <- paste0(DF$perc,'%')
  # change all "0%" to blanks
  DF$perc[DF$perc == "0%"] <- ""
  # the argument label is a bit modified too
  panel.text(x=DF$correctX, y=DF$y, label=DF$perc, cex=0.7)
}

# plot passing our custom panel function
p <- plot.likert(df,
            as.percent=TRUE, 
            main = "Graph title",
            xlab = "Percent",  
            positive.order = F,
            ylab = "Question",    
            key.border.white=F,
            panel=myPanelFunc,  
            rightAxis=F   
)

p