Animação de distribuições de população dos EUA

cupom com desconto - o melhor site de cupom de desconto cupomcomdesconto.com.br


[Esteartigofoipublicadopelaprimeiravezem[Thisarticlewasfirstpublishedon R em kieranhealy.org, e gentilmente contribuiu para os R-blogueiros]. (Você pode relatar um problema sobre o conteúdo desta página aqui)


Deseja compartilhar seu conteúdo com R-blogueiros? clique aqui se você tiver um blog ou aqui se não tiver.

Com o Censo dos EUA em 2020 já em andamento, analisei vários dados do Census Bureau. Decidi que queria desenhar algumas pirâmides populacionais para os EUA durante uma série de tempo possível. O que é necessário para isso são tabelas para, digamos, o maior número possível de anos que mostre o número de homens e mulheres vivos a cada ano de idade, de zero à idade mais alta que você deseja rastrear. Esse tipo de dado é disponível no site do Censo. Mas parecia um pouco tedioso reunir-se em uma única série utilizável. (Talvez ele esteja disponível em um formato fácil de digerir em outro lugar, mas não consegui encontrá-lo.) Inicialmente, trabalhei com alguns dos excelentes pacotes R que conversam com a API do Censo (tidycensus e censusapi), esperando que eles me dessem o que eu precisava. Mas, no final, lancei uma série anual de anos de idade de 1900 a 2019, pegando os dados do Censo e limpando-os. Como sempre, 95% da análise de dados é de fato aquisição e limpeza de dados.


Primeiro nos preparamos como de costume.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20

library(tidyverse)
library(here)
library(janitor)
library(socviz)

library(gganimate)
library(transformr)

## --------------------------------------------------------------------
## Custom font and theme, omit if you don't have the myriad library
## (https://github.com/kjhealy/myriad) and associated Adobe fonts.
## --------------------------------------------------------------------
library(showtext)
showtext_auto()
library(myriad)
import_myriad_semi()

theme_set(theme_myriad_semi())

Agora, os dados. O que queremos são as estimativas decenais e intercensais por ano, sexo e ano de idade. Estes não estão todos no mesmo lugar. Além disso, eles não estão todos no mesmo formato. As estimativas para 1900 a 1979 estão disponíveis neste link, mas (como ficou claro rapidamente), o formato do arquivo CSV muda ligeiramente. As décadas subsequentes variam de formato e ampliam o leque de medidas contadas. Alguns dos formatos são bastante difíceis de trabalhar. Por exemplo, aqui está parte da descrição dos arquivos 1980-89:

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
The 1990 monthly postcensal national population estimate data files have
an identical layout.  All records contain 222 characters.  All data fields
are right-justified.

Location            Type        Data

1-2                 Character   Series
3-4                 Numeric     Month
5-8                 Numeric     Year
9-11                Numeric     Age (years)
12                  (blank)     (blank)
13-22               Numeric     Total population
23-32               Numeric     Total male population
33-42               Numeric     Total female population
43-52               Numeric     White male population
53-62               Numeric     White female population
63-72               Numeric     Black male population
73-82               Numeric     Black female population

E depois:

1
2
3
4
5
Within each file, the records are first sorted by the reference date
(Month-Year) in chronological order.  For each reference date, the first
record lists the population counts for all ages combined.  The remaining
records list the population counts by single year of age in ascending
order.

Isso significa que o arquivo de dados para qualquer ano em particular durante esse período é mais ou menos assim:

1
2
3
4
5
6
7
2I 780 98      14234      3485 
2I 780 99       9652      2409 
2I 780100      15099      3244 
2I1080999  227924215 110746612 
2I1080  0    3582352   1832733 
2I1080  1    3360607   1718828 
2I1080  2    3217219   1645162 

Não tão legal. A maneira mais limpa de trabalhar com coisas assim seria escrever uma especificação para ler os dados pela posição da coluna. No final, escrevi uma série de scripts curtos usando algumas ferramentas Unix antiquadas, especialmente sed, para fatiar e cortar em cubos para mim. Eles ficaram assim:

No final, eu tinha alguns arquivos delimitados razoavelmente limpos com os quais eu poderia trabalhar, que necessitavam de um pouco mais de limpeza em R. Para cada lote de arquivos, eu faria algo assim: obtenha uma lista dos arquivos necessários no diretório, leia o conteúdo em uma mistura e harmonize os nomes das colunas, se necessário. Aqui está o segmento para os arquivos dos anos 80, por exemplo:

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

target <- "1980_1989"
path <- paste0("data/",target)

filenames <- dir(path = here(path),
                 pattern = "*.new$",
                 full.names = TRUE)

pop_1980_1989 <- tibble(
  year = get_80syr(filenames),
  path = filenames, 
  data = map(filenames, ~ read_delim(., delim = " "))
  ) %>%
  mutate(data = map(data, ~ 
                       .x %>% 
                         mutate_if(is.character, as.numeric)))

pop_1980_1989

# A tibble: 10 x 3
   year  path                                           data          
   <chr> <chr>                                          <list>        
 1 1980  /Users/kjhealy/Documents/data/misc/census_pop<tibble [1012 1981  /Users/kjhealy/Documents/data/misc/census_pop<tibble [1013 1982  /Users/kjhealy/Documents/data/misc/census_pop<tibble [1014 1983  /Users/kjhealy/Documents/data/misc/census_pop<tibble [1015 1984  /Users/kjhealy/Documents/data/misc/census_pop<tibble [1016 1985  /Users/kjhealy/Documents/data/misc/census_pop<tibble [1017 1986  /Users/kjhealy/Documents/data/misc/census_pop<tibble [1018 1987  /Users/kjhealy/Documents/data/misc/census_pop<tibble [1019 1988  /Users/kjhealy/Documents/data/misc/census_pop<tibble [10110 1989  /Users/kjhealy/Documents/data/misc/census_pop<tibble [101

Eventualmente, todas as séries são lidas e podem ser unidas e as contagens de ano, idade e população são extraídas.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

# Now we're suckin' diesel
pop_data <- bind_rows(pop_1900_1959, 
                      pop_1960_1979, 
                      pop_1980_1989,
                      pop_1990_1999, 
                      pop_2000_2009, 
                      pop_2010_2019)

pop_series <- unnest(pop_data, cols = c(data)) %>%
  select(-path) %>%
  select(year, age, pop, male, female) 

pop_series

# A tibble: 10,520 x 5
   year    age     pop   male female
   <chr> <dbl>   <dbl>  <dbl>  <dbl>
 1 1900       1811000 919000 892000
 2 1900      1 1835000 928000 907000
 3 1900      2 1846000 932000 914000
 4 1900      3 1848000 932000 916000
 5 1900      4 1841000 928000 913000
 6 1900      5 1827000 921000 906000
 7 1900      6 1806000 911000 895000
 8 1900      7 1780000 899000 881000
 9 1900      8 1750000 884000 866000
10 1900      9 1717000 868000 849000
# … with 10,510 more rows

A partir daí, alternamos as séries para o formato longo:

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

pop_lon <- pop_series %>% select(year, age, male, female) %>%
  pivot_longer(male:female, names_to = "group", values_to = "count") %>%
  group_by(year, group) %>%
  mutate(total = sum(count), 
         pct = (count/total)*100, 
         base = ) 

pop_lon

# A tibble: 21,040 x 7
# Groups:   year, group [240]
   year    age group   count    total   pct  base
   <chr> <dbl> <chr>   <dbl>    <dbl> <dbl> <dbl>
 1 1900       male   919000 38867000  2.36     
 2 1900       female 892000 37227000  2.40     
 3 1900      1 male   928000 38867000  2.39     
 4 1900      1 female 907000 37227000  2.44     
 5 1900      2 male   932000 38867000  2.40     
 6 1900      2 female 914000 37227000  2.46     
 7 1900      3 male   932000 38867000  2.40     
 8 1900      3 female 916000 37227000  2.46     
 9 1900      4 male   928000 38867000  2.39     
10 1900      4 female 913000 37227000  2.45     
# … with 21,030 more rows

Aqui, dentro de cada ano e para homens e mulheres, calculamos a porcentagem da população total que tem uma idade específica. Como mencionei, uma característica dos dados do Censo é que, ao longo dos anos, o código principal para a idade – a maior idade relatada pelas tabelas do Censo – aumenta gradualmente. Podemos ver quais são esses limites e quando eles mudam:

Leia Também  Novos aprimoramentos bacanas para descompactar / para
cupom com desconto - o melhor site de cupom de desconto cupomcomdesconto.com.br
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14

pop_series %>%
  group_by(year) %>%
  summarize(max_age = max(age)) %>%
  group_by(max_age) %>%
  summarize(minyr = min(year), 
            maxyr = max(year))

# A tibble: 3 x 3
  max_age minyr maxyr
    <dbl> <chr> <chr>
1      75 1900  1939 
2      85 1940  1979 
3     100 1980  2019 

Agora podemos fazer algumas animações. Primeiro, em vez de uma pirâmide populacional, usaremos geom_density() produzir estimativas de densidade de kernel da distribuição etária para cada ano, tanto para homens quanto para mulheres. Em casos como este, quando temos uma variável como year e uma contagem resumida para cada idade naquele ano (mas não as observações em nível individual), a maneira de obter a densidade é colocar age no eixo xe use a proporção (pct/100) para ponderar cada ano de idade. (Os pesos precisam somar 1, daí o uso de proporções em vez de porcentagens.) Aqui estamos usando o after_stat() função que é nova no scales pacote e ggplot2 versão 3.3.0. Essa maneira de expressar o que queremos fazer substitui as sintaxes anteriores, como o período duplo ..density.. convenção.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36


p_dens <- pop_lon %>%
  ggplot(aes(x = age, 
           y = after_stat(density),
           weight = pct/100,
           fill = group, 
           group = group)) +
  geom_density(color = "black", alpha = 0.5) + 
  scale_fill_manual(values = my.colors("bly"), 
                    labels = c("Female", "Male")) + 
  scale_x_continuous(breaks = seq(, 100, 10), 
                    labels = as.character(seq(, 100, 10))) +
  guides(fill = guide_legend(label.position = "bottom", keywidth = 2),
               color = guide_legend(label.position = "bottom", keywidth = 2)) +
  labs(x = "Age", y = "Estimated Density", 
      color = NULL, fill = NULL, 
       title = "{frame_time}. Relative Age Distribution of the U.S. Population by Sex", 
       subtitle = "Age is top-coded at 75 until 1939, at 85 until 1979, and at 100 since 1980.",
       caption = "@kjhealy / http://kieranhealy.org.") + 
  theme(legend.position = "bottom",
          plot.title = element_text(size = rel(3), face = "bold"),
          plot.subtitle = element_text(size = rel(3)),
          plot.caption = element_text(size = rel(2)),
          axis.text.y = element_text(size = rel(3)),
          axis.title.x = element_text(size = rel(3)),
          axis.title.y = element_text(size = rel(3)),
          axis.text.x = element_text(size = rel(3)),
          legend.text = element_text(size = rel(3))) +
  transition_time(as.integer(year(year))) + 
  ease_aes("linear") + 
    transition_time(as.integer(year)) + 
    ease_aes("cubic-in-out")
    
animate(p_dens, fps = 25, duration = 30, width = 1024, height = 1024, renderer = ffmpeg_renderer())

o theme() As chamadas são sobre aumentar o texto padrão da etiqueta, usando as práticas rel() função para aumentar o tamanho em termos relativos, em vez de se preocupar com as unidades. Recebemos a animação quase de graça, graças ao trabalho de Thomas Lin Pedersen gganimate pacote. Apenas as duas funções, transition_time() e ease_aes() faça todo o trabalho. Então nós usamos animate() para renderizar a animação. Depois de salvar os resultados como um mp4 arquivo, aqui está o que obtemos.

Leia Também  RcppAPT 0.0.6 | R-bloggers

As curvas aqui são densidades estimadas do núcleo. Uma maneira mais convencional de representar os dados demográficos que temos é com um pirâmide populacional, onde colocamos as idades no eixo xe as contagens populacionais (ou porcentagens) no eixo y, e depois colocamos os machos à esquerda e as fêmeas à direita. Para fazer isso em R, usaremos geom_ribbon() e trapaceie um pouco, fazendo com que as idades dos homens sejam todas negativas. Em seguida, definiremos a base das fitas masculina e feminina como zero. Aqui está como isso funciona. Mostraremos a distribuição absoluta e não a relativa da população, para podermos observar o tamanho da pirâmide crescer ao longo do tempo e também mudar sua forma.

1
2
3
4
5

pop_pyr <- pop_lon

## Make all the Male ages negative
pop_pyr$count[pop_pyr$group == "male"] <- -pop_pyr$count[pop_pyr$group == "male"]

O código para o gráfico é muito semelhante ao anterior:

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35


mbreaks <- c("1M", "2M", "3M")

p <- ggplot(data = pop_pyr,
            mapping = aes(x = age, ymin = base,
                          ymax = count, fill = group))

p_pyr_count <- p + geom_ribbon(alpha = 0.5) +
    scale_y_continuous(labels = c(rev(mbreaks), "0", mbreaks), 
                       breaks = seq(-3e6, 3e6, 1e6), 
                       limits = c(-3e6, 3e6)) + 
    scale_x_continuous(breaks = seq(10, 100, 10)) +
  scale_fill_manual(values = my.colors("bly"), labels = c("Female", "Male")) + 
    guides(fill = guide_legend(reverse = TRUE)) +
    labs(x = "Age", y = "Number of People",
         title = "{frame_time}. Absolute Age Distribution of the U.S. Population by Sex",
         subtitle = "Age is top-coded at 75 until 1939, at 85 until 1979, and at 100 since 1980.",
         caption = "Kieran Healy / kieranhealy.org / Data: US Census Bureau.",
         fill = "") +
    theme(legend.position = "bottom",
          plot.title = element_text(size = rel(3), face = "bold"),
          plot.subtitle = element_text(size = rel(3)),
          plot.caption = element_text(size = rel(2)),
          axis.text.y = element_text(size = rel(3)),
          axis.text.x = element_text(size = rel(3)),
          axis.title.x = element_text(size = rel(3)),
          axis.title.y = element_text(size = rel(3)),
          legend.text = element_text(size = rel(3))) +
    coord_flip() + 
    transition_time(as.integer(year)) + 
    ease_aes("cubic-in-out")
    
    
animate(p_pyr_count, fps = 25, duration = 60, width = 1024, height = 1024, renderer = ffmpeg_renderer())

As principais mudanças estão na rotulagem. geom_ribbon precisa de uma ymin e um ymax valor. O primeiro será sempre zero. Este último será a contagem da população para essa idade. Criamos um pequeno vetor de rótulos populacionais, mbreaks, para o eixo x, e junte-o primeiro no sentido inverso e, em seguida, em ordem regular em ambos os lados de zero: labels = c(rev(mbreaks), "0", mbreaks). Também definimos as quebras entre -3 milhões e 3 milhões em etapas de 1 milhão: breaks = seq(-3e6, 3e6, 1e6). o cubic-in-out A função de atenuação cria uma animação passo a passo mais bonita que a padrão linear, que oscila demais.

E aqui está o resultado.