Пирамидальный (не правый angular) сложенный барплот в R

Question

Используя следующий код, я могу создать простой составной барплот, имеющий правильную angular форму:

barplot(as.matrix(prop.table(c(150,90,60))),col=c('Cornflowerblue','Yellow','Red'),las=1)

Результат выглядит следующим образом

Однако я хочу построить столбчатую диаграмму, которая является пирамидой, так чтобы разбивка процентов была по площади, а не по длине. Поскольку верхушка пирамиды имеет гораздо меньшую площадь, чем дно, соответствующий участок пирамиды должен выглядеть примерно так

Я просто не уверен как закодировать такой сюжет в R. Любое предложение будет оценено.

Answer 1

Вот функция, которая создаст точки для полигонов для вас

get_pyramid_layers  <- function(vals, a=1, pad=FALSE) {
  vals <- vals/sum(vals)
  area <- function(y1, y2) {
    .5*(y2-y1)*(2*a-2*sqrt(3)/4*(y2+y1))
  }
  xdist <- function(y) {
    a/2 - y*sqrt(3)/3
  }

  max_height <- a*sqrt(3)/2
  total_area <- area(0, max_height)
  breaks <- rep(0, length(vals) +1 )
  for(i in seq_along(vals)) {
    breaks[i+1] <- optimise(function(x) (area(breaks[i], x)/total_area-vals[i])^2, lower = 0, upper=max_height)$minimum
  }
  padding <- if(pad) {cbind(x=NA,y=NA)} else {NULL}
  as.data.frame(do.call("rbind", lapply(seq_along(vals), function(i) {
  cbind(rbind(
    cbind(x=c(-1,1)*xdist(breaks[i]), y=breaks[i]),
    cbind(x=c(1,-1)*xdist(breaks[i+1]), y=breaks[i+1]),
    padding
  ), prop=vals[i], index=i)})))
}

Я не уверен, что она оптимизирована на 100%, но она должна сработать. Вы можете создать базовый c график в ggplot с помощью

library(ggplot2)
vals <- c(.5, .3, .2)
ggplot(get_pyramid_layers(vals), aes(x,y)) + 
  geom_polygon(aes(fill=factor(index))) +
  coord_fixed()

Это должно работать с пропорциями в любом порядке

vals <- c(.2, .1, .3, .4)
ggplot(get_pyramid_layers(vals), aes(x,y)) + 
  geom_polygon(aes(fill=factor(index))) +
  coord_fixed()

Вы также можете добавить метки с помощью

library(dplyr)
vals <- c(.5, .3, .2)
pyramid_data <- get_layers(vals) 
pyramid_labels <- pyramid_data %>% group_by(index) %>% summarize(x=mean(x), y=mean(y), prop=first(prop)) 
ggplot(pyramid_data, aes(x,y)) + 
  geom_polygon(aes(fill=factor(index))) +
  geom_text(aes(label=scales::percent(prop, accuracy=1)), data=pyramid_labels, color="white") + 
  coord_fixed()

И если вы хотите использовать базовую графику, вы можете сделать

vals <- c(.5, .3, .2)
plot(c(-.5, .5), c(0, .85), type="n")
with(get_pyramid_layers(vals, pad=TRUE), 
  polygon(x,y, col=c('Cornflowerblue','Yellow','Red')))