verteilt Dichte Parzellen mit ggplot

Question

Ich sah dieses große Grundstück von Fivethirty, die eine leichte Überlappung von Dichte Plots für verschiedene Hochschulen hat. Auschecken this link at fivethirtyeight.com

Wie würden Sie dieses Diagramm mit ggplot2 replizieren?

Insbesondere wie würden Sie bekommen, dass geringe Überlappung, facet_wrap ist nicht zur Arbeit gehen.

TestFrame <- 
    data.frame(
    Score = 
     c(rnorm(100, 0, 1) 
     ,rnorm(100, 0, 2) 
     ,rnorm(100, 0, 3) 
     ,rnorm(100, 0, 4) 
     ,rnorm(100, 0, 5)) 
    ,Group = 
     c(rep('Ones', 100) 
     ,rep('Twos', 100) 
     ,rep('Threes', 100) 
     ,rep('Fours', 100) 
     ,rep('Fives', 100)) 
) 

ggplot(TestFrame, aes(x = Score, group = Group)) + 
    geom_density(alpha = .75, fill = 'black') 

Answer 1

Wie immer bei ggplot wird der Schlüssel, um die Daten im richtigen Format bekommen, und dann ist das Plotten ziemlich einfach. Ich bin mir sicher, dass es eine andere Möglichkeit geben würde, dies zu tun, aber mein Ansatz war, die Dichteschätzung mit density() durchzuführen und dann eine Art Handbuch geom_density() mit geom_ribbon() anzufertigen, das eine ymin und ymax benötigt, um die Form aus der Bewegung zu entfernen x Achse.

Der Rest der Herausforderung bestand darin, die Reihenfolge des Druckens korrekt zu halten, da es so aussieht, als würde ggplot zuerst das breiteste Farbband drucken. Am Ende ist der Teil, der den umfangreichsten Code benötigt, die Produktion der Quartile.

Ich produzierte auch einige Daten, die ein bisschen mehr konsistent mit der ursprünglichen Figur ist.

library(ggplot2) 
library(dplyr) 
library(broom) 
rawdata <- data.frame(Score = rnorm(1000, seq(1, 0, length.out = 10), sd = 1), 
        Group = rep(LETTERS[1:10], 10000)) 

df <- rawdata %>% 
    mutate(GroupNum = rev(as.numeric(Group))) %>% #rev() means the ordering will be from top to bottom 
    group_by(Group, GroupNum) %>% 
    do(tidy(density(.$Score, bw = diff(range(.$Score))/20))) %>% #The original has quite a large bandwidth 
    group_by() %>% 
    mutate(ymin = GroupNum * (max(y)/1.5), #This constant controls how much overlap between groups there is 
     ymax = y + ymin, 
     ylabel = ymin + min(ymin)/2, 
     xlabel = min(x) - mean(range(x))/2) #This constant controls how far to the left the labels are 

#Get quartiles 
labels <- rawdata %>% 
    mutate(GroupNum = rev(as.numeric(Group))) %>% 
    group_by(Group, GroupNum) %>% 
    mutate(q1 = quantile(Score)[2], 
     median = quantile(Score)[3], 
     q3 = quantile(Score)[4]) %>% 
    filter(row_number() == 1) %>% 
    select(-Score) %>% 
    left_join(df) %>% 
    mutate(xmed = x[which.min(abs(x - median))], 
     yminmed = ymin[which.min(abs(x - median))], 
     ymaxmed = ymax[which.min(abs(x - median))]) %>% 
    filter(row_number() == 1) 

p <- ggplot(df, aes(x, ymin = ymin, ymax = ymax)) + geom_text(data = labels, aes(xlabel, ylabel, label = Group)) + 


geom_vline(xintercept = 0, size = 1.5, alpha = 0.5, colour = "#626262") + 
    geom_vline(xintercept = c(-2.5, -1.25, 1.25, 2.5), size = 0.75, alpha = 0.25, colour = "#626262") + 
    theme(panel.grid = element_blank(), 
     panel.background = element_rect(fill = "#F0F0F0"), 
     axis.text.y = element_blank(), 
     axis.ticks = element_blank(), 
     axis.title = element_blank()) 
