I would like a chart that as a function of the day in the year, advances from 0 -> 100% in both x and y axes (where each axis is a separate metric). Depending on where the data is relative to the day in the year, I'd like to show whether that's good or bad. Quite simply, I can show it like this:
So the above plot shows we're in a good sitaution because the "tip" (darkest biggest points) are past the 50% mark (and assume we are 50% through the year). But I wanted to add gradient lines around the horizontal and vertical lines to show more nuance. Here's an explanation of the areas (first drawing is the explanation... and the second one is the way I would like to show this in ggplot... with the area fully filled-in.
This is how far I have come in ggplot:
Problems I'm having:
For some reason, the vertical gradient isn't accepting the alpha parameter
I can't assign two different gradients, once I define the gradient, it applies to the vertical and horizontal one.
This looks terrible. Is there a better approach I should be following?
Are Problems 1-2 solvable? If anyone has a better approach not using geom_line, please feel free to suggest approach.
EDIT: As the lines move, so would the gradients, so a static background wouldn't work here.
Code follows:
dff <- data.frame(x = 1:60+(runif(n = 60,-2,2)),
y = 1:60+(runif(n = 60,-2,2)),
z = 1:60)
dfgrad <- data.frame(static = c(rep(50,1000)), line = seq(0,100,length.out=100))
## To see the gradientlines thinner, change the size on the geom_line to like 200
ggplot(dff,aes(x,y)) +
geom_line(data = dfgrad, aes(x=static, y=line, color=line),size=1000,alpha=0.5) +
geom_line(data = dfgrad, aes(x=line, y=static, color=line),size=1000,alpha=0.5) +
scale_colour_gradientn( colours = c( "yellow", "darkgreen","darkred"),
breaks = c( 0, 3, 100),
limits = c( 0,100)) +
geom_hline(yintercept = 50, linetype="dashed") +
geom_vline(xintercept = 50, linetype="dashed") +
geom_point(aes(alpha=dff$z,size= (dff$z))) +
theme(legend.position="none") +
scale_x_continuous(expand = c(0, 0)) + scale_y_continuous(expand = c(0, 0))
FINAL EDIT: The submitted answer is correct, but in order to change the gradient depending on the "today" lines, I had to mess with it a bit more... so I paste it here in case it's useful to anyone:
g1 <- colorRampPalette(c("darkgreen", "darkgreen","red"))(20) %>%
alpha(0.3) %>% matrix(ncol=1) %>% # up and down gradient
rasterGrob(width = 1, height = 1) # full-size (control it by ggplot2)
g2 <- colorRampPalette(c("yellow", "darkgreen","red"))(20) %>%
alpha(0.3) %>% matrix(nrow=1) %>% # left and right gradient
rasterGrob(width = 1, height = 1)
timeOfYear <- 5
maxx <- max(timeOfYear,(100-timeOfYear))
ggplot(dff,aes(x,y)) +
annotation_custom(g1, xmin = timeOfYear-maxx, xmax = timeOfYear+maxx, ymin = timeOfYear-maxx, ymax = timeOfYear+maxx) +
annotation_custom(g2, xmin = timeOfYear-maxx, xmax = timeOfYear+maxx, ymin = timeOfYear-maxx, ymax = timeOfYear+maxx) +
# annotation_custom(g1, xmin = 35, xmax = 65, ymin = -3, ymax = 100) +
# annotation_custom(g2, xmin = -3, xmax = 100, ymin = 35, ymax = 65) +
geom_hline(yintercept = timeOfYear, linetype="dashed") +
geom_vline(xintercept = timeOfYear, linetype="dashed") +
geom_point(aes(alpha=dff$z,size= (dff$z))) +
theme(legend.position="none") +
coord_cartesian(xlim = c(0, 100), ylim = c(0, 100), expand = F)
If I were you, I'd make rectangles by grid package and put them on the graph using annotation_custom(). (your problem.1 is due to overlaying, try alpha=0.05)
Here is my example:
library(ggplot2); library(grid); library(dplyr)
g1 <- colorRampPalette(c("yellow", "darkgreen","darkred"))(20) %>%
alpha(0.5) %>% matrix(ncol = 1) %>% # up and down gradient
rasterGrob(width = 1, height = 1) # full-size (control it by ggplot2)
g2 <- colorRampPalette(c("cyan", "darkgreen","darkblue"))(20) %>%
alpha(0.5) %>% matrix(nrow = 1) %>% # left and right gradient
rasterGrob(width = 1, height = 1)
ggplot(dff,aes(x,y)) +
annotation_custom(g1, xmin = 35, xmax = 65, ymin = -3, ymax = 100) +
annotation_custom(g2, xmin = -3, xmax = 100, ymin = 35, ymax = 65) +
geom_hline(yintercept = 50, linetype="dashed") +
geom_vline(xintercept = 50, linetype="dashed") +
geom_point(aes(alpha=dff$z,size= (dff$z))) +
theme(legend.position="none") +
coord_cartesian(xlim = c(-3, 100), ylim = c(-3, 100), expand = F)
[EDITED]
Here is my approach to keep the same degree of gradient for each timeOfYear (I refered to #Amit Kohli's code) (left graph is concept);
# I added both limits colors as outside colors
# to avoid that graph becomes almost green when timeOfYear is about 50.
g1.2 <- c(rep("yellow", 5), colorRampPalette(c("yellow", "darkgreen","red"))(20), rep("red", 5)) %>%
rev() %>% alpha(0.3) %>% matrix(ncol=1) %>% rasterGrob(width = 1, height = 1)
g2.2 <- c(rep("yellow", 5), colorRampPalette(c("yellow", "darkgreen","red"))(20), rep("red", 5)) %>%
alpha(0.3) %>% matrix(nrow=1) %>% rasterGrob(width = 1, height = 1)
timeOfYear <- 5
ggplot(dff, aes(x, y)) +
annotation_custom(g1.2, timeOfYear - 100, timeOfYear + 100, timeOfYear - 100, timeOfYear + 100) +
annotation_custom(g2.2, timeOfYear - 100, timeOfYear + 100, timeOfYear - 100, timeOfYear + 100) +
geom_hline(yintercept = timeOfYear, linetype="dashed") +
geom_vline(xintercept = timeOfYear, linetype="dashed") +
geom_point(aes(alpha=dff$z,size= (dff$z))) +
theme(legend.position="none") +
coord_cartesian(xlim = c(0, 100), ylim = c(0, 100), expand = F)
If you need, SpaDES::divergentColors() gives you a color-vector with non-symmetric range (probably some packages have a similar function).
library(SpaDES)
timeOfYear <- 5
# ?divergentColors(start.color, end.color, min.value, max.value, mid.value = 0, mid.color = "white")
# It makes a vector of colors (length: max.value - min.value)
# and you can define mid.color's val (i.e., position)
g3 <- divergentColors("yellow", "red", 0, 100, timeOfYear, mid.color = "darkgreen") %>%
rev() %>% alpha(0.3) %>% matrix(ncol = 1) %>% rasterGrob(width = 1, height = 1)
g4 <- divergentColors("yellow", "red", 0, 100, timeOfYear, mid.color = "darkgreen") %>%
alpha(0.3) %>% matrix(nrow = 1) %>% rasterGrob(width = 1, height = 1)
ggplot(dff,aes(x,y)) +
annotation_custom(g3, xmin = 0, xmax = 100, ymin = 0, ymax = 90) +
annotation_custom(g4, xmin = 0, xmax = 90, ymin = 0, ymax = 100) +
geom_hline(yintercept = timeOfYear, linetype="dashed") +
geom_vline(xintercept = timeOfYear, linetype="dashed") +
geom_point(aes(alpha=dff$z,size= (dff$z))) +
theme(legend.position="none") +
coord_cartesian(xlim = c(0, 100), ylim = c(0, 100), expand = F)
Related
I have created a random walk plot using ggplot2 (code below). I wondered if it would be possible to use the gganimate package so that the random walk process (the black line in the plot) gradually appears but stops once it touches the grey horizontal dashed line.
set.seed(3344)
create_random_walk <- function(number=500){
data.frame(x = rnorm(number),
rown = c(1:500)) %>%
mutate(xt = cumsum(x))
}
randomwalkdata <- rbind(mutate(create_random_walk(), run = 1))
p <- ggplot(randomwalkdata, aes(x = rown, y = xt)) +
geom_line() +
labs(x = '\nTime (arbitrary value)', y = 'Evidence accumulation\n') +
theme_classic()
p + geom_segment(aes(x = 0.5, xend = 500, y = 25, yend = 25, linetype = 2), colour = "grey", size = 1, show.legend = FALSE) +
scale_linetype_identity()
Can anybody help?
library(gganimate); library(dplyr)
animate(
ggplot(randomwalkdata |> filter(cumsum(lag(xt, default = 0) >= 25) == 0),
aes(x = rown, y = xt)) +
geom_line() +
geom_point(data = . %>% filter(rown == max(rown)),
size = 10, shape = 21, color = "red", stroke = 2) +
labs(x = '\nTime (arbitrary value)', y = 'Evidence accumulation\n') +
theme_classic() +
annotate("segment", x = 0.5, xend = 500, y = 25, yend = 25, linetype = 2,
colour = "grey", linewidth = 1) +
scale_linetype_identity() +
transition_reveal(rown),
end_pause = 20, width = 600)
I've created a plot withgeom_rect and added the annotation with geom_text_repel but when I want to create several plots where I zoom in part of the original plot. The labels of the regions outside the zoom area also appear.
This is a minimal example:
start = c(1, 5,8, 14, 19, 25)
end =c(3, 6,12, 16, 22, 30)
label = c(1,2,3, 4, 5, 6)
library(ggplot2)
library(ggrepel)
regions = tibble::tibble(label, start, end)
ggplot() +
scale_x_continuous() +
scale_y_continuous(name = "") +
geom_rect(
data = regions,
mapping = aes(
xmin = start,
xmax = end,
ymin = 1.5,
ymax = 1.8),
color = "black",
fill = "#56B4E9"
) +
geom_text_repel(
data = regions,
aes(
x = start + (end - start) / 2,
y = 1.8,
label = label,
),
size = 10,
force_pull = 0,
nudge_y = 0.05,
direction = "x",
angle = 90,
vjust = 0,
segment.size = 0.5,
) +
ylim(1.38, 2.2) +
ylab("") +
xlab("") +
theme_minimal()
This code generates this plot:
I want to zoom into box 3, so I tried adding + xlim(8,12) or +facet_zoom(xlim = c(8, 12)) but The zoomed plot has the annotation (labels) of box 1, box2, ... on the side as you can see here (1,2 in the right and 4,5,6 on the left of the zoomed plot)
and similar result with + xlim(8,12)
How can I remove the labels (annotation) outside the zoomed area (1,2 in the right and 4,5,6 on the left of the zoomed plot?)
There are two quick fixes I can think of, where the first is the one you already mentioned. Perhaps you mistyped it, as I can run it fine.
Set xlim(8,12)
library(ggrepel)
start = c(1, 5,8, 14, 19, 25)
end =c(3, 6,12, 16, 22, 30)
label = c(1,2,3, 4, 5, 6)
regions = data.frame(label, start, end)
ggplot() +
scale_x_continuous() +
scale_y_continuous(name = "") +
geom_rect(
data = regions,
mapping = aes(
xmin = start,
xmax = end,
ymin = 1.5,
ymax = 1.8),
color = "black",
fill = "#56B4E9"
) +
geom_text_repel(
data = regions,
aes(
x = start + (end - start) / 2,
y = 1.8,
label = label,
),
size = 10,
force_pull = 0,
nudge_y = 0.05,
direction = "x",
angle = 90,
vjust = 0,
segment.size = 0.5,
) +
ylim(1.38, 2.2) +
xlim(8, 12) +
ylab("") +
xlab("") +
theme_minimal()
If I run this I obtain the following image
However, using xlim() is not always advised as it throws away all the other points which do not meet the condition. Although for your case that might be favourable.
Subsetting regions and zooming in properly using coord_cartesian().
ggplot() +
scale_x_continuous() +
scale_y_continuous(name = "") +
geom_rect(
data = regions,
mapping = aes(
xmin = start,
xmax = end,
ymin = 1.5,
ymax = 1.8),
color = "black",
fill = "#56B4E9"
) +
geom_text_repel(
data = subset(regions, label == 3),
aes(
x = start + (end - start) / 2,
y = 1.8,
label = label,
),
size = 10,
force_pull = 0,
nudge_y = 0.05,
direction = "x",
angle = 90,
vjust = 0,
segment.size = 0.5,
) +
ylim(1.38, 2.2) +
coord_cartesian(xlim = c(8, 12)) +
ylab("") +
xlab("") +
theme_minimal()
This produces the same image (as far as I can tell)
I saw this great plot from fivethirty that has a slight overlap of density plots for different colleges. Check out this link at fivethirtyeight.com
How would you replicate this plot with ggplot2?
Specifically how would you get that slight overlap, facet_wrap isn't going to work.
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')
As always with ggplot, the key is getting the data in the right format, and then the plotting is pretty straightforward. I'm sure there would be another way to do this, but my approach was to do the density estimation with density() and then to make a sort of manual geom_density() with geom_ribbon(), which takes a ymin and ymax, necessary for moving the shape off the x axis.
The rest of the challenge was in getting the order of the printing correct, since it seems that ggplot will print the widest ribbon first. In the end, the part that requires the bulkiest code is the production of the quartiles.
I also produced some data that is a bit more consistent with the original figure.
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)
Edit
I noticed the original actually does a bit of fudging by stretching out each distribution with a horizontal line (you can see a join if you look closely...). I added something similar with the second geom_segment() in the loop.
Although there is a great & accepted answer available already - I finished my contribution as an alternative avenue without data reformatting.
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
Using dedicated geom_joy() from 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
I'd like to create a chart displaying the size of the seats to a parliament, such as the one below, in ggplot2. My main problem is, essentially, how do I turn a donut chart to a half-donut chart (half-circle arc)?
Using the picture above as an example, I don't know where to go from here:
df <- data.frame(Party = c("GUE/NGL", "S&D", "Greens/EFA", "ALDE", "EPP", "ECR", "EFD", "NA"),
Number = c(35, 184, 55, 84, 265, 54, 32, 27))
df$Party <- factor(df$Party)
df$Share <- df$Number / sum(df$Number)
df$ymax <- cumsum(df$Share)
df$ymin <- c(0, head(df$ymax, n= -1))
ggplot(df, aes(fill = Party, ymax = ymax, ymin = ymin, xmax = 2, xmin = 1)) + geom_rect() +
coord_polar(theta = "y") + xlim(c(0, 2))
To get labels etc you can use unit circle properties! I wrote a small function trying to recreate the style of the plot in your question :)
library(ggforce)
parlDiag <- function(Parties, shares, cols = NULL, repr=c("absolute", "proportion")) {
repr = match.arg(repr)
stopifnot(length(Parties) == length(shares))
if (repr == "proportion") {
stopifnot(sum(shares) == 1)
}
if (!is.null(cols)) {
names(cols) <- Parties
}
# arc start/end in rads, last one reset bc rounding errors
cc <- cumsum(c(-pi/2, switch(repr, "absolute" = (shares / sum(shares)) * pi, "proportion" = shares * pi)))
cc[length(cc)] <- pi/2
# get angle of arc midpoints
meanAngles <- colMeans(rbind(cc[2:length(cc)], cc[1:length(cc)-1]))
# unit circle
labelX <- sin(meanAngles)
labelY <- cos(meanAngles)
# prevent bounding box < y=0
labelY <- ifelse(labelY < 0.015, 0.015, labelY)
p <- ggplot() + theme_no_axes() + coord_fixed() +
expand_limits(x = c(-1.3, 1.3), y = c(0, 1.3)) +
theme(panel.border = element_blank()) +
theme(legend.position = "none") +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = 0.5, r = 1,
start = cc[1:length(shares)],
end = c(cc[2:length(shares)], pi/2), fill = Parties)) +
switch(is.null(cols)+1, scale_fill_manual(values = cols), NULL) +
# for label and line positions, just scale sin & cos to get in and out of arc
geom_path(aes(x = c(0.9 * labelX, 1.15 * labelX), y = c(0.9 * labelY, 1.15 * labelY),
group = rep(1:length(shares), 2)), colour = "white", size = 2) +
geom_path(aes(x = c(0.9 * labelX, 1.15 * labelX), y = c(0.9 * labelY, 1.15 * labelY),
group = rep(1:length(shares), 2)), size = 1) +
geom_label(aes(x = 1.15 * labelX, y = 1.15 * labelY,
label = switch(repr,
"absolute" = sprintf("%s\n%i", Parties, shares),
"proportion" = sprintf("%s\n%i%%", Parties, round(shares*100)))), fontface = "bold",
label.padding = unit(1, "points")) +
geom_point(aes(x = 0.9 * labelX, y = 0.9 * labelY), colour = "white", size = 2) +
geom_point(aes(x = 0.9 * labelX, y = 0.9 * labelY)) +
geom_text(aes(x = 0, y = 0, label = switch(repr,
"absolute" = (sprintf("Total: %i MPs", sum(shares))),
"proportion" = "")),
fontface = "bold", size = 7)
return(p)
}
bt <- data.frame(parties = c("CDU", "CSU", "SPD", "AfD", "FDP", "Linke", "GrĂ¼ne", "Fraktionslos"),
seats = c(200, 46, 153, 92, 80, 69, 67, 2),
cols = c("black", "blue", "red", "lightblue", "yellow", "purple", "green", "grey"),
stringsAsFactors = FALSE)
parlDiag(bt$parties, bt$seats, cols = bt$cols)
Would this work for you?
ggplot(df, aes(fill = Party, ymax = ymax, ymin = ymin, xmax = 2, xmin = 1)) + geom_rect() +
coord_polar(theta = "y",start=-pi/2) + xlim(c(0, 2)) + ylim(c(0,2))
Basically you just set the ylim to be 2x your max so it only plots it on half. In this case we set the y limits to be from 0 to 2. Then you can offset the start in coord_polar(start=) to get it in proper place.
FWIW, one might also check out the nice ggforce package:
library(tidyverse)
library(ggforce)
library(scales)
df %>%
mutate_at(vars(starts_with("y")), rescale, to=pi*c(-.5,.5), from=0:1) %>%
ggplot +
geom_arc_bar(aes(x0 = 0, y0 = 0, r0 = .5, r = 1, start = ymin, end = ymax, fill=Party)) +
coord_fixed()
I saw this great plot from fivethirty that has a slight overlap of density plots for different colleges. Check out this link at fivethirtyeight.com
How would you replicate this plot with ggplot2?
Specifically how would you get that slight overlap, facet_wrap isn't going to work.
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')
As always with ggplot, the key is getting the data in the right format, and then the plotting is pretty straightforward. I'm sure there would be another way to do this, but my approach was to do the density estimation with density() and then to make a sort of manual geom_density() with geom_ribbon(), which takes a ymin and ymax, necessary for moving the shape off the x axis.
The rest of the challenge was in getting the order of the printing correct, since it seems that ggplot will print the widest ribbon first. In the end, the part that requires the bulkiest code is the production of the quartiles.
I also produced some data that is a bit more consistent with the original figure.
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)
Edit
I noticed the original actually does a bit of fudging by stretching out each distribution with a horizontal line (you can see a join if you look closely...). I added something similar with the second geom_segment() in the loop.
Although there is a great & accepted answer available already - I finished my contribution as an alternative avenue without data reformatting.
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
Using dedicated geom_joy() from 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