TyT2019W33 - Bullet Graph

By Johanie Fournier, agr. in rstats tidyverse tidytuesday

August 13, 2019

Get the data

emperors <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-08-13/emperors.csv")
## Rows: 68 Columns: 16
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (11): name, name_full, birth_cty, birth_prv, rise, cause, killer, dynas...
## dbl   (1): index
## date  (4): birth, death, reign_start, reign_end
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

Explore the data

summary(emperors)
##      index           name            name_full             birth           
##  Min.   : 1.00   Length:68          Length:68          Min.   :0002-12-24  
##  1st Qu.:17.75   Class :character   Class :character   1st Qu.:0123-12-13  
##  Median :34.50   Mode  :character   Mode  :character   Median :0201-01-01  
##  Mean   :34.50                                         Mean   :0184-07-15  
##  3rd Qu.:51.25                                         3rd Qu.:0250-01-01  
##  Max.   :68.00                                         Max.   :0371-01-01  
##                                                        NA's   :5           
##      death             birth_cty          birth_prv             rise          
##  Min.   :0014-08-19   Length:68          Length:68          Length:68         
##  1st Qu.:0189-10-20   Class :character   Class :character   Class :character  
##  Median :0251-08-08   Mode  :character   Mode  :character   Mode  :character  
##  Mean   :0236-06-01                                                           
##  3rd Qu.:0310-09-25                                                           
##  Max.   :0395-01-17                                                           
##                                                                               
##   reign_start           reign_end             cause          
##  Min.   :0014-09-18   Min.   :0014-08-19   Length:68         
##  1st Qu.:0173-01-17   1st Qu.:0189-10-20   Class :character  
##  Median :0250-08-08   Median :0251-08-08   Mode  :character  
##  Mean   :0228-06-24   Mean   :0236-02-08                     
##  3rd Qu.:0305-05-01   3rd Qu.:0306-11-06                     
##  Max.   :0379-01-01   Max.   :0395-01-17                     
##                                                              
##     killer            dynasty              era               notes          
##  Length:68          Length:68          Length:68          Length:68         
##  Class :character   Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character   Mode  :character  
##                                                                             
##                                                                             
##                                                                             
##                                                                             
##   verif_who        
##  Length:68         
##  Class :character  
##  Mode  :character  
##                    
##                    
##                    
## 

Prepare the data

data<-emperors %>% 
  mutate(annee_naiss=year(birth)) %>% 
  mutate(annee_mort=year(death)) %>% 
  mutate(annee_deb=year(reign_start)) %>% 
  mutate(annee_fin=year(reign_end)) %>% 
  mutate(age_mort=abs(annee_mort-annee_naiss)) %>% 
  mutate(age_deb=abs(annee_deb-annee_naiss)) %>% 
  mutate(age_fin=abs(annee_fin-annee_naiss)) %>% 
  mutate(duree=abs(age_fin-age_deb)) %>%
  mutate(remove=ifelse(age_deb==age_mort, 'retirer', NA)) %>% 
  filter(!age_mort %in% NA,!age_deb %in% NA,!age_fin %in% NA, 
         !age_mort %in% 4, !remove %in% "retirer") %>% 
  select(name, age_deb, age_fin, age_mort, duree) 

Visualize the data

#Graphique
gg<-ggplot(data, aes(x=reorder(name, -age_mort), y=age_mort))
gg <- gg + geom_bar(stat="identity", position="stack", width=0.65, fill="#6D7C83", alpha=0.4)
gg <- gg + geom_segment(aes(y = age_deb, 
                            x = name, 
                            yend = age_fin, 
                            xend = name), 
                        color = "#175676", size=2.3, alpha=0.8) 
gg <- gg + geom_errorbar(aes(y=age_mort, x=name, ymin=age_mort, ymax=age_mort), color="black", width=0.85) 
gg <- gg + geom_point(aes(name, age_mort), colour="black", size=0.75) 
gg <- gg + coord_flip()
#ajuster les axes 
gg <- gg + scale_y_continuous(breaks=seq(0,80,10), limits = c(0,80))
gg <- gg + expand_limits(x=c(0, 56))
#modifier le thème
gg <- gg +  theme(panel.border = element_blank(),
                    panel.background = element_blank(),
                    plot.background = element_blank(),
                    panel.grid.major.x= element_line(size=0.2,linetype="dotted", color="#6D7C83"),
                    panel.grid.major.y= element_blank(),
                    panel.grid.minor = element_blank(),
                    axis.line.x = element_blank(),
                    axis.line.y = element_blank(),
                    axis.ticks.y = element_blank(),
                    axis.ticks.x = element_blank())
#ajouter les titres
gg<-gg + labs(title=" ",
              subtitle="",
              y=" ", 
              x=" ")
gg<-gg + theme(plot.title    = element_blank(),
                 plot.subtitle = element_blank(),
                 axis.title.y  = element_blank(),
                 axis.title.x  = element_blank(),
                 axis.text.y   = element_text(hjust=1, vjust=0.5, size=12, color="#6D7C83", face="bold"), 
                 axis.text.x   = element_text(hjust=0.5, vjust=0, size=12, color="#6D7C83", face="bold"))
#Faire des flèches
arrows <- tibble(
  x1 = c(50, 16, 53.5, 53.5, 53.5),
  x2 = c(49, 15,   51,   51,   51),
  y1 = c(35, 70,    5,   25,   40),
  y2 = c(22, 61,    0,   13,   19)
)
gg<-gg +    geom_curve(data = arrows, aes(x = x1, y = y1, xend = x2, yend = y2), 
                              arrow = arrow(length = unit(0.1, "inch")), 
                              size = 0.3, color = "#6D7C83", curvature = -0.3)
#ajouter les étiquettes de données
gg<-gg + annotate(geom="text", x=50,y=35, label="The youngest to\nbecome Emperor", color="#6D7C83", size=3, hjust=0,vjust=0.5, fontface="bold")
gg<-gg + annotate(geom="text", x=18,y=70, label="His reign\nend before\nhe dies", color="#6D7C83", size=3, hjust=0.5,vjust=0.5, fontface="bold")
gg<-gg + annotate(geom="text", x=54,y=5, label="Birth", color="#6D7C83", size=3, hjust=0.5,vjust=0.5, fontface="bold")
gg<-gg + annotate(geom="text", x=55,y=25, label="Reign\nStart", color="#6D7C83", size=3, hjust=0.5,vjust=0.8, fontface="bold")
gg<-gg + annotate(geom="text", x=54,y=40, label="Death", color="#6D7C83", size=3, hjust=0.5,vjust=0.5, fontface="bold")
Posted on:
August 13, 2019
Length:
3 minute read, 569 words
Categories:
rstats tidyverse tidytuesday
Tags:
rstats tidyverse tidytuesday
See Also:
FADQ historical crops data
I Juste Make my Own Blog!
TyT2020W10 - 3D Aeras