for (i in unique(df$GroupNum)) { 
    p <- p + geom_ribbon(data = df[df$GroupNum == i,], aes(group = GroupNum), colour = "#F0F0F0", fill = "black") + 
    geom_segment(data = labels[labels$GroupNum == i,], aes(x = xmed, xend = xmed, y = yminmed, yend = ymaxmed), colour = "#F0F0F0", linetype = "dashed") + 
    geom_segment(data = labels[labels$GroupNum == i,], x = min(df$x), xend = max(df$x), aes(y = ymin, yend = ymin), size = 1.5, lineend = "round") 
} 
p <- p + geom_text(data = labels[labels$Group == "A",], aes(xmed - xlabel/50, ylabel), 
        label = "Median", colour = "#F0F0F0", hjust = 0, fontface = "italic", size = 4) 

bearbeiten bemerkte ich das Original tatsächlich ein bisschen fudging tut, indem jede Verteilung mit einer horizontalen Linie ausstreckt (Sie können eine sehen beitreten, wenn man genau hinschaut ...). Ich habe etwas ähnliches mit der zweiten geom_segment() in der Schleife hinzugefügt.

Answer 2

Obwohl bereits ein großer & akzeptierte Antwort verfügbar ist - beenden ich meinen Beitrag als Alternative Allee ohne Neuformatierung von Daten.

TestFrame <- 
    data.frame(
    Score = 
     c(rnorm(50, 3, 2)+rnorm(50, -1, 3) 
     ,rnorm(50, 3, 2)+rnorm(50, -2, 3) 
     ,rnorm(50, 3, 2)+rnorm(50, -3, 3) 
     ,rnorm(50, 3, 2)+rnorm(50, -4, 3) 
     ,rnorm(50, 3, 2)+rnorm(50, -5, 3)) 
    ,Group = 
     c(rep('Ones', 50) 
     ,rep('Twos', 50) 
     ,rep('Threes', 50) 
     ,rep('Fours', 50) 
     ,rep('Fives', 50)) 
) 

require(ggplot2) 
require(grid) 

spacing=0.05 

tm <- theme(legend.position="none",  axis.line=element_blank(),axis.text.x=element_blank(), 
      axis.text.y=element_blank(),axis.ticks=element_blank(), 
      axis.title.x=element_blank(),axis.title.y=element_blank(), 
      panel.grid.major = element_blank(), panel.grid.minor = element_blank(), 
      panel.background = element_blank(), 
      plot.background = element_rect(fill = "transparent",colour = NA), 
      plot.margin = unit(c(0,0,0,0),"mm")) 

firstQuintile = quantile(TestFrame$Score,0.2) 
secondQuintile = quantile(TestFrame$Score,0.4) 
median = quantile(TestFrame$Score,0.5) 
thirdQuintile = quantile(TestFrame$Score,0.6) 
fourthQuintile = quantile(TestFrame$Score,0.8) 

ymax <- 1.5*max(density(TestFrame[TestFrame$Group=="Ones",]$Score)$y) 
xmax <- 1.2*max(TestFrame$Score) 
xmin <- 1.2*min(TestFrame$Score) 

p0 <- ggplot(TestFrame[TestFrame$Group=="Ones",], aes(x = Score, group = Group)) + geom_density(fill = "transparent",colour = NA)+ylim(0-5*spacing,ymax)+xlim(xmin,xmax)+tm 
p0 <- p0 + geom_vline(aes(xintercept=firstQuintile),color="gray",size=1.2) 
p0 <- p0 + geom_vline(aes(xintercept=secondQuintile),color="gray",size=1.2) 
p0 <- p0 + geom_vline(aes(xintercept=thirdQuintile),color="gray",size=1.2) 
p0 <- p0 + geom_vline(aes(xintercept=fourthQuintile),color="gray",size=1.2) 
p0 <- p0 + geom_vline(aes(xintercept=median),color="darkgray",size=2) 
#previous line is a little hack for creating a working empty grid with proper sizing 
p1 <- ggplot(TestFrame[TestFrame$Group=="Ones",], aes(x = Score, group = Group)) + geom_density(alpha = .85, fill = 'black', color="white",size=1)+tm+ylim(0,ymax)+xlim(xmin,xmax)+ geom_segment(aes(y=0,x=median(Score),yend=max(density(Score)$y),xend=median(Score)), color="white", linetype=2) 
p2 <- ggplot(TestFrame[TestFrame$Group=="Twos",], aes(x = Score, group = Group)) + geom_density(alpha = .85, fill = 'black', color="white",size=1)+tm+ylim(0,ymax)+xlim(xmin,xmax)+ geom_segment(aes(y=0,x=median(Score),yend=max(density(Score)$y),xend=median(Score)), color="white", linetype=2) 
p3 <- ggplot(TestFrame[TestFrame$Group=="Threes",], aes(x = Score, group = Group)) + geom_density(alpha = .85, fill = 'black', color="white",size=1)+tm+ylim(0,ymax)+xlim(xmin,xmax)+ geom_segment(aes(y=0,x=median(Score),yend=max(density(Score)$y),xend=median(Score)), color="white", linetype=2) 
p4 <- ggplot(TestFrame[TestFrame$Group=="Fours",], aes(x = Score, group = Group)) + geom_density(alpha = .85, fill = 'black', color="white",size=1)+tm+ylim(0,ymax)+xlim(xmin,xmax)+ geom_segment(aes(y=0,x=median(Score),yend=max(density(Score)$y),xend=median(Score)), color="white", linetype=2) 
p5 <- ggplot(TestFrame[TestFrame$Group=="Fives",], aes(x = Score, group = Group)) + geom_density(alpha = .85, fill = 'black', color="white",size=1)+tm+ylim(0,ymax)+xlim(xmin,xmax)+ geom_segment(aes(y=0,x=median(Score),yend=max(density(Score)$y),xend=median(Score)), color="white", linetype=2) 

f <- grobTree(ggplotGrob(p1)) 
g <- grobTree(ggplotGrob(p2)) 
h <- grobTree(ggplotGrob(p3)) 
i <- grobTree(ggplotGrob(p4)) 
j <- grobTree(ggplotGrob(p5)) 



a1 <- annotation_custom(grob = f, xmin = xmin, xmax = xmax,ymin = -spacing, ymax = ymax) 
a2 <- annotation_custom(grob = g, xmin = xmin, xmax = xmax,ymin = -spacing*2, ymax = ymax-spacing) 
a3 <- annotation_custom(grob = h, xmin = xmin, xmax = xmax,ymin = -spacing*3, ymax = ymax-spacing*2) 
a4 <- annotation_custom(grob = i, xmin = xmin, xmax = xmax,ymin = -spacing*4, ymax = ymax-spacing*3) 
a5 <- annotation_custom(grob = j, xmin = xmin, xmax = xmax,ymin = -spacing*5, ymax = ymax-spacing*4) 

pfinal <- p0 + a1 + a2 + a3 + a4 + a5 
pfinal 

Answer 3

Mit engagierten geom_joy() von ggjoy package:

library(ggjoy) 

ggplot(TestFrame, aes(Score, Group)) + 
    geom_joy() 

# dummy data 
set.seed(1) 
TestFrame <- 
    data.frame(
    Score = 
     c(rnorm(100, 0, 1) 
     ,rnorm(100, 0, 2) 
     ,rnorm(100, 0, 3) 
     ,rnorm(100, 0, 4) 
     ,rnorm(100, 0, 5)) 
    ,Group = 
     c(rep('Ones', 100) 
     ,rep('Twos', 100) 
     ,rep('Threes', 100) 
     ,rep('Fours', 100) 
     ,rep('Fives', 100)) 
) 

head(TestFrame) 
#  Score Group 
# 1 -0.6264538 Ones 
# 2 0.1836433 Ones 
# 3 -0.8356286 Ones 
# 4 1.5952808 Ones 
# 5 0.3295078 Ones 
# 6 -0.8204684 Ones