рисунок пирамиды с использованием R и ggplot2

Question

Мне нужно нарисовать участок пирамиды, как тот, который прилагается.

Я нашел пример, используя R (но не ggplot) от here, кто может дать мне намек на делать это с помощью ggplot? Благодаря!

Answer 1

Это по существу barplot спина к спине, что-то вроде тех, сгенерированных с помощью ggplot2 в отличном learnr блоге: http://learnr.wordpress.com/2009/09/24/ggplot2-back-to-back-bar-charts/

Вы можете использовать coord_flip с одним из этих участков, но я не знаю, как вы получите его, чтобы разделить метки оси Y между двумя графиками, как то, что у вас есть выше. Код ниже вы должны получить достаточно близко к оригиналу:

Сначала создайте фрейм данных выборки данных, преобразовать столбец Возраст в фактор с требуемыми брейк-поинтов:

require(ggplot2) 
df <- data.frame(Type = sample(c('Male', 'Female', 'Female'), 1000, replace=TRUE), 
       Age = sample(18:60, 1000, replace=TRUE)) 

AgesFactor <- ordered(cut(df$Age, breaks = c(18,seq(20,60,5)), 
          include.lowest = TRUE)) 

df$Age <- AgesFactor 

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

gg <- ggplot(data = df, aes(x=Age)) 

gg.male <- gg + 
    geom_bar(subset = .(Type == 'Male'), 
      aes(y = ..count../sum(..count..), fill = Age)) + 
    scale_y_continuous('', formatter = 'percent') + 
    opts(legend.position = 'none') + 
    opts(axis.text.y = theme_blank(), axis.title.y = theme_blank()) + 
    opts(title = 'Male', plot.title = theme_text(size = 10)) + 
    coord_flip()  

Для женского участка, обратный «Percent» оси с помощью trans = "reverse" ...

gg.female <- gg + 
    geom_bar(subset = .(Type == 'Female'), 
      aes(y = ..count../sum(..count..), fill = Age)) + 
    scale_y_continuous('', formatter = 'percent', trans = 'reverse') + 
    opts(legend.position = 'none') + 
    opts(axis.text.y = theme_blank(), 
     axis.title.y = theme_blank(), 
     title = 'Female') + 
    opts(plot.title = theme_text(size = 10)) + 
    coord_flip() 

Теперь создаст участок только для отображения возрастных кронштейнов с помощью geom_text, но и использовать фиктивный geom_bar, чтобы гарантировать, что масштабирование «возраст» оси в этом графике совпадает с тем, в мужских и женских участках:

gg.ages <- gg + 
    geom_bar(subset = .(Type == 'Male'), aes(y = 0, fill = alpha('white',0))) + 
    geom_text(aes(y = 0, label = as.character(Age)), size = 3) + 
    coord_flip() + 
    opts(title = 'Ages', 
     legend.position = 'none' , 
     axis.text.y = theme_blank(), 
     axis.title.y = theme_blank(), 
     axis.text.x = theme_blank(), 
     axis.ticks = theme_blank(),   
     plot.title = theme_text(size = 10))  

Наконец, организовать участки на сетке, используя метод, описанный в книге Hadley Уикхем:

grid.newpage() 

pushViewport(viewport(layout = grid.layout(1,3, widths = c(.4,.2,.4)))) 

vplayout <- function(x, y) viewport(layout.pos.row = x, layout.pos.col = y) 

print(gg.female, vp = vplayout(1,1)) 
print(gg.ages, vp = vplayout(1,2)) 
print(gg.male, vp = vplayout(1,3)) 

Answer 2

Незначительное твик:

library(ggplot2) 
library(plyr) 
library(gridExtra) 

## The Data 
df <- data.frame(Type = sample(c('Male', 'Female', 'Female'), 1000, replace=TRUE), 
    Age = sample(18:60, 1000, replace=TRUE)) 

AgesFactor <- ordered(cut(df$Age, breaks = c(18,seq(20,60,5)), 
    include.lowest = TRUE)) 

df$Age <- AgesFactor 

## Plotting 
gg <- ggplot(data = df, aes(x=Age)) 

