Deal with bar size and totals when ggplot position "stack" in split charts

Question

When using the "stack" style (not "dodge") as with geom_bar or geom_col the totals get compromised with log scale. I manage to represent the correct total in a simple way (split chart) when ONE of the values is conspicuously more frequent than others, see Workaround (not log). But, the total problem remains for other cases and log scales. I would ask for a universal -automated- solution.

EDIT: After reading ggplot scale_y_log10() issue, I found it makes no sense to use log. So the answer to this question, should be how to generalize the split approach = workaround - not only for one frequent group -.

mydf2<-data.frame(date=c(rep("2020-02-01",25),rep("2020-02-01",25),rep("2020-02-02",35),rep("2020-02-02",40) ),
                  value= c(rep(LETTERS[1],39),rep(LETTERS[1:3],4),rep(LETTERS[1],39),rep(LETTERS[2],35) ) , stringsAsFactors = FALSE)

dateValueCount<-setDT(mydf2)[, .N, by=.(date, value)]
dateValueCount
#          date value  N
# 1: 2020-02-01     A 43
# 2: 2020-02-01     B  4
# 3: 2020-02-01     C  3
# 4: 2020-02-02     C  1
# 5: 2020-02-02     A 39
# 6: 2020-02-02     B 35

library(scales)
prevalent1<-ggplot(mydf2, aes(date, fill = value)) + 
  geom_bar() + scale_y_continuous(breaks= breaks_pretty())

prevalent1log<-ggplot(mydf2, aes(date, fill = value)) + 
  geom_bar() +  scale_y_continuous(trans='log2', breaks = log_breaks(7), 
                                   labels= label_number_auto()
  )
# total Problem, real totals are 50 and 75
{
  require(grid)
  grid.newpage()
  pushViewport(viewport(layout = grid.layout(1, 2)))
  pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1))
  print(prevalent1,newpage=F) 
  popViewport()
  pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1))
  print( prevalent1log, newpage = F )
}

workaround (for only one prevalent value).

Answer should solve 2nd date and all possible cases over threshold

mydf3<-mydf2[which(mydf2$date=="2020-02-01")]

dateValueCount3<-dateValueCount[which(dateValueCount$date=="2020-02-01"),]
# get the most frequent per group

mydf3Max<-dateValueCount3[, .SD[  N== max(N) ]  , by=date]  
mydf3Max

#          date value  N
# 1: 2020-02-01     A 43


# totals per group
dateCount<-mydf3[, .N, by=.(date)]
dateCount
#          date  N
# 1: 2020-02-01 50

# transfer column to previous table
mydf3Max$totalDay <- dateCount$N[match(mydf3Max$date, dateCount$date)]

threshold <- 10 # splitting threshold

# remove groups with total lower than threshold
mydf3Max<-mydf3Max[which(mydf3Max$totalDay>threshold),]

# the final height of A will be dependent on the values of B and C
mydf3Max$diff<-mydf3Max$totalDay-mydf3Max$N

# shrinkFactor for the upper part of the plot which begins in threshold
shrinkFactor<-.05

# part of our frequent value (A) count must not be shrinked
mydf3Max$notshrink <- threshold - mydf3Max$diff

# part of A data (> threshold) must be shrinked
mydf3Max$NToShrink<-mydf3Max$N-mydf3Max$notshrink

mydf3Max$NToShrinkShrinked<-mydf3Max$NToShrink*shrinkFactor

# now sum the not-shrinked part with the shrinked part to obtain the transformed height
mydf3Max$NToShrinkShrinkedPlusBase<-mydf3Max$NToShrinkShrinked+mydf3Max$notshrink

# transformation function  - works for "dodge" position
# https://stackguides.com/questions/44694496/y-break-with-scale-change-in-r
trans <- function(x){pmin(x,threshold) + shrinkFactor*pmax(x-threshold,0)}
# dateValueCount3$transN <- trans(dateValueCount3$N)

setDF(dateValueCount3)
setDF(mydf3Max)

# pass transformed column to original d.f.
dateValueCount3$N2 <- mydf3Max$NToShrinkShrinkedPlusBase[match(interaction( dateValueCount3[c("value","date")]) ,
                                                              interaction( mydf3Max[c("value","date") ] )  )]

# substitute real N with transformed values
dateValueCount3[which(!is.na(dateValueCount3$N2)),]$N <- dateValueCount3[which(!is.na(dateValueCount3$N2)),]$N2

yticks <- c(0, 2,4,6,8,10,20,30,40,50)

ggplot(data=dateValueCount3, aes(date, N, group=value, fill=value)) + #group=longName
  geom_col(position="stack") +
  geom_rect(aes(xmin=0, xmax=3, ymin=threshold, ymax=threshold+.1), fill="white") +
  scale_y_continuous(breaks = trans(yticks), labels= yticks)

Answer 1

Solution based on accumulated sum an order of labels.

mydf2<-data.frame(date=c(rep("2020-02-01",25),rep("2020-02-01",25),rep("2020-02-02",35),rep("2020-02-02",40) ),
                  value= c(rep(LETTERS[1],27),rep(LETTERS[1:3],8),rep(LETTERS[1],35),rep(LETTERS[2],39) ) , stringsAsFactors = FALSE)
{
  summaryDT<-setDT(mydf2)[, .N, by=.(date, value)]

  # summaryDT <- summaryDT[order(summaryDT$N, decreasing = TRUE),] # for highest bars at top
  # summaryDT$NFac<-factor(summaryDT$N, levels = unique(summaryDT$N) ) #for highest bars at top

  # sort categories in the inverse order of labels
  summaryDT$value<-factor(summaryDT$value, levels=unique(summaryDT$value) )
  summaryDT<- summaryDT[order(summaryDT$date,-summaryDT$value)]

  # accum. per date
  # summaryDT<-summaryDT[order(date, N), .SD,by=.(date)]  # for highest bars at top
  summaryDT[, acc_sum := cumsum(N  ) , by= date]


  threshold<-20
  # problematic days, over thres.
  dVLtoTransfo <- summaryDT[which(summaryDT$acc_sum>threshold),]
  # accum. down per day - thres
  dVLtoTransfo$toShrink <- dVLtoTransfo$acc_sum-threshold
  # correct portion to shrink
  dVLtoTransfo$toShrink <- ifelse(dVLtoTransfo$toShrink>dVLtoTransfo$N,dVLtoTransfo$N,dVLtoTransfo$toShrink)

  # not to shrink portion
  dVLtoTransfo$notToShrink<- dVLtoTransfo$N-dVLtoTransfo$toShrink

  # shrinkFactor for the upper part of the plot which begins in threshold
  shrinkFactor<-.04

  dVLtoTransfo$NToShrinkShrinked<-dVLtoTransfo$toShrink*shrinkFactor

  # now sum the not-shrinked part with the shrinked part to obtain the transformed height
  dVLtoTransfo$NToShrinkShrinkedPlusBase<-dVLtoTransfo$NToShrinkShrinked+dVLtoTransfo$notToShrink

  # transformation function  - works for "dodge" position
  # https://stackguides.com/questions/44694496/y-break-with-scale-change-in-r
  trans <- function(x){pmin(x,threshold) + shrinkFactor*pmax(x-threshold,0)}
  # summaryDT$transN <- trans(summaryDT$N)

  setDF(summaryDT)
  setDF(dVLtoTransfo)
  # class(mydfAll)

  # pass transformed column to original d.f.

  summaryDT$N2 <- dVLtoTransfo$NToShrinkShrinkedPlusBase[match(interaction( summaryDT[c("value","date")]) ,
                                                               interaction( dVLtoTransfo[c("value","date") ] )  )]
  # substitute real N with transformed values
  summaryDT$NOld<-summaryDT$N

  summaryDT[which(!is.na(summaryDT$N2)),]$N <- summaryDT[which(!is.na(summaryDT$N2)),]$N2
  yticks <- c(0,4,8,12,16,20,40,60,80)
}

ggplot(data=summaryDT, aes(date, N, group=value, fill=value)) + # order by label order
# ggplot(data=summaryDT, aes(date, N, group=NFac, fill=value)) + # order by highest frequency
  geom_col(position="stack") +
  geom_rect(aes(xmin=0, xmax=3, ymin=threshold, ymax=threshold+.1), fill="white") +
  scale_y_continuous(breaks = trans(yticks), labels= yticks)