Add smooth line to R pyramid plots - r

Question

Please help me to add smooth lines(thick black lines shown in the figure) to a R pyramid plot as shown in the attached image. Appreciate your help.This plot shows the population distribution according to the age and gender.
xy.pop<-c(3.2,3.5,3.6,3.6,3.5,3.5,3.9,3.7,3.9,3.5,3.2,2.8,2.2,1.8,1.5,1.3,0.7,0.4)
xx.pop<-c(3.2,3.4,3.5,3.5,3.5,3.7,4,3.8,3.9,3.6,3.2,2.5,2,1.7,1.5,1.3,1,0.8)
agelabels<-c("0-4","5-9","10-14","15-19","20-24","25-29","30-34",
"35-39","40-44","45-49","50-54","55-59","60-64","65-69","70-74",
"75-79","80-44","85+")
mcol<-color.gradient(c(0,0,0.5,1),c(0,0,0.5,1),c(1,1,0.5,1),18)
fcol<-color.gradient(c(1,1,0.5,1),c(0.5,0.5,0.5,1),c(0.5,0.5,0.5,1),18)
par(mar=pyramid.plot(xy.pop,xx.pop,labels=agelabels,main="Australian population pyramid 2002",lxcol=mcol,rxcol=fcol,))

Answer 1

How about the following (using ggplot rather than base R graphics).
# Your data
xy.pop<-c(3.2,3.5,3.6,3.6,3.5,3.5,3.9,3.7,3.9,3.5,3.2,2.8,2.2,1.8,1.5,1.3,0.7,0.4)
xx.pop<-c(3.2,3.4,3.5,3.5,3.5,3.7,4,3.8,3.9,3.6,3.2,2.5,2,1.7,1.5,1.3,1,0.8)
agelabels<-c("0-4","5-9","10-14","15-19","20-24","25-29","30-34",
"35-39","40-44","45-49","50-54","55-59","60-64","65-69","70-74",
"75-79","80-44","85+")
# Collect data in dataframe
df <- rbind.data.frame(
cbind.data.frame(Percentage = -xy.pop, Group = agelabels, Gender = "male"),
cbind.data.frame(Percentage = +xx.pop, Group = agelabels, Gender = "female"));
# Make sure agelabels have the right order
df$Group <- factor(df$Group, levels = agelabels);
# (gg)plot
gg <- ggplot(
data = df,
aes(x = Group, y = Percentage, fill = Gender, group = Gender));
gg <- gg + geom_bar(data = subset(df, Gender == "female"), stat = "identity");
gg <- gg + geom_bar(data = subset(df, Gender == "male"), stat = "identity");
gg <- gg + coord_flip();
gg <- gg + geom_smooth(
colour = "black", method = "loess", se = FALSE, show.legend = FALSE, size = 0.5);
gg <- gg + labs(
x = "Age",
y = "Percentage",
title = "Australian population pyramid 2012");
gg <- gg + scale_y_continuous(
breaks = seq(-4, 4, by = 2),
labels = c(rev(seq(0, 4, by = 2)), seq(2, 4, by = 2)));
print(gg);
I'm here fitting a LOESS curve separately to both the male and female pyramid halves (through the group aesthetic).
It's not quite the same plot as the one you show, but there is still room for improvement/tweaking. For example, you can change the fill aesthetic to achieve a percentage-dependent fill of the bars.
Credit where credit is due: This solution is based on this post on SO by #DidzisElferts.
Update (nearly a year later)
I've always wanted to review this answer to increase the aesthetic similarity of a ggplot2 solution with the plot generated from plotrix::pyramid.plot. Here is an update that gets pretty close.
# Define function to draw the left/right half of an age pyramid
ggpyramidhalf <- function(df, pos = "left", title) {
gg <- ggplot(df, aes(Group, Percentage, group = Gender)) +
geom_col(aes(fill = Group), colour = "black") +
geom_smooth(
colour = "black",
method = "loess",
se = F,
show.legend = F, size = 0.5) +
theme_minimal() +
labs(y = "%", title = title) +
coord_flip(expand = FALSE) +
theme(
axis.title.y = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank())
if (pos == "left") {
gg <- gg +
ylim(c(min(range(pretty(df$Percentage))), 0)) +
scale_fill_manual(
values = colorRampPalette(c("blue", "white"))(length(agelabels)),
guide = F) +
theme(
plot.title = element_text(hjust = 1),
axis.text.y = element_blank())
} else {
gg <- gg +
ylim(c(0, max(range(pretty(df$Percentage))))) +
scale_fill_manual(
values = colorRampPalette(c("red", "white"))(length(agelabels)),
guide = F) +
theme(
plot.title = element_text(hjust = 0),
axis.title.y = element_blank(),
axis.text.y = element_text(hjust = 0.5, margin = margin(r = 10)))
}
gg
}
# Draw left (male) half of age pyramid
gg1 <- df %>%
filter(Gender == "male") %>%
mutate(Group = factor(Group, agelabels)) %>%
ggpyramidhalf(pos = "left", title = "Male")
# Draw right (female) half of age pyramid
gg2 <- df %>%
filter(Gender == "female") %>%
mutate(Group = factor(Group, agelabels)) %>%
ggpyramidhalf(pos = "right", title = "Female")
# Use gridExtra to draw both halfs in one plot
library(gridExtra)
library(grid)
grid.arrange(
gg1, gg2,
ncol = 2,
widths = c(1, 1.15),
top = textGrob("Australian population period 2002", gp = gpar(font = 2)))

Answer 2

Here is a solution using the pyramid.plot function of plotrix:
library(plotrix)
pyramid.plot(xy.pop,xx.pop,labels=agelabels,
main="Australian population pyramid 2002",lxcol=mcol,rxcol=fcol)
male.smline <- loess.smooth(x=1:18, y=xy.pop, degree=2)
lines(-1-male.smline$y, male.smline$x, col="red", lwd=3)
female.smline <- loess.smooth(x=1:18, y=xx.pop, degree=2)
lines(1+female.smline$y, female.smline$x, col="black", lwd=3)