gg.male <- gg + 
    geom_bar(data=subset(df,Type == 'Male'), 
     aes(y = ..count../sum(..count..), fill = Age)) + 
    scale_y_continuous('', labels = scales::percent) + 
    theme(legend.position = 'none', 
     axis.title.y = element_blank(), 
     plot.title = element_text(size = 11.5), 
     plot.margin=unit(c(0.1,0.2,0.1,-.1),"cm"), 
     axis.ticks.y = element_blank(), 
     axis.text.y = theme_bw()$axis.text.y) + 
    ggtitle("Male") + 
    coord_flip()  

gg.female <- gg + 
    geom_bar(data=subset(df,Type == 'Female'), 
     aes(y = ..count../sum(..count..), fill = Age)) + 
    scale_y_continuous('', labels = scales::percent, 
        trans = 'reverse') + 
    theme(legend.position = 'none', 
     axis.text.y = element_blank(), 
     axis.ticks.y = element_blank(), 
     plot.title = element_text(size = 11.5), 
     plot.margin=unit(c(0.1,0,0.1,0.05),"cm")) + 
    ggtitle("Female") + 
    coord_flip() + 
    ylab("Age") 

## Plutting it together 
grid.arrange(gg.female, 
    gg.male, 
    widths=c(0.4,0.6), 
    ncol=2 
) 

Я все еще хочу играть с полями немного больше (может panel.margin бы помочь в theme вызова, а).

Answer 3

Я сделал это с небольшим обходным решением - вместо использования geom_bar я использовал geom_linerange и geom_label.

library(magrittr) 
library(dplyr) 
library(ggplot2) 

population <- read.csv("https://raw.githubusercontent.com/andriy-gazin/datasets/master/ageSexDistribution.csv") 

population %<>% 
    tidyr::gather(sex, number, -year, - ageGroup) %>% 
    mutate(ageGroup = gsub("100 і старше", "≥100", ageGroup), 
    ageGroup = factor(ageGroup, 
         ordered = TRUE, 
         levels = 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-84", 
            "85-89", "90-94", "95-99", "≥100")), 
    number = ifelse(sex == "male", number*-1/10^6, number/10^6)) %>% 
    filter(year %in% c(1990, 1995, 2000, 2005, 2010, 2015)) 

png(filename = "~/R/pyramid.png", width = 900, height = 1000, type = "cairo") 

ggplot(population, aes(x = ageGroup, color = sex))+ 
    geom_linerange(data = population[population$sex=="male",], 
       aes(ymin = -0.3, ymax = -0.3+number), size = 3.5, alpha = 0.8)+ 
    geom_linerange(data = population[population$sex=="female",], 
       aes(ymin = 0.3, ymax = 0.3+number), size = 3.5, alpha = 0.8)+ 
    geom_label(aes(x = ageGroup, y = 0, label = ageGroup, family = "Ubuntu Condensed"), 
     inherit.aes = F, 
     size = 3.5, label.padding = unit(0.0, "lines"), label.size = 0, 
     label.r = unit(0.0, "lines"), fill = "#EFF2F4", alpha = 0.9, color = "#5D646F")+ 
    scale_y_continuous(breaks = c(c(-2, -1.5, -1, -0.5, 0) + -0.3, c(0, 0.5, 1, 1.5, 2)+0.3), 
       labels = c("2", "1.5", "1", "0.5", "0", "0", "0.5", "1", "1.5", "2"))+ 
    facet_wrap(~year, ncol = 2)+ 
    coord_flip()+ 
labs(title = "Піраміда населення України", 
    subtitle = "Статево-вікові групи у 1990-2015 роках, млн осіб", 
    caption = "Дані: Держкомстат України")+ 
    scale_color_manual(name = "", values = c(male = "#3E606F", female = "#8C3F4D"), 
       labels = c("жінки", "чоловіки"))+ 
    theme_minimal(base_family = "Ubuntu Condensed")+ 
theme(text = element_text(color = "#3A3F4A"), 
    panel.grid.major.y = element_blank(), 
    panel.grid.minor = element_blank(), 
    panel.grid.major.x = element_line(linetype = "dotted", size = 0.3, color = "#3A3F4A"), 
    axis.title = element_blank(), 
    plot.title = element_text(face = "bold", size = 36, margin = margin(b = 10), hjust = 0.030), 
    plot.subtitle = element_text(size = 16, margin = margin(b = 20), hjust = 0.030), 
    plot.caption = element_text(size = 14, margin = margin(b = 10, t = 50), color = "#5D646F"), 
    axis.text.x = element_text(size = 12, color = "#5D646F"), 
    axis.text.y = element_blank(), 
    strip.text = element_text(color = "#5D646F", size = 18, face = "bold", hjust = 0.030), 
    plot.background = element_rect(fill = "#EFF2F4"), 
    plot.margin = unit(c(2, 2, 2, 2), "cm"), 
    legend.position = "top", 
    legend.margin = unit(0.1, "lines"), 
    legend.text = element_text(family = "Ubuntu Condensed", size = 14), 
    legend.text.align = 0) 

dev.off() 

и вот в результате чего участок:

Answer 4

мне понравились сюжеты @ Andriy достаточно, чтобы сделать упрощенную пользовательскую функцию из нее:

Данные должны выглядеть следующим образом, и ageGroup быть упорядоченным множителем.

head(population) 
# ageGroup sex number 
# 1  0-4 male 1.896459 
# 2  5-9 male 1.914255 
# 3 10-14 male 1.832594 
# 4 15-19 male 1.849453 
# 5 20-24 male 1.658733 
# 6 25-29 male 1.918060 

Затем вы предоставите данные и разрывы:

pyramid(population,c(0, 0.5, 1, 1.5, 2)) 

При необходимости, создание возрастных групп может быть сделано с помощью функции age_cat, что я взял из this blog. См. Код ниже. Я слегка изменил исходное имя и параметры по умолчанию.

Например:

age_column <- sample(0:110,10000,TRUE) 
table(age_cat(age_column)) 
# 0-9 10-19 20-29 30-39 40-49 50-59 60-69 70-79 80-89 90-99 100+ 
# 885 836 885 927 942 953 886 882 935 872 997 

функции

pyramid <- function(data,.breaks){ 
ggplot(data, aes(x = ageGroup, color = sex))+ 
    geom_linerange(data = data[data$sex=="male",], 
       aes(ymin = -tail(.breaks,1)/7, ymax = -tail(.breaks,1)/7-number), size = 3.5, alpha = 0.8)+ 
    geom_linerange(data = data[data$sex=="female",], 
       aes(ymin = tail(.breaks,1)/7, ymax = tail(.breaks,1)/7+number), size = 3.5, alpha = 0.8)+ 
    geom_label(aes(x = ageGroup, y = 0, label = ageGroup), 
      inherit.aes = F, 
      size = 3.5, label.padding = unit(0.0, "lines"), label.size = NA, 
      label.r = unit(0.0, "lines"), fill = "white", alpha = 0.9, color = "#5D646F")+ 
    scale_y_continuous(breaks = c(-rev(.breaks) -tail(.breaks,1)/7, .breaks+tail(.breaks,1)/7), 
        labels = c(rev(.breaks),.breaks))+ 
    coord_flip()+ 
    scale_color_manual(name = "", values = c(male = "#3E606F", female = "#8C3F4D"))+ 
    theme_minimal()+ 
    theme(text = element_text(color = "#3A3F4A"), 
     panel.grid.major.y = element_blank(), 
     panel.grid.minor = element_blank(), 
     panel.grid.major.x = element_line(linetype = "dotted", size = 0.3, color = "#3A3F4A"), 
     axis.title = element_blank(), 
     axis.text.x = element_text(size = 12, color = "#5D646F"), 
     axis.text.y = element_blank(), 
     strip.text = element_text(color = "#5D646F", size = 18, face = "bold", hjust = 0.030), 
     legend.position = "none") 
} 

age_cat <- function(x, lower = 0, upper = 100, by = 5, 
        sep = "-", above.char = "+") { 

    labs <- c(paste(seq(lower, upper - by, by = by), 
        seq(lower + by - 1, upper - 1, by = by), 
        sep = sep), 
      paste(upper, above.char, sep = "")) 

    cut(floor(x), breaks = c(seq(lower, upper, by = by), Inf), 
     right = FALSE, labels = labs) 
} 

данных

library(dplyr) 
library(ggplot2) 
population <- read.csv("https://raw.githubusercontent.com/andriy-gazin/datasets/master/ageSexDistribution.csv") 
population <- population %>% 
    tidyr::gather(sex, number, -year, - ageGroup) %>% 
    mutate(ageGroup = factor(ageGroup, 
          ordered = TRUE, 
          levels = 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-84", 
             "85-89", "90-94", "95-99", "100+")), 
     ageGroup = `[<-`(ageGroup,is.na(ageGroup),value="100+"), 
     number = number/10^6) %>% 
    dplyr::filter(year == 1990) %>% 
    select(-year)