Podcast ADV #7: Qu’est-ce qu’on fait quand ce qu’on pensait visualiser dans les données ne donne rien de bon?

 

Qu’est-ce qu’on fait quand ce qu’on voulait initialement visualiser dans les données ne donne rien d’autre qu’on gros nuage de points?  Quels sont les règles les plus importantes de la visualisation de données? Venez découvrir tout ça et bien plus dans cet épisode.

Voici l’article de blog en lien avec cet épisode.

 

line fra FINAL

TyT2019|W17: Nuage de points et tendance

Pour le #Tidytuesday de cette semaine, nous avons l’occasion de regarder les données des comics et animations qui sont catalogués sur le site MyAnimeList.net.

CONTEXTE

Ce site offre à ses utilisateurs un système de type liste pour organiser et marquer des comics et des animations selon le gout de l’utilisateur et fournit une grande base de données sur les animations et les comics. Le site prétend avoir 4,4 millions d’animations et 775 000 comics. En 2015, le site a reçu 120 millions de visiteurs par mois.

 

OBJECTIFS

1) Visualiser la relation entre la popularité des animations et leur score.

IMPORTER

tidy_anime <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-23/tidy_anime.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   .default = col_character(),
FALSE   animeID = col_double(),
FALSE   episodes = col_double(),
FALSE   airing = col_logical(),
FALSE   start_date = col_date(format = ""),
FALSE   end_date = col_date(format = ""),
FALSE   score = col_double(),
FALSE   scored_by = col_double(),
FALSE   rank = col_double(),
FALSE   popularity = col_double(),
FALSE   members = col_double(),
FALSE   favorites = col_double()
FALSE )
FALSE See spec(...) for full column specifications.

EXPLORER

glimpse(tidy_anime)
## Observations: 77,911
## Variables: 28
## $ animeID        <dbl> 1, 1, 1, 1, 1, 1, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6…
## $ name           <chr> "Cowboy Bebop", "Cowboy Bebop", "Cowboy Bebop", "…
## $ title_english  <chr> "Cowboy Bebop", "Cowboy Bebop", "Cowboy Bebop", "…
## $ title_japanese <chr> "カウボーイビバップ", "カウボーイビバップ", "カウボーイビバップ", "カウボーイビバップ…
## $ title_synonyms <chr> "[]", "[]", "[]", "[]", "[]", "[]", "[\"Cowboy Be…
## $ type           <chr> "TV", "TV", "TV", "TV", "TV", "TV", "Movie", "Mov…
## $ source         <chr> "Original", "Original", "Original", "Original", "…
## $ producers      <chr> "Bandai Visual", "Bandai Visual", "Bandai Visual"…
## $ genre          <chr> "Action", "Adventure", "Comedy", "Drama", "Sci-Fi…
## $ studio         <chr> "Sunrise", "Sunrise", "Sunrise", "Sunrise", "Sunr…
## $ episodes       <dbl> 26, 26, 26, 26, 26, 26, 1, 1, 1, 1, 1, 1, 1, 1, 1…
## $ status         <chr> "Finished Airing", "Finished Airing", "Finished A…
## $ airing         <lgl> FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, …
## $ start_date     <date> 1998-04-03, 1998-04-03, 1998-04-03, 1998-04-03, …
## $ end_date       <date> 1999-04-02, 1999-04-02, 1999-04-02, 1999-04-02, …
## $ duration       <chr> "24 min per ep", "24 min per ep", "24 min per ep"…
## $ rating         <chr> "R - 17+ (violence & profanity)", "R - 17+ (viole…
## $ score          <dbl> 8.81, 8.81, 8.81, 8.81, 8.81, 8.81, 8.41, 8.41, 8…
## $ scored_by      <dbl> 405664, 405664, 405664, 405664, 405664, 405664, 1…
## $ rank           <dbl> 26, 26, 26, 26, 26, 26, 164, 164, 164, 164, 164, …
## $ popularity     <dbl> 39, 39, 39, 39, 39, 39, 449, 449, 449, 449, 449, …
## $ members        <dbl> 795733, 795733, 795733, 795733, 795733, 795733, 1…
## $ favorites      <dbl> 43460, 43460, 43460, 43460, 43460, 43460, 776, 77…
## $ synopsis       <chr> "In the year 2071, humanity has colonized several…
## $ background     <chr> "When Cowboy Bebop first aired in spring of 1998 …
## $ premiered      <chr> "Spring 1998", "Spring 1998", "Spring 1998", "Spr…
## $ broadcast      <chr> "Saturdays at 01:00 (JST)", "Saturdays at 01:00 (…
## $ related        <chr> "{'Adaptation': [{'mal_id': 173, 'type': 'manga',…
summary(tidy_anime)
##     animeID          name           title_english      title_japanese    
##  Min.   :    1   Length:77911       Length:77911       Length:77911      
##  1st Qu.: 3052   Class :character   Class :character   Class :character  
##  Median :13667   Mode  :character   Mode  :character   Mode  :character  
##  Mean   :16863                                                           
##  3rd Qu.:31452                                                           
##  Max.   :39197                                                           
##                                                                          
##  title_synonyms         type              source         
##  Length:77911       Length:77911       Length:77911      
##  Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character  
##                                                          
##                                                          
##                                                          
##                                                          
##   producers            genre              studio             episodes     
##  Length:77911       Length:77911       Length:77911       Min.   :   1.0  
##  Class :character   Class :character   Class :character   1st Qu.:   1.0  
##  Mode  :character   Mode  :character   Mode  :character   Median :  12.0  
##                                                           Mean   :  15.8  
##                                                           3rd Qu.:  13.0  
##                                                           Max.   :3057.0  
##                                                           NA's   :987     
##     status            airing          start_date        
##  Length:77911       Mode :logical   Min.   :1917-01-01  
##  Class :character   FALSE:76528     1st Qu.:2002-09-01  
##  Mode  :character   TRUE :1383      Median :2011-01-22  
##                                     Mean   :2007-03-14  
##                                     3rd Qu.:2015-09-18  
##                                     Max.   :2019-02-03  
##                                     NA's   :238         
##     end_date            duration            rating         
##  Min.   :1962-02-02   Length:77911       Length:77911      
##  1st Qu.:2005-06-02   Class :character   Class :character  
##  Median :2012-06-02   Mode  :character   Mode  :character  
##  Mean   :2009-03-29                                        
##  3rd Qu.:2016-03-02                                        
##  Max.   :2019-09-02                                        
##  NA's   :33824                                             
##      score          scored_by            rank         popularity   
##  Min.   : 1.000   Min.   :      0   Min.   :    1   Min.   :    1  
##  1st Qu.: 6.360   1st Qu.:    597   1st Qu.: 1530   1st Qu.: 1064  
##  Median : 7.020   Median :   7130   Median : 3685   Median : 3033  
##  Mean   : 6.894   Mean   :  43495   Mean   : 4557   Mean   : 4567  
##  3rd Qu.: 7.550   3rd Qu.:  39876   3rd Qu.: 6724   3rd Qu.: 7394  
##  Max.   :10.000   Max.   :1107955   Max.   :13838   Max.   :15474  
##  NA's   :174                                                       
##     members          favorites        synopsis          background       
##  Min.   :      6   Min.   :     0   Length:77911       Length:77911      
##  1st Qu.:   1968   1st Qu.:     2   Class :character   Class :character  
##  Median :  18214   Median :    40   Mode  :character   Mode  :character  
##  Mean   :  85051   Mean   :  1468                                        
##  3rd Qu.:  88560   3rd Qu.:   413                                        
##  Max.   :1610561   Max.   :120331                                        
##                                                                          
##   premiered          broadcast           related         
##  Length:77911       Length:77911       Length:77911      
##  Class :character   Class :character   Class :character  
##  Mode  :character   Mode  :character   Mode  :character  
##                                                          
##                                                          
##                                                          
## 

Les données ont déjà été travaillées et tout est déjà sous un format prêt à travailler. Faire attention aux NA’s ici.
PRÉPARER:

data%
  select(name, start_date, score, rating, popularity)%>%
  filter(!is.na(start_date) & !is.na(score))%>%
  filter(!rating=="None")%>%
  distinct()

VISUALISER

#Graphique
gg<-ggplot(data=data, aes(x=popularity, y=score))
gg<-gg + geom_point(size=2, color=alpha("#80FF72", 0.1))
gg<-gg + geom_smooth(size=2.5, color="#E8EBE4")
#ajuster les axes
#gg<-gg + scale_y_continuous(breaks=seq(1,7,1), limits = c(1, 7))
gg<-gg + scale_x_continuous(breaks=seq(0, 18000, 2000),limits = c(0, 16000))
#gg<-gg + expand_limits(x =c(-2,16))
#modifier la légende
gg<-gg + theme(legend.position="none")
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              plot.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line = element_line(size=1, color="#E8EBE4", linetype="solid"),
              axis.ticks= element_line(size=0.5, color="#E8EBE4", linetype="solid"))
#ajouter les titres
gg<-gg + labs(title="Existe-t-il une relation entre la popularité et le score des animations et des comics?",
              subtitle="Il semblerait que plus les animations sont populaires, c'est-à-dire plus il y a de personnes qui les ont dans leurs listes\npersonnelles, plus le score de l'animation diminue.",
              y="Score",
              x="Popularité")
gg<-gg + theme(plot.title    = element_text(hjust=0,size=17, color="#E8EBE4"),
               plot.subtitle = element_text(hjust=0,size=12, color="#E8EBE4"),
               axis.title.y  = element_text(hjust=1, size=12, color="#E8EBE4"),
               axis.title.x  = element_text(hjust=0, size=12, color="#E8EBE4"),
               axis.text.y   = element_text(hjust=0.5, size=10, color="#E8EBE4"),
               axis.text.x   = element_text(hjust=0.5, size=10, color="#E8EBE4"))

Voici ce que ça donne:

TyT2019|W16: Rang, histogramme ou autre??

Pour le #Tidytuesday de cette semaine, nous avons l’occasion de regarder des visualisations qui ont étés révisées par Sarah Leo de The Economist . Dans leur archives, elle a trouvé 7 exemples de graphiques qui avaient besion d’être revu.

CONTEXTE

Pour cette semaine, je me concentre sur son 7e exemple qui concerne la place des femmes dans le monde de la recherche avec publications.

La visualisation originale présente le pourcentage des femmes qui ont soumis des publications pour différents domaines (sciences de la santé, sciences physique, ingénérie, mathématique et sciences informatiques, inventeures) pour différents pays.

Le défi ici des d’essayer de présenter beaucoup de données dans un espace restreint.

Voici le graphique original à revoir:

OBJECTIFS

1) Explorer quelques visualisation pour voir ce qui se prête le mieux à ces données.

IMPORTER

brexit <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-16/brexit.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   date = col_character(),
FALSE   percent_responding_right = col_double(),
FALSE   percent_responding_wrong = col_double()
FALSE )
corbyn <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-16/corbyn.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   political_group = col_character(),
FALSE   avg_facebook_likes = col_double()
FALSE )
dogs <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-16/dogs.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   year = col_double(),
FALSE   avg_weight = col_double(),
FALSE   avg_neck = col_double()
FALSE )
eu_balance <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-16/eu_balance.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   country = col_character(),
FALSE   account_type = col_character(),
FALSE   year = col_double(),
FALSE   value = col_double()
FALSE )
pensions <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-16/pensions.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   country = col_character(),
FALSE   pop_65_percent = col_double(),
FALSE   gov_spend_percent_gdp = col_double()
FALSE )
trade <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-16/trade.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   year = col_double(),
FALSE   trade_deficit = col_double(),
FALSE   manufacture_employment = col_double()
FALSE )
women_research <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-16/women_research.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   country = col_character(),
FALSE   field = col_character(),
FALSE   percent_women = col_double()
FALSE )

EXPLORER

glimpse(women_research)
## Observations: 60
## Variables: 3
## $ country       <chr> "Japan", "Chile", "United Kingdom", "United States…
## $ field         <chr> "Health sciences", "Health sciences", "Health scie…
## $ percent_women <dbl> 0.24, 0.43, 0.45, 0.46, 0.46, 0.47, 0.48, 0.48, 0.…
summary(women_research)
##    country             field           percent_women   
##  Length:60          Length:60          Min.   :0.0800  
##  Class :character   Class :character   1st Qu.:0.1900  
##  Mode  :character   Mode  :character   Median :0.2250  
##                                        Mean   :0.2617  
##                                        3rd Qu.:0.2825  
##                                        Max.   :0.5700
summary%
  group_by(field)%>%
  summarise(mean=mean(percent_women))

Les données ont déjà été travaillées ici, donc rien de ce qui est présenté dans cette table est inutilisé pour faire la visualisation. De plus, tout est déjà sous un format prêt à travailler. Par contre, pour la visualisation que j’ai en tête, il faut quand même travailler un peu pour préparer les données:

Pour regarder les données avec un graphique de rang:

PRÉPARER:

rank%
  mutate(country=(ifelse(country=="United Kingdom", "UK", country)))%>%
  mutate(country=(ifelse(country=="United States", "US", country)))%>%
  mutate(field=(ifelse(field=="Computer science, maths", "Informatique, maths", field)))%>%
  mutate(field=(ifelse(field=="Engineering", "Ingénérie", field)))%>%
  mutate(field=(ifelse(field=="Health sciences", "Sciences de la santé", field)))%>%
  mutate(field=(ifelse(field=="Physical sciences", "Sciences physique", field)))%>%
  mutate(field=(ifelse(field=="Women inventores", "Inventeures", field)))%>%
  spread(country, percent_women)%>%
  arrange((`Australia`)) %>%
          mutate(`Australia`= c(1:5))%>%
  arrange((`Brazil`)) %>%
          mutate(`Brazil`= c(1:5))%>%
  arrange((`Canada`)) %>%
          mutate(`Canada`= c(1:5))%>%
  arrange((`Chile`)) %>%
          mutate(`Chile`= c(1:5))%>%
   arrange((`Denmark`)) %>%
          mutate(`Denmark`= c(1:5))%>%
     arrange((`EU28`)) %>%
          mutate(`EU28`= c(1:5))%>%
     arrange((`France`)) %>%
          mutate(`France`= c(1:5))%>%
     arrange((`Japan`)) %>%
          mutate(`Japan`= c(1:5))%>%
     arrange((`Mexico`)) %>%
          mutate(`Mexico`= c(1:5))%>%
     arrange((`Portugal`)) %>%
          mutate(`Portugal`= c(1:5))%>%
     arrange((`UK`)) %>%
          mutate(`UK`= c(1:5))%>%
     arrange((`US`)) %>%
          mutate(`US`= c(1:5))%>%
  gather(key=country, value=rang, -field) #changer la mise en page pour analyse

VISUALISER

#Graphique
gg<-ggplot(data=rank, aes(x=country, y=rang, group=field, color=field))
gg<-gg + geom_line(size=3)
gg<-gg + geom_point(size=5)
#Ajouter les étiquettes de données
gg% filter(country == "Australia"), aes(label = field, x = 0.8) , hjust = 1, size = 4)
gg<-gg + scale_color_manual(values = c("#E8EBE4", "#E8EBE4", "#FE9920", "#698F3F", "#E8EBE4"))
#ajuster les axes
#gg<-gg + scale_y_continuous(breaks=seq(1,7,1), limits = c(1, 7))
#gg<-gg + scale_x_discrete(breaks=seq(0, 12, 1),limits = c(0, 12))
gg<-gg + expand_limits(x =c(-2,16))
#modifier la légende
gg<-gg + theme(legend.position="none")
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              plot.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line = element_blank(),
              axis.ticks.y = element_blank(),
              axis.ticks.x = element_blank())
#ajouter les titres
gg<-gg + labs(title= NULL,
              subtitle=NULL,
              y=NULL,
              x=NULL)
gg<-gg + theme(plot.title    = element_text(hjust=0,size=25, color="#E8EBE4"),
               plot.subtitle = element_text(hjust=0,size=18, color="#E8EBE4"),
               axis.title.y  = element_blank(),
               axis.title.x  = element_blank(),
               axis.text.y   = element_blank(),
               axis.text.x   = element_text(hjust=0.5, size=10, color="#E8EBE4"))
#Ajouter les étiquettes de données
gg<-gg + annotate(geom="text", x=12.3,y=5, label="Les sciences de la santé sont le\ndomaine de recherche ou les\nfemmes sont les plus présentes.\nEn moyenne 47% des publications\nsont faites par des femmes.", color="#698F3F", size=4, hjust=0,vjust=0.9)
gg<-gg + annotate(geom="text", x=12.3,y=3, label="L'ingénierie, l'informatique, les\nmathématiques et les sciences\nphysiques sont des domaines où\n23% des articles sont publiés par\nune femme.", color="#E8EBE4", size=4, hjust=0,vjust=0.5)
gg<-gg + annotate(geom="text", x=12.3,y=1, label="Inventeurs est le domaine le moins\nreprésenté par la femme. En\nmoyenne, seulement 15% des\narticles sont publiés par une femme.", color="#FE9920", size=4, hjust=0, vjust=0.1)

Voici ce que ça donne:

Pour regarder les données avec un histogramme:

PRÉPARER:

bar%
  mutate(country=(ifelse(country=="United Kingdom", "UK", country)))%>%
  mutate(country=(ifelse(country=="United States", "US", country)))%>%
  mutate(field=(ifelse(field=="Computer science, maths", "Informatique, maths", field)))%>%
  mutate(field=(ifelse(field=="Engineering", "Ingénérie", field)))%>%
  mutate(field=(ifelse(field=="Health sciences", "Sciences de la santé", field)))%>%
  mutate(field=(ifelse(field=="Physical sciences", "Sciences physique", field)))%>%
  mutate(field=(ifelse(field=="Women inventores", "Inventeures", field)))

VISUALISER

#Graphique
gg<-ggplot(data=bar, aes(x=country, y=percent_women, group=field, fill=field))
gg<-gg + geom_bar(stat="identity", width = 0.65)
gg<-gg + scale_fill_manual(values = c("#E8EBE4", "#E8EBE4", "#FE9920", "#698F3F", "#E8EBE4"))
gg<-gg +geom_hline(data = bar, aes(yintercept = 0),color="#E8EBE4", size=1.5)
gg<-gg + facet_wrap((factor(field,levels=c("Sciences de la santé","Ingénérie","Informatique, maths","Sciences physique", "Inventeures")) ~ .), ncol=1)
gg<-gg + theme(strip.text.x = element_text(size=12, face="bold", hjust=0, color="#E8EBE4"),
         strip.background = element_rect(colour="#292E1E", fill="#292E1E"))
#ajuster les axes
gg<-gg + scale_y_continuous(labels = function(x) paste0(x*100, "%"), limits =c(0, 1))
#modifier la légende
gg<-gg + theme(legend.position="none")
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              plot.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line.x = element_blank(),
              axis.line.y = element_line(linetype = "solid", size=1, color="#E8EBE4"),
              axis.ticks.y = element_line(linetype = "solid", size=0.3, color="#E8EBE4"),
              axis.ticks.x = element_blank())
#ajouter les titres
gg<-gg + labs(title= NULL,
              subtitle=NULL,
              y="Pourcentage des articles publiés qui l'on été par des femmes",
              x=NULL)
gg<-gg + theme(plot.title    = element_text(hjust=0,size=25, color="#E8EBE4"),
               plot.subtitle = element_text(hjust=0,size=18, color="#E8EBE4"),
               axis.title.y  = element_text(hjust=0.5, size=10, color="#E8EBE4", angle=90),
               axis.title.x  = element_blank(),
               axis.text.y   = element_text(hjust=0.5, size=10, color="#E8EBE4"),
               axis.text.x   = element_text(hjust=0.5, size=10, color="#E8EBE4"))

Voici ce que ça donne:

Pour regarder les données avec un graphique de points:

PRÉPARER:

bar%
  mutate(country=(ifelse(country=="United Kingdom", "UK", country)))%>%
  mutate(country=(ifelse(country=="United States", "US", country)))%>%
  mutate(field=(ifelse(field=="Computer science, maths", "Informatique, maths", field)))%>%
  mutate(field=(ifelse(field=="Engineering", "Ingénérie", field)))%>%
  mutate(field=(ifelse(field=="Health sciences", "Sciences de la santé", field)))%>%
  mutate(field=(ifelse(field=="Physical sciences", "Sciences physique", field)))%>%
  mutate(field=(ifelse(field=="Women inventores", "Inventeures", field)))%>%
  mutate(gap=0.5-percent_women)

VISUALISER

#Graphique
gg<-ggplot(data=bar, aes(x=country, y=gap, group=field, color=factor(field, levels=c("Sciences de la santé","Informatique, maths","Ingénérie","Sciences physique","Inventeures"))))
gg<-gg + geom_point(size=5)
gg<-gg + scale_color_manual(values = c("#698F3F", "#E8EBE4", "#E8EBE4", "#E8EBE4", "#FE9920"))
gg<-gg + geom_hline(yintercept = 0, color="#E8EBE4", size=1, linetype="dotted")
gg<-gg + coord_flip()
#ajuster les axes
#gg<-gg + scale_y_continuous(labels = function(x) paste0(x*100, "%"), limits =c(0, 1))
#modifier la légende
gg<-gg + theme(legend.position="top",
        legend.title = element_blank(),
        legend.background = element_blank(),
        legend.key=element_blank(),
        legend.spacing.x = unit(0.5, 'cm'),
        legend.text= element_text(hjust =0.5,size= 12, colour = "#A9A9A9"))
gg<-gg + guides(fill = guide_legend(nrow = 1, reverse = TRUE))
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              plot.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line.x = element_line(linetype = "solid", size=1, color="#E8EBE4"),
              axis.line.y = element_line(linetype = "solid", size=1, color="#E8EBE4"),
              axis.ticks.y = element_line(linetype = "solid", size=0.3, color="#E8EBE4"),
              axis.ticks.x = element_line(linetype = "solid", size=0.3, color="#E8EBE4"))
#ajouter les titres
gg<-gg + labs(title= NULL,
              subtitle=NULL,
              y="L'équart de l'équité de publication",
              x=NULL)
gg<-gg + theme(plot.title    = element_text(hjust=0,size=25, color="#E8EBE4"),
               plot.subtitle = element_text(hjust=0,size=18, color="#E8EBE4"),
               axis.title.y  = element_text(hjust=0.5, size=10, color="#E8EBE4", angle=90),
               axis.title.x  = element_text(hjust=0.5, size=10, color="#E8EBE4"),
               axis.text.y   = element_text(hjust=0.5, size=10, color="#E8EBE4"),
               axis.text.x   = element_text(hjust=0.5, size=10, color="#E8EBE4"))

Voici ce que ça donne:

TyT2019|W15: Left_join ou Right_join? On a le choix mais il faut valider!

Pour le #Tidytuesday de cette semaine, nous avons l’occasion de regarder les tournois du Grand Chelem. Financial Times a produite un arcivle qui a couvert l’aspect historique des femmes au tennis. Cet article couvre plus de données que ce qui nous est proposé ici, mais il contient plusieurs visualisation qui vallent la peine d’être vues.

 

CONTEXTE

Les tournois du Grand Chelem, également appelés majors, sont les quatre événements annuels les plus importants. Ils offrent le plus grand nombre de points de classement, de récompenses, d’attention du public et des médias, la plus grande force et la plus grande taille du terrain, ainsi qu’un plus grand nombre de « meilleurs ». L’épreuve du Grand Chelem comprend l’Open australien mi-janvier, l’Ouverture Française entre fin mai et début juin, Wimbledon en juin-juillet et l’US Open en août-septembre. Chaque tournoi se déroule sur deux Les tournois australien et américain se jouent sur des courts en dur, le français sur terre battue et le Wimbledon sur gazon.

 

OBJECTIFS

1) Visualiser l’évolution de l’âge au premier grand titre pour les hommes et les femmes

IMPORTER

tt_data<-tt_load("2019-04-09")
FALSE Parsed with column specification:
FALSE cols(
FALSE   player = col_character(),
FALSE   year = col_double(),
FALSE   tournament = col_character(),
FALSE   outcome = col_character(),
FALSE   gender = col_character()
FALSE )
FALSE Parsed with column specification:
FALSE cols(
FALSE   year = col_double(),
FALSE   grand_slam = col_character(),
FALSE   name = col_character(),
FALSE   rolling_win_count = col_double(),
FALSE   tournament_date = col_date(format = ""),
FALSE   gender = col_character()
FALSE )
FALSE Parsed with column specification:
FALSE cols(
FALSE   name = col_character(),
FALSE   grand_slam = col_character(),
FALSE   date_of_birth = col_date(format = ""),
FALSE   date_of_first_title = col_date(format = ""),
FALSE   age = col_double()
FALSE )
print(tt_data)
FALSE Available Datasets:
FALSE   grand_slam_timeline 
FALSE   grand_slams 
FALSE   pic1 
FALSE   pic2 
FALSE   player_dob 
FALSE   tennis_pros 
FALSE   

EXPLORER

data_age<-tt_data$player_dob
glimpse(data_age)
## Observations: 105
## Variables: 5
## $ name                <chr> "Nancy Richey", "Virginia Wade", "Billie Jea…
## $ grand_slam          <chr> "French Open", "US Open", "Wimbledon", "Aust…
## $ date_of_birth       <date> 1942-08-23, 1945-07-10, 1943-11-22, 1942-07…
## $ date_of_first_title <date> 1968-06-08, 1968-09-07, 1968-07-05, 1969-01…
## $ age                 <dbl> 9421, 8460, 8992, 9691, 7249, 7116, 7360, 10…
summary(data_age)
##      name            grand_slam        date_of_birth       
##  Length:105         Length:105         Min.   :1934-11-02  
##  Class :character   Class :character   1st Qu.:1956-03-19  
##  Mode  :character   Mode  :character   Median :1971-08-12  
##                                        Mean   :1968-10-21  
##                                        3rd Qu.:1981-08-08  
##                                        Max.   :1997-10-16  
##                                                            
##  date_of_first_title       age       
##  Min.   :1968-06-08   Min.   : 5961  
##  1st Qu.:1978-06-16   1st Qu.: 7512  
##  Median :1994-10-15   Median : 8286  
##  Mean   :1992-10-28   Mean   : 8531  
##  3rd Qu.:2004-06-06   3rd Qu.: 9502  
##  Max.   :2018-09-08   Max.   :12724  
##  NA's   :3            NA's   :3
grand_slams<-tt_data$grand_slams
glimpse(grand_slams)
## Observations: 416
## Variables: 6
## $ year              <dbl> 1968, 1968, 1968, 1968, 1969, 1969, 1969, 1969…
## $ grand_slam        <chr> "australian_open", "french_open", "wimbledon",…
## $ name              <chr> "Billie Jean King", "Nancy Richey", "Billie Je…
## $ rolling_win_count <dbl> 1, 1, 2, 1, 1, 2, 1, 3, 4, 5, 6, 7, 8, 1, 2, 3…
## $ tournament_date   <date> 1968-01-10, 1968-06-09, 1968-07-14, 1968-09-0…
## $ gender            <chr> "Female", "Female", "Female", "Female", "Femal…
summary(grand_slams)
##       year       grand_slam            name           rolling_win_count
##  Min.   :1968   Length:416         Length:416         Min.   : 1.000   
##  1st Qu.:1980   Class :character   Class :character   1st Qu.: 1.000   
##  Median :1993   Mode  :character   Mode  :character   Median : 4.000   
##  Mean   :1993                                         Mean   : 5.507   
##  3rd Qu.:2006                                         3rd Qu.: 8.000   
##  Max.   :2019                                         Max.   :23.000   
##  tournament_date         gender         
##  Min.   :1968-01-10   Length:416        
##  1st Qu.:1979-12-10   Class :character  
##  Median :1993-03-26   Mode  :character  
##  Mean   :1993-04-09                     
##  3rd Qu.:2006-02-16                     
##  Max.   :2019-01-10
Hmisc::describe(data_age$age)
## data_age$age 
##        n  missing distinct     Info     Mean      Gmd      .05      .10 
##      102        3      102        1     8531     1661     6387     6615 
##      .25      .50      .75      .90      .95 
##     7512     8286     9502    10674    10938 
## 
## lowest :  5961  6033  6114  6285  6320, highest: 10967 11061 12252 12273 12724
Hmisc::describe(data_age$date_of_first_title)
## data_age$date_of_first_title 
##        n  missing distinct 
##      102        3      102 
## 
## lowest : 1968-06-08 1968-06-09 1968-07-05 1968-07-06 1968-09-07
## highest: 2017-06-10 2017-09-09 2018-01-27 2018-06-09 2018-09-08
Hmisc::describe(grand_slams$tournament_date)
## grand_slams$tournament_date 
##        n  missing distinct 
##      416        0      204 
## 
## lowest : 1968-01-10 1968-06-09 1968-07-14 1968-09-09 1969-01-10
## highest: 2018-01-10 2018-06-09 2018-07-14 2018-09-09 2019-01-10
Hmisc::describe(data_age$grand_slam)
## data_age$grand_slam 
##        n  missing distinct 
##      102        3        7 
## 
## Australian Open (19, 0.186), Australian Open (December) (1, 0.010),
## Australian Open (Jan.) (1, 0.010), Australian Open (January) (1, 0.010),
## French Open (39, 0.382), US Open (24, 0.235), Wimbledon (17, 0.167)
Hmisc::describe(grand_slams$grand_slam)
## grand_slams$grand_slam 
##        n  missing distinct 
##      416        0        4 
##                                                                           
## Value      australian_open     french_open         us_open       wimbledon
## Frequency              104             104             104             104
## Proportion            0.25            0.25            0.25            0.25
Hmisc::describe(data_age$name)
## data_age$name 
##        n  missing distinct 
##      105        0      105 
## 
## lowest : Adriano Panatta    Albert Costa       Amélie Mauresmo    Ana Ivanovic       Anastasia Myskina 
## highest: Virginia Wade      Vitas Gerulaitis   William Bowrey     Yannick Noah       Yevgeny Kafelnikov
Hmisc::describe(grand_slams$name)
## grand_slams$name 
##        n  missing distinct 
##      416        0      105 
## 
## lowest : Adriano Panatta    Albert Costa       Amélie Mauresmo    Ana Ivanovic       Anastasia Myskina 
## highest: Virginia Wade      Vitas Gerulaitis   William Bowrey     Yannick Noah       Yevgeny Kafelnikov
Hmisc::describe(grand_slams$gender)
## grand_slams$gender 
##        n  missing distinct 
##      416        0        2 
##                         
## Value      Female   Male
## Frequency     208    208
## Proportion    0.5    0.5

Nous disposons de plusieurs variables. Toutefois, pour pouvoir pousser plus l’exploration de ces données, il va falloir travailler un peu les âges car elles sont sotckées sous forme de jour et non d’année. Pour avoir le genre, il faut joindre 2 tables de données ensemble. Donc, il faut s’assurer que toutes ces valeurs contenues dans ces colonnes concordent.

PRÉPARER:

gender% #J'ai besion de sélectionner seulement le genre
  select(name, gender)%>%
  distinct()

data%
  mutate(age_y=round(age/365, digits = 0))%>% #modifier l'age pour l'avoir en année
  mutate(tournament_date=date_of_first_title)%>% #avoir le même nom de colonne pour joindre les fichiers
  left_join(gender, by="name")%>%
  mutate(annee=year(date_of_first_title))%>%
  select("name", "gender", "age_y", "date_of_first_title")

glimpse(data) #validation du nombre de ligne des données combinées
FALSE Observations: 105
FALSE Variables: 4
FALSE $ name                <chr> "Nancy Richey", "Virginia Wade", "Billie Jea…
FALSE $ gender              <chr> "Female", "Female", "Female", "Female", "Fem…
FALSE $ age_y               <dbl> 26, 23, 25, 27, 20, 19, 20, 29, 21, 23, 22, …
FALSE $ date_of_first_title <date> 1968-06-08, 1968-09-07, 1968-07-05, 1969-01…
summary(data) #validation des données manquante comme on a fait un left_join
FALSE      name              gender              age_y      date_of_first_title 
FALSE  Length:105         Length:105         Min.   :16.0   Min.   :1968-06-08  
FALSE  Class :character   Class :character   1st Qu.:21.0   1st Qu.:1978-06-16  
FALSE  Mode  :character   Mode  :character   Median :23.0   Median :1994-10-15  
FALSE                                        Mean   :23.4   Mean   :1992-10-28  
FALSE                                        3rd Qu.:26.0   3rd Qu.:2004-06-06  
FALSE                                        Max.   :35.0   Max.   :2018-09-08  
FALSE                                        NA's   :3      NA's   :3

VISUALISER

gg<-ggplot(data=data, aes(x=date_of_first_title, y=age_y, group=gender, color=gender))
gg<-gg + geom_line(size=2)
gg<- gg +scale_color_manual(values=c("#931328", "#3E7BBC"))
#modifier la légende
gg<-gg + theme(legend.position="top")
#ajuster les étiquettes des axes
gg<-gg + scale_x_date(date_breaks = "10 year", date_labels = "%Y")
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#FFFFFF", colour = "#FFFFFF"),
              plot.background = element_rect(fill = "#FFFFFF", colour = "#FFFFFF"),
              panel.grid.major.x= element_line(linetype="dotted", size=0.5, color="#9F9F9F"),
              panel.grid.major.y= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line.y = element_blank(),
              axis.line.x = element_line(linetype="solid", size=1, color="#9F9F9F"),
              axis.ticks.x = element_line(linetype="solid", size=1, color="#9F9F9F"),
              axis.ticks.y = element_blank())
#ajouter les titres
gg<-gg + labs(title= "Grand Chelem: Qu'est-ce qu'on peut constater comme tendance???",
              subtitle=NULL,
              y="Âge moyen à la première victoire",
              x="Années")
gg<-gg + theme(plot.title    = element_text(hjust=0,size=18, color="#5B5B5B"),
               plot.subtitle = element_text(hjust=0,size=12, color="#5B5B5B"),
               axis.title.x  = element_text(hjust=0.5, size=12,angle=360, color="#5B5B5B"),
               axis.title.y  = element_text(hjust=0.5, size=12, angle=90,color="#5B5B5B"),
               axis.text.y   = element_blank(),
               axis.text.x   = element_text(hjust=0.5, size=8, color="#5B5B5B"))

Avec ce graphique, on peut se faire une idée générale de la tendance de l’age à la première victiore, mais ce n’est pas très clair. Il y a trop de variation dans les données pour que le portrait global soit clair. Pour améliorer le tout, on peut regrouper les données en faisant la moyenne des ages des gagnants sur une période de temps. Disons 10 ans.
Voyons ce que ça donne:

PRÉPARER:

gender% #J'ai besion de sélectionner seulement le genre
  select(name, gender)%>%
  distinct()

data%
  mutate(age_y=round(age/365, digits = 0))%>% #modifier l'age pour l'avoir en année
  mutate(tournament_date=date_of_first_title)%>% #avoir le même nom de colonne pour joindre les fichiers
  left_join(gender, by="name")%>%
  mutate(annee=year(date_of_first_title))%>%
  mutate(decennie=0)%>%
  mutate(decennie=ifelse(annee%
  mutate(decennie=ifelse(annee>1970 & annee%
  mutate(decennie=ifelse(annee>1980 & annee%
  mutate(decennie=ifelse(annee>1990 & annee%
  mutate(decennie=ifelse(annee>2000 & annee%
  mutate(decennie=ifelse(annee>2010 & annee%
  group_by(gender, decennie)%>%
  summarise(age_moy=mean(age_y, na.rm = TRUE))%>%
  filter(!is.na(decennie))

data$decennie<-factor(data$decennie,levels = c(60,70, 80, 90, 00, 10))

glimpse(data) #validation du nombre de ligne des données combinées
FALSE Observations: 12
FALSE Variables: 3
FALSE Groups: gender [2]
FALSE $ gender   <chr> "Female", "Female", "Female", "Female", "Female", "Fema…
FALSE $ decennie <fct> 0, 10, 60, 70, 80, 90, 0, 10, 60, 70, 80, 90
FALSE $ age_moy  <dbl> 22.77778, 25.69231, 25.25000, 21.55556, 18.20000, 21.00…
summary(data) #validation des données manquante comme on a fait un left_join
FALSE     gender          decennie    age_moy     
FALSE  Length:12          60:2     Min.   :18.20  
FALSE  Class :character   70:2     1st Qu.:21.82  
FALSE  Mode  :character   80:2     Median :23.48  
FALSE                     90:2     Mean   :23.53  
FALSE                     0 :2     3rd Qu.:25.36  
FALSE                     10:2     Max.   :27.80

VISUALISER

gg<-ggplot(data=data, aes(x=decennie, y=age_moy, group=gender, color=gender))
gg<-gg + geom_line(size=3)
gg<-gg + geom_point(size=6)
gg<- gg +scale_color_manual(values=c("#931328", "#3E7BBC"))
gg<-gg + geom_point(size=5, color="#FFFFFF")
#Ajouter les étiquettes de données
gg<-gg + geom_text(data=data, aes(x=decennie, y=age_moy, label=round(age_moy, digits=0)), size=2.75, vjust=0.5, family="Calibri")
gg<- gg +scale_color_manual(values=c("#931328", "#3E7BBC"))
#modifier la légende
gg<-gg + theme(legend.position="none")
#ajuster les étiquettes des axes
gg<-gg + scale_y_continuous(breaks=seq(15, 35, 5),limits = c(15, 35))
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#FFFFFF", colour = "#FFFFFF"),
              plot.background = element_rect(fill = "#FFFFFF", colour = "#FFFFFF"),
              panel.grid.major.x= element_line(linetype="dotted", size=0.5, color="#9F9F9F"),
              panel.grid.major.y= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line.y = element_blank(),
              axis.line.x = element_line(linetype="solid", size=1, color="#9F9F9F"),
              axis.ticks.x = element_line(linetype="solid", size=1, color="#9F9F9F"),
              axis.ticks.y = element_blank())
#ajouter les titres
gg<-gg + labs(title= "Grand Chelem: Qu'est-ce qui c'est passé dans les années 80?",
              subtitle="L'âge moyen à laquel les joueurs ont remportés leur premier titre est passé de 28 à 22 ans pour les\nhommes et de 25 à 18 ans pour les femmes entre les années 60 et les années 80. L'age moyen est\nrevenu à 27 ans pour les hommes et 26 ans pour les femmes dans les anées 2010",
              y="Âge moyen à la première victoire",
              x="Années")
gg<-gg + theme(plot.title    = element_text(hjust=0,size=20, color="#5B5B5B"),
               plot.subtitle = element_text(hjust=0,size=12, color="#5B5B5B"),
               axis.title.x  = element_text(hjust=0.5, size=12,angle=360, color="#5B5B5B"),
               axis.title.y  = element_text(hjust=0.5, size=12, angle=90,color="#5B5B5B"),
               axis.text.y   = element_blank(),
               axis.text.x   = element_text(hjust=0.5, size=8, color="#5B5B5B"))

Ce qu’on peut observer:

  • L’âge moyen de la première victoire varie en fonction du temps et était à son minimun dans les années 80.
  • J’ai regroupé les âges moyens pour les hommes et les femmes par période de 10 ans pour pouvoir voir un tendances dans les données. Faire afficher les données de toutes les années individuellement ne nous montrait aucune tendance claire.
  • Il y a une différence entre les hommes et les femmes, les femmes gagnent généralement leur premier titre plus jeune ques les hommes.
  • Par contre, j’ai l’impression qu’il nous manque des éléments pour que l’histoire soit claire. Pourquoi est-ce que l’age à la première victoire diminue dans les années 80?

Est-ce que le nombre de joueurs qu’on considère par décénie est le même?

PRÉPARER:

gender% #J'ai besion de sélectionner seulement le genre
  select(name, gender)%>%
  distinct()

data%
  mutate(age_y=round(age/365, digits = 0))%>% #modifier l'age pour l'avoir en année
  mutate(tournament_date=date_of_first_title)%>% #avoir le même nom de colonne pour joindre les fichiers
  left_join(gender, by="name")%>%
  mutate(annee=year(date_of_first_title))%>%
  mutate(decennie=0)%>%
  mutate(decennie=ifelse(annee%
  mutate(decennie=ifelse(annee>1970 & annee%
  mutate(decennie=ifelse(annee>1980 & annee%
  mutate(decennie=ifelse(annee>1990 & annee%
  mutate(decennie=ifelse(annee>2000 & annee%
  mutate(decennie=ifelse(annee>2010 & annee<=2020, 10, decennie))

by(data, data$decennie, summary)
FALSE data$decennie: 0
FALSE      name            grand_slam        date_of_birth       
FALSE  Length:20          Length:20          Min.   :1971-09-13  
FALSE  Class :character   Class :character   1st Qu.:1979-05-14  
FALSE  Mode  :character   Mode  :character   Median :1981-07-23  
FALSE                                        Mean   :1981-09-06  
FALSE                                        3rd Qu.:1985-09-20  
FALSE                                        Max.   :1988-09-23  
FALSE  date_of_first_title       age            age_y       tournament_date     
FALSE  Min.   :2001-01-27   Min.   : 6285   Min.   :17.00   Min.   :2001-01-27  
FALSE  1st Qu.:2003-03-08   1st Qu.: 7547   1st Qu.:21.00   1st Qu.:2003-03-08  
FALSE  Median :2004-06-06   Median : 8066   Median :22.00   Median :2004-06-06  
FALSE  Mean   :2004-09-26   Mean   : 8421   Mean   :23.15   Mean   :2004-09-26  
FALSE  3rd Qu.:2005-10-15   3rd Qu.: 9410   3rd Qu.:26.25   3rd Qu.:2005-10-15  
FALSE  Max.   :2010-06-05   Max.   :10939   Max.   :30.00   Max.   :2010-06-05  
FALSE     gender              annee         decennie
FALSE  Length:20          Min.   :2001   Min.   :0  
FALSE  Class :character   1st Qu.:2003   1st Qu.:0  
FALSE  Mode  :character   Median :2004   Median :0  
FALSE                     Mean   :2004   Mean   :0  
FALSE                     3rd Qu.:2005   3rd Qu.:0  
FALSE                     Max.   :2010   Max.   :0  
FALSE -------------------------------------------------------- 
FALSE data$decennie: 10
FALSE      name            grand_slam        date_of_birth       
FALSE  Length:16          Length:16          Min.   :1982-02-25  
FALSE  Class :character   Class :character   1st Qu.:1985-02-11  
FALSE  Mode  :character   Mode  :character   Median :1989-02-28  
FALSE                                        Mean   :1989-03-08  
FALSE                                        3rd Qu.:1992-02-09  
FALSE                                        Max.   :1997-10-16  
FALSE  date_of_first_title       age            age_y       tournament_date     
FALSE  Min.   :2011-06-04   Min.   : 7307   Min.   :20.00   Min.   :2011-06-04  
FALSE  1st Qu.:2012-07-15   1st Qu.: 8260   1st Qu.:23.00   1st Qu.:2012-07-15  
FALSE  Median :2015-03-11   Median : 9614   Median :26.50   Median :2015-03-11  
FALSE  Mean   :2015-01-04   Mean   : 9434   Mean   :25.88   Mean   :2015-01-04  
FALSE  3rd Qu.:2017-07-02   3rd Qu.:10305   3rd Qu.:28.25   3rd Qu.:2017-07-02  
FALSE  Max.   :2018-09-08   Max.   :12252   Max.   :34.00   Max.   :2018-09-08  
FALSE     gender              annee         decennie 
FALSE  Length:16          Min.   :2011   Min.   :10  
FALSE  Class :character   1st Qu.:2012   1st Qu.:10  
FALSE  Mode  :character   Median :2014   Median :10  
FALSE                     Mean   :2015   Mean   :10  
FALSE                     3rd Qu.:2017   3rd Qu.:10  
FALSE                     Max.   :2018   Max.   :10  
FALSE -------------------------------------------------------- 
FALSE data$decennie: 60
FALSE      name            grand_slam        date_of_birth       
FALSE  Length:9           Length:9           Min.   :1934-11-02  
FALSE  Class :character   Class :character   1st Qu.:1942-07-16  
FALSE  Mode  :character   Mode  :character   Median :1943-07-10  
FALSE                                        Mean   :1942-06-16  
FALSE                                        3rd Qu.:1944-05-23  
FALSE                                        Max.   :1946-03-01  
FALSE  date_of_first_title       age            age_y       tournament_date     
FALSE  Min.   :1968-06-08   Min.   : 8460   Min.   :23.00   Min.   :1968-06-08  
FALSE  1st Qu.:1968-07-05   1st Qu.: 8992   1st Qu.:25.00   1st Qu.:1968-07-05  
FALSE  Median :1968-09-07   Median : 9421   Median :26.00   Median :1968-09-07  
FALSE  Mean   :1969-01-11   Mean   : 9706   Mean   :26.67   Mean   :1969-01-11  
FALSE  3rd Qu.:1969-01-26   3rd Qu.: 9691   3rd Qu.:27.00   3rd Qu.:1969-01-26  
FALSE  Max.   :1970-07-04   Max.   :12273   Max.   :34.00   Max.   :1970-07-04  
FALSE     gender              annee         decennie 
FALSE  Length:9           Min.   :1968   Min.   :60  
FALSE  Class :character   1st Qu.:1968   1st Qu.:60  
FALSE  Mode  :character   Median :1968   Median :60  
FALSE                     Mean   :1969   Mean   :60  
FALSE                     3rd Qu.:1969   3rd Qu.:60  
FALSE                     Max.   :1970   Max.   :60  
FALSE -------------------------------------------------------- 
FALSE data$decennie: 70
FALSE      name            grand_slam        date_of_birth       
FALSE  Length:21          Length:21          Min.   :1937-08-03  
FALSE  Class :character   Class :character   1st Qu.:1950-07-09  
FALSE  Mode  :character   Mode  :character   Median :1954-06-24  
FALSE                                        Mean   :1952-12-04  
FALSE                                        3rd Qu.:1956-06-06  
FALSE                                        Max.   :1962-12-12  
FALSE  date_of_first_title       age            age_y       tournament_date     
FALSE  Min.   :1971-06-05   Min.   : 6114   Min.   :17.00   Min.   :1971-06-05  
FALSE  1st Qu.:1974-06-15   1st Qu.: 7510   1st Qu.:21.00   1st Qu.:1974-06-15  
FALSE  Median :1976-06-14   Median : 8309   Median :23.00   Median :1976-06-14  
FALSE  Mean   :1976-02-20   Mean   : 8478   Mean   :23.24   Mean   :1976-02-20  
FALSE  3rd Qu.:1978-01-01   3rd Qu.: 9219   3rd Qu.:25.00   3rd Qu.:1978-01-01  
FALSE  Max.   :1980-01-01   Max.   :12724   Max.   :35.00   Max.   :1980-01-01  
FALSE     gender              annee         decennie 
FALSE  Length:21          Min.   :1971   Min.   :70  
FALSE  Class :character   1st Qu.:1974   1st Qu.:70  
FALSE  Mode  :character   Median :1976   Median :70  
FALSE                     Mean   :1976   Mean   :70  
FALSE                     3rd Qu.:1978   3rd Qu.:70  
FALSE                     Max.   :1980   Max.   :70  
FALSE -------------------------------------------------------- 
FALSE data$decennie: 80
FALSE      name            grand_slam        date_of_birth       
FALSE  Length:16          Length:16          Min.   :1954-12-23  
FALSE  Class :character   Class :character   1st Qu.:1960-04-30  
FALSE  Mode  :character   Mode  :character   Median :1965-09-22  
FALSE                                        Mean   :1965-08-05  
FALSE                                        3rd Qu.:1970-09-06  
FALSE                                        Max.   :1973-12-02  
FALSE  date_of_first_title       age            age_y       tournament_date     
FALSE  Min.   :1981-01-03   Min.   : 6033   Min.   :17.00   Min.   :1981-01-03  
FALSE  1st Qu.:1983-03-15   1st Qu.: 6486   1st Qu.:18.00   1st Qu.:1983-03-15  
FALSE  Median :1986-09-07   Median : 7116   Median :19.50   Median :1986-09-07  
FALSE  Mean   :1986-05-15   Mean   : 7588   Mean   :20.75   Mean   :1986-05-15  
FALSE  3rd Qu.:1989-09-10   3rd Qu.: 8490   3rd Qu.:23.25   3rd Qu.:1989-09-10  
FALSE  Max.   :1990-09-10   Max.   :11061   Max.   :30.00   Max.   :1990-09-10  
FALSE     gender              annee         decennie 
FALSE  Length:16          Min.   :1981   Min.   :80  
FALSE  Class :character   1st Qu.:1983   1st Qu.:80  
FALSE  Mode  :character   Median :1986   Median :80  
FALSE                     Mean   :1986   Mean   :80  
FALSE                     3rd Qu.:1989   3rd Qu.:80  
FALSE                     Max.   :1990   Max.   :80  
FALSE -------------------------------------------------------- 
FALSE data$decennie: 90
FALSE      name            grand_slam        date_of_birth       
FALSE  Length:20          Length:20          Min.   :1967-10-02  
FALSE  Class :character   Class :character   1st Qu.:1970-07-20  
FALSE  Mode  :character   Mode  :character   Median :1973-07-24  
FALSE                                        Mean   :1974-02-08  
FALSE                                        3rd Qu.:1976-12-03  
FALSE                                        Max.   :1981-09-26  
FALSE  date_of_first_title       age            age_y       tournament_date     
FALSE  Min.   :1991-06-10   Min.   : 5961   Min.   :16.00   Min.   :1991-06-10  
FALSE  1st Qu.:1994-12-06   1st Qu.: 7481   1st Qu.:20.75   1st Qu.:1994-12-06  
FALSE  Median :1997-04-01   Median : 8108   Median :22.00   Median :1997-04-01  
FALSE  Mean   :1996-07-22   Mean   : 8200   Mean   :22.50   Mean   :1996-07-22  
FALSE  3rd Qu.:1998-06-14   3rd Qu.: 8469   3rd Qu.:23.50   3rd Qu.:1998-06-14  
FALSE  Max.   :2000-09-11   Max.   :10967   Max.   :30.00   Max.   :2000-09-11  
FALSE     gender              annee         decennie 
FALSE  Length:20          Min.   :1991   Min.   :90  
FALSE  Class :character   1st Qu.:1995   1st Qu.:90  
FALSE  Mode  :character   Median :1997   Median :90  
FALSE                     Mean   :1996   Mean   :90  
FALSE                     3rd Qu.:1998   3rd Qu.:90  
FALSE                     Max.   :2000   Max.   :90

Donc,

années 60 = 9 joueurs
années 70 = 21 joueurs
années 80 = 16 joueurs
années 90 = 20 joueurs
années 00 = 20 joueurs
années 10 = 16 joueurs

Je pense qu’on peut seulement suspecter les années 60 comme étant aberhant. Rien ne laisse suspecter d’explication pour notre cas des années 80.

Ensuite, comment varie le nombre de nouveau gagnant par décénnie?

PRÉPARER:

gender%
  select(name, gender, year, rolling_win_count)%>%
  mutate(annee=year)%>%
  mutate(decennie=0)%>%
  mutate(decennie=ifelse(annee%
  mutate(decennie=ifelse(annee>1970 & annee%
  mutate(decennie=ifelse(annee>1980 & annee%
  mutate(decennie=ifelse(annee>1990 & annee%
  mutate(decennie=ifelse(annee>2000 & annee%
  mutate(decennie=ifelse(annee>2010 & annee%
  filter(rolling_win_count==1)%>%
  group_by(gender, decennie)%>%
  summarise(somme_new=sum(rolling_win_count, na.rm = TRUE))%>%
  filter(!is.na(decennie))%>%
  select(decennie, gender, somme_new)

gender$decennie<-factor(gender$decennie,levels = c(60,70, 80, 90, 00, 10))

glimpse(gender) #validation du nombre de ligne des données combinées
FALSE Observations: 12
FALSE Variables: 3
FALSE Groups: gender [2]
FALSE $ decennie  <fct> 0, 10, 60, 70, 80, 90, 0, 10, 60, 70, 80, 90
FALSE $ gender    <chr> "Female", "Female", "Female", "Female", "Female", "Fem…
FALSE $ somme_new <dbl> 9, 13, 5, 11, 4, 8, 11, 3, 6, 13, 10, 12
summary(gender) #validation des données manquante comme on a fait un left_join
FALSE  decennie    gender            somme_new    
FALSE  60:2     Length:12          Min.   : 3.00  
FALSE  70:2     Class :character   1st Qu.: 5.75  
FALSE  80:2     Mode  :character   Median : 9.50  
FALSE  90:2                        Mean   : 8.75  
FALSE  0 :2                        3rd Qu.:11.25  
FALSE  10:2                        Max.   :13.00

VISUALISER

gg<-ggplot(data=gender, aes(x=decennie, y=somme_new, group=gender, color=gender))
gg<-gg + geom_line(size=3)
gg<-gg + geom_point(size=6)
gg<- gg +scale_color_manual(values=c("#931328", "#3E7BBC"))
gg<-gg + geom_point(size=5, color="#FFFFFF")
#Ajouter les étiquettes de données
gg<-gg + geom_text(data=gender, aes(x=decennie, y=somme_new, label=round(somme_new, digits=0)), size=2.75, vjust=0.5, family="Calibri")
gg<- gg +scale_color_manual(values=c("#931328", "#3E7BBC"))
gg<-gg + annotate(geom="text", x=1,y=4, label="Femmes", color="#931328", size=4, hjust=1, fontface="bold")
gg<-gg + annotate(geom="text", x=1,y=7, label="Hommes", color="#3E7BBC", size=4, hjust=1, fontface="bold")
#modifier la légende
gg<-gg + theme(legend.position="none")
#ajuster les étiquettes des axes
gg<-gg + scale_y_continuous(breaks=seq(0, 20, 5),limits = c(0, 20))
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#FFFFFF", colour = "#FFFFFF"),
              plot.background = element_rect(fill = "#FFFFFF", colour = "#FFFFFF"),
              panel.grid.major.x= element_line(linetype="dotted", size=0.5, color="#9F9F9F"),
              panel.grid.major.y= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line.y = element_blank(),
              axis.line.x = element_line(linetype="solid", size=1, color="#9F9F9F"),
              axis.ticks.x = element_line(linetype="solid", size=1, color="#9F9F9F"),
              axis.ticks.y = element_blank())
#ajouter les titres
gg<-gg + labs(title= "Grand Chelem: Comment à évoluer le nombre de nouveaux gagnant?",
              subtitle=NULL,
              y="Nombre de nouveaux gagnants",
              x="Années")
gg<-gg + theme(plot.title    = element_text(hjust=0,size=18, color="#5B5B5B"),
               plot.subtitle = element_text(hjust=0,size=12, color="#5B5B5B"),
               axis.title.x  = element_text(hjust=0.5, size=12,angle=360, color="#5B5B5B"),
               axis.title.y  = element_text(hjust=0.5, size=12, angle=90,color="#5B5B5B"),
               axis.text.y   = element_blank(),
               axis.text.x   = element_text(hjust=0.5, size=8, color="#5B5B5B"))

Peu de nouveau gagnant du côté des femmes dans les années 80 et une moins forte diminution du côté des hommes. Ça va à l’encontre de ce qu’on a constaté pour l’age à la première victoire…

Dernière question, comment évolu l’age moyen de tous les participants par décénnie?

PRÉPARER:

players%
  filter(!outcome %in% "Absent")%>%
  mutate(name=player)%>%
  mutate(annee=year)%>%
  mutate(decennie=0)%>%
  mutate(decennie=ifelse(annee%
  mutate(decennie=ifelse(annee>1970 & annee%
  mutate(decennie=ifelse(annee>1980 & annee%
  mutate(decennie=ifelse(annee>1990 & annee%
  mutate(decennie=ifelse(annee>2000 & annee%
  mutate(decennie=ifelse(annee>2010 & annee%
  select(name, gender, decennie)%>%
  left_join(data_age, by="name")

Il semblerait qu’on ne dispose pas de la date de naissance de tous les joueurs, je suspecte qu’on a pas l’information pour les joueurs qui n’ont pas gagné…

Donc, les données ne nous permettent pas de comprendre pourquoi est-ce que l’age moyen à la première victoire est inérieur pour les années 80.

Vous voulez en apprendre plus sur ma démarche? Allez écouter l’épisode de podcast dans lequel j’explique mes réflexions pour arriver à ce résultat.

SWD Challenge|2019M4: Immiter!

Cole nous a mis au défi, ce mois-ci, de trouver une visualisation et de la refaire avec l’outil de notre choix. C’est bien connu qu’on apprend beaucoup par immitation, alors l’objectif ici est d’améliorer nos compétences en visualisation à travers le travail d’un expert.

J’ai choisi la visualisation réalisée par Eva Murray pour la 3e semaine du MakeoverMonday. Voici le lien pour les données originales, le lien pour le blog de Eva dans lequel elle décrit son travail et son graphique:

29__#$!@%!#__inconnu

Pour avoir participé moi aussi à la semaine 3 du MakeoverMonday, je peux dire que cette analyse de données est tout simplement brillante. Les données forment une histoire cohérente et les annotations viennent renforcer le message. Du côté de la visualisation, je me souvient m’être dit en voyant ce visuel que j’avais beaucoup de croûte à manger avant de pouvoir faire quelque chose d’aussi élégant.

J’ai beaucoup appris en programation dans R dans les dernières semaines, alors imiter ce graphique me semblait être tout approprié.

Je peux vous confirmer que faire autant d’annotation dans R a vraiment été un défi pour moi, mais je sui bien fière du résultat que voici:

graph final

À travers ce travail, j’ai pu comprendre un peu plus le travail d’analyse qu’il est important de mettre dans chacune de ses visualisations. De plus, mettre les données en contexte, avec des annotations ici, vient vraiment renforcer le message ou l’histoire qu’on veut faire ressortir. Quelques fois, il faut être prêt à aller chercher ces éléments à l’extérieur des données elles-mêmes.

MakeoverMonday | 2019W14: Déchets sur les plages de britaniques

Cette semaine, nous avons eu l’occasion de regarder les type de déchets qui se retrouvent sur les plages britaniques.

Voici le graphique original à réviser et l’article en lien avec notre travail de cette semaine:

Ce qui fonctionne:

  • Titre bien utilisé
  • Le sous-titre apporte une précision supplémentaire
  • Étiquette des données présentes
  • Le design et les couleurs sont bien pensés
  • La source des données est indentifée au bas du graphique

Ce qui peut être amélioré:

  • Sur ce graphique, la taille des cercles représente la porportion occupé par chaque type de déchet. J’airrive facilement à voir que le type le plus important de déchets qu’on retrouve sur la plage est le plastique et les pièces de polystyrène. Par contre, pour les autres, j’arrive difficlement à distinguer leur différence.

Sur quoi je me suis concentrée:

  • Créer un visuel pour lequels on voit clairement la différence les différents types de déchets.
  • Utiliser les pourcentages du nombre de déchets total retrouvé sur la plage pour rendre plus facile la comparaison entre les différents types.
  • Ajouter des explications en sous-titre pour préciser le contexte.
  • Garder ça clair et simple!

Voici mon graphique:

bub final FRA

 

TyT2019|W14: Quand lubridate nous permet d’explorer des données

Pour le #Tidytuesday de cette semaine, nous avons l’occasion de regarder les compteurs de vélo à Seattle. Le Seattle Times a récemment couvert ce que nous pouvons apprendre de ces données. Ça vaut la pein d’aller jetter un petit coup d’oeil à cet article car, on y retrouve des visualisations très bien pensées!

CONTEXTE

Le ministère des Transports de Seattle possède 12 compteurs à vélos (dont quatre comptent également des piétons) situés sur des voies vertes de quartier, des sentiers polyvalents, sur le pont Fremont et sur la rue SW Spokane.

Les données issues de ces compteurs sont collectées depuis 2014 pour créer une base de données de fréquentation. L’objectif est de compiler l’utilisation des années antérieures et d’évaluer les années à venir afin de s’assurer que les investissements aident à atteindre leur objectif qui est de quadrupler le nombre de passagers d’ici 2030.

Dans son analyse, le Sealttle Time à mis en évidence que la collecte de données de la ville sur la fréquentation des pistes cyclables est dispersée et incomplète. Le nombre de passagers est mesuré à seulement 12 endroits où la ville a installé des comptoirs à vélos sur les voies vertes des quartiers, les sentiers polyvalents, les pistes cyclables protégées et sur le pont Fremont. De plus, les compteurs fonctionnent mal et n’enregistrent pas les données, parfois pendant des semaines ou des mois.

Ils en ont donc conclu qu’il n’est pas surprenant que les données montrent clairement que le nombre de passagers a considérablement diminué pendant les mois de pluies à Seattle. La période d’octobre 2016 à avril 2017 a été la plus humide depuis la tenue des registres dans la ville en 1895. Le trafic cycliste a considérablement diminué, avec une diminution mesurée de 6 à 58% sur les compteurs.

Dongho Chang, ingénieur en chef du trafic à Seattle, reconnaît les problèmes avec les données. Néanmoins, malgré tous leurs défauts, les guichets fournissent la seule information accessible au public sur l’utilisation des pistes cyclables à Seattle.

OBJECTIFS

1) Explolrer les données pour voir si je peux avoir une idée des données manquante dont il est question dans l’article et juger de leur importance vis-à-vis le travail que je veux faire.
2) Montrer l’évoluition dans le temps, selon différente perspective, de l’utilisation des vélos.
3) Essayer de me faire une idée à savoir si les données manquante sont vraiment la cause de la baisse du nombre de vélos sur les routes de Seatle.

IMPORTER

bike_traffic <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-02/bike_traffic.csv")
FALSE Parsed with column specification:
FALSE cols(
FALSE   date = col_character(),
FALSE   crossing = col_character(),
FALSE   direction = col_character(),
FALSE   bike_count = col_double(),
FALSE   ped_count = col_logical()
FALSE )

EXPLORER

glimpse(bike_traffic)
## Observations: 515,688
## Variables: 5
## $ date       <chr> "01/01/2014 12:00:00 AM", "01/01/2014 01:00:00 AM", "…
## $ crossing   <chr> "Broadway Cycle Track North Of E Union St", "Broadway…
## $ direction  <chr> "North", "North", "North", "North", "North", "North",…
## $ bike_count <dbl> 0, 3, 0, 0, 0, 0, 0, 0, 2, 0, 5, 0, 7, 4, 6, 6, 1, 4,…
## $ ped_count  <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, N…
Hmisc::describe(bike_traffic$crossing)
## bike_traffic$crossing 
##        n  missing distinct 
##   515688        0        7 
## 
## 39th Ave NE Greenway at NE 62nd St (77328, 0.150), Broadway Cycle Track
## North Of E Union St (89136, 0.173), Burke Gilman Trail (90480, 0.175),
## Elliot Bay Trail (90480, 0.175), MTS Trail (45576, 0.088), NW 58th St
## Greenway at 22nd Ave (89136, 0.173), Sealth Trail (33552, 0.065)
Hmisc::describe(bike_traffic$ped_count)
## bike_traffic$ped_count 
##        n  missing distinct 
##   103008   412680        2 
##                       
## Value      FALSE  TRUE
## Frequency  77609 25399
## Proportion 0.753 0.247
plt1 %
  ggplot(aes(x=" ", y = bike_count)) +
  geom_boxplot(fill = "#D8EADF", color = "black") +
  coord_flip() +
  theme_classic() +
  xlab("") +
  ylab("nombre de vélos")+
  theme(axis.text.y=element_blank(),
        axis.ticks.y=element_blank())

Nous disposons de plusieurs variables. Toutefois, pour pouvoir pousser plus l’exploration de ces données, il va falloir travailler un peu les dates, nottament avec lubridate pour pouvoir aller chercher les jours de la semaine et les heures.

bike_count représente le nombre de vélos comptés pour chaque fenêtre horaire.

Ped_count est inutile pour mon objetctif puisqu’il y a près de 413 000 données manquante sur un jeu de données de 516 000. Ça représente 80% de données manquante. Ce qui fait du sens puisque ce n’est pas tous les compteurs qui possèdent cette fonction, seulement 4.

On constate qu’il y a des observations (heures) ou il y a eu plus de 2000 vélos. Probablement des erreurs dans les données.

PRÉPARER: Explorer la distribution des données pour chaque intersection

var_width = 10
data%
  filter(bike_count% # retirer les données abérhantes
  mutate(date = mdy_hms(date))%>% #changer le format de la date pour pouvoir travailler
  mutate(date_simple = as.Date(date, format="%Y-%M-%d"))%>% #changer le format de la date pour le graphique
  mutate(crossing_1 = str_wrap(crossing, width = var_width)) # ajuster la largeur du texte pour l'affichage

VISUALISER

gg<-ggplot(data=data, aes(x=date_simple, y=bike_count))
gg<-gg + geom_point(colour ="#247BA0",pch=21, size = 0.2, alpha = 0.1)
gg<-gg + facet_grid(rows = vars(crossing_1), scale="free")
#modifier la légende
gg<-gg + theme(legend.position="none")
#ajuster les étiquettes des axes
gg<-gg + scale_x_date(date_breaks = "1 year", date_labels = "%Y")
#modifier l'aparence des boites de titres
gg<-gg +   theme(strip.background = element_rect(fill="#FFFBF4", colour = "#000000", size = 0.3, linetype = "solid"),
                 strip.text=element_text(size=7))
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              plot.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.y = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.x = element_line(linetype="solid", size=.3, color="#000000"))
#ajouter les titres
gg<-gg + labs(title= "Nombre de vélo pour chacune des intersections selon la date",
              subtitle=NULL,
              y="Nombre de vélos",
              x=NULL)
gg<-gg + theme(plot.title    = element_text(hjust=0,size=18, color="#000000"),
               plot.subtitle = element_text(hjust=0,size=18, color="#000000"),
               axis.title.y  = element_text(hjust=1, size=12, color="#000000"),
               axis.title.x  = element_blank(),
               axis.text.x   = element_text(hjust=0.5, size=8, color="#000000"),
               axis.text.y   = element_text(hjust=0.5, size=8, color="#000000"))

Ce qu’on peut observer:

  • Certaines stations sont beaucoup plus fréquentées que d’autres
  • Il y a effectivement des données manquantes à quelques endroit
  • Cycle selon les saisons: les bicyclettes c’est fait pour être utilisé l’été…
  • Est-ce qu’on devrait constater la baisse dû à la saison humide de octobre 2016 à avril 2017?

PRÉPARER: Explorer la distribution des données en fonction des jours de la semaine

data%
  filter(bike_count% # retirer les données abérhantes
  mutate(date = mdy_hms(date))%>% #changer le format de la date pour pouvoir travailler
  mutate(jour=weekdays(date))%>% #extraire le jour de la semaine
  mutate(annee=year(date))%>% #extraire l'année
  filter(!annee %in% c(2013,2019), crossing != 'Sealth Trail') %>% # retirer les données abérhantes
  group_by(jour, annee)%>%
  summarise(somme = sum(bike_count, na.rm = T))

VISUALISER

#Graphique
gg<-ggplot(data=data, aes(x=jour, y=somme, group=annee, color=factor(annee)))
gg<-gg + geom_line(size = 2)
gg<-gg + geom_point(shape = 21, fill = "#FFFBF4", size = 4, show.legend = F)
gg<-gg + scale_color_manual(values = c("#247BA0", "#D62828", "#FF9000", "#610F7F", "#57886C"))
#m odifier la légende
gg<-gg + theme(legend.title = element_blank(),
                legend.background = element_blank(),
                legend.key=element_blank())
#ajuster les étiquettes des axes
gg<-gg +   scale_y_continuous(labels = function(x) x/1000)
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              plot.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.y = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.x = element_line(linetype="solid", size=.3, color="#000000"))
#ajouter les titres
gg<-gg + labs(title= "Nombre de vélo pour chaque année en fonction des jours de la semaine",
              subtitle=NULL,
              y="Nombre de vélos (X1000)",
              x=NULL)
gg<-gg + theme(plot.title    = element_text(hjust=0,size=18, color="#000000"),
               plot.subtitle = element_text(hjust=0,size=18, color="#000000"),
               axis.title.y  = element_text(hjust=1, size=12, color="#000000"),
               axis.title.x  = element_blank(),
               axis.text.x   = element_text(hjust=0.5, size=8, color="#000000"),
               axis.text.y   = element_text(hjust=0.5, size=8, color="#000000"))

On peut observer que:

  • l’utilisation des vélos à Seatle diminue entre 2014 et 2018 si on regarde l’utilisation en fonction des jours de la semaine
  • Je me serait attendu à voir la saison 2018 reprendre après la saison humide mais ce n’est pas le cas. C’est difficile de se prononcer par contre par ce que effectivement, le compteur de Ghilman trail a cessé de fonctionner pendant quelques mois et celui sur la 39e avenue a cessé de fonctionner après le premier tier de l’année 2018 environ.

PRÉPARER: Explorer la distribution des données en fonction des heures de la journée

data%
  filter(bike_count% # retirer les données abérhante
  mutate(date = mdy_hms(date))%>% #changer le format de la date pour pouvoir travailler
  mutate(heure=hour(date)) %>% #extraire les heures
  mutate(annee=year(date))%>% #extraire l'année
  filter(!annee %in% c(2013,2019), crossing != 'Sealth Trail') %>% # retirer les données abérhante
  group_by(heure, annee)%>%
  summarise(somme = sum(bike_count, na.rm = T))

VISUALISER

#Graphique
gg<-ggplot(data=data, aes(x=heure, y=somme, group=annee, color=factor(annee)))
gg<-gg + geom_line(size = 2)
gg<-gg + scale_color_manual(values = c("#247BA0", "#D62828", "#FF9000", "#610F7F", "#57886C"))
#modifier la légende
gg<-gg + theme(legend.title = element_blank(),
                legend.background = element_blank(),
                legend.key=element_blank())
#ajuster les étiquettes des axes
gg<-gg +   scale_y_continuous(labels = function(x) x/1000)
gg<-gg +   scale_x_continuous(breaks = seq(0,23))
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              plot.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.y = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.x = element_line(linetype="solid", size=.3, color="#000000"))
#ajouter les titres
gg<-gg + labs(title= "Nombre de vélo pour chaque année en fonction des heures de la journée",
              subtitle=NULL,
              y="Nombre de vélos (X1000)",
              x=NULL)
gg<-gg + theme(plot.title    = element_text(hjust=0,size=18, color="#000000"),
               plot.subtitle = element_text(hjust=0,size=18, color="#000000"),
               axis.title.y  = element_text(hjust=1, size=12, color="#000000"),
               axis.title.x  = element_blank(),
               axis.text.x   = element_text(hjust=0.5, size=8, color="#000000"),
               axis.text.y   = element_text(hjust=0.5, size=8, color="#000000"))
#Annotation
gg<-gg + geom_vline(xintercept = c(8,17), linetype = 2)
gg<-gg + annotate("text", label = "temps de\ntrajet", x = 12.5, y = 25000)
gg<-gg +  geom_segment(xend = 8.5, x = 11, y = 20000, yend = 20000, col = "000000",
                       arrow = arrow(angle = 30, length = unit(2, "mm")))
gg<-gg +   geom_segment(xend = 16.5, x = 14, y = 20000, yend = 20000, col = "000000",
                        arrow = arrow(angle = 30, length = unit(2, "mm")))

On peut constater que:

  • Les pic d’utilisation des vélos se situent aux heures de début et de fin des heures de travail régulière. Donc, beaucoup de gens à Seatle utilisent les vélos pour aller travailler.

PRÉPARER: Explorer la distribution des données en fonction des heures de la journée par intersection

data%
  filter(bike_count% # retirer les données abérhantes
  mutate(date = mdy_hms(date))%>% #changer le format de la date pour pouvoir travailler
  mutate(heure=hour(date)) %>% #extraire les heures
  mutate(jour=weekdays(date))%>% #extraire le jour de la semaine
  mutate(annee=year(date))%>% #extraire l'année
  filter(!annee %in% c(2013,2019), crossing != 'Sealth Trail') %>% # retirer les données abérhantes
  group_by(heure,jour, crossing)%>%
  summarise(somme = sum(bike_count, na.rm = T))

data$jour <- factor(data$jour,levels = c("Dimanche","Lundi", "Mardi", "Mercredi", "Jeudi",
                                                   "Vendredi", "Samedi"))

VISUALISER

#Graphique

gg<- ggplot(data=data,aes(heure, fct_rev(jour)))
gg<- gg + geom_tile(aes(fill = somme))
gg<- gg +  facet_wrap(~crossing)
gg<- gg + scale_fill_viridis_c(guide = guide_legend(title.position = 'top',
                                            label.position = 'bottom',
                                            direction = 'horizontal',
                                            reverse = T, title = "Nombres de vélos",
                                            keywidth = unit(20,"mm"),
                                            keyheight = unit(2,"mm"),
                                            label.hjust = 0,
                                            label.theme = element_text(size = 8),
                                            title.theme = element_text(size = 9)))
#modifier la légende
gg<- gg +    theme(legend.position = 'top',
                  strip.text = element_text(size = 8),
                  legend.background = element_blank(),
                  legend.key=element_blank())
#ajuster les étiquettes des axes
gg<- gg +  scale_x_continuous(breaks = seq(0,23,2))
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              plot.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.y = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.x = element_line(linetype="solid", size=.3, color="#000000"))
#ajouter les titres
gg<-gg + labs(title= "Heures de pointe pour les cyclistes de Seattle par intersection",
              subtitle=NULL,
              y="Jour de la semaine",
              x="Heures du jour")
gg<-gg + theme(plot.title    = element_text(hjust=0,size=18, color="#000000"),
               plot.subtitle = element_text(hjust=0,size=18, color="#000000"),
               axis.title.y  = element_text(hjust=1, size=12, color="#000000"),
               axis.title.x  = element_text(hjust=0, size=12, color="#000000"),
               axis.text.x   = element_text(hjust=0.5, size=8, color="#000000"),
               axis.text.y   = element_text(hjust=0.5, size=8, color="#000000"))

On peut constater que:

  • Ce type de graphique met bien en évidence quelles stations sont les plus utilisées.

PRÉPARER: Évolution de l’utilisation des vélos dans le temps

data%
  filter(bike_count% # retirer les données abérhante
  mutate(date = mdy_hms(date))%>% #changer le format de la date pour pouvoir travailler
  mutate(date_simple = as.Date(date, format="%Y-%M-%d"))%>% #changer le format de la date
  mutate(annee=year(date))%>% #extraire l'année
  filter(!annee %in% c(2013,2019), crossing != 'Sealth Trail') %>% # retirer les données abérhante
  group_by(date_simple)%>%
  summarise(somme=sum(bike_count))

VISUALISER

#Graphique
gg<-ggplot(data=data, aes(x=date_simple, y=somme))
gg<-gg + geom_point(shape = 21, fill = "#A9A9A9", size = 2, show.legend = F)
gg<-gg + geom_smooth()
#ajuster les étiquettes des axes
gg<-gg +   scale_y_continuous(labels = function(x) x/1000)
gg<-gg + scale_x_date(date_breaks = "1 year", date_labels = "%Y")
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              plot.background = element_rect(fill = "#FFFBF4", colour = "#FFFBF4"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.y = element_line(linetype="solid", size=.3, color="#000000"),
              axis.ticks.x = element_line(linetype="solid", size=.3, color="#000000"))
#ajouter les titres
gg<-gg + labs(title= "Évolution du nombre de vélos présent sur les routes de Seatle",
              subtitle=NULL,
              y="Nombre de vélos (X1000)",
              x=NULL)
gg<-gg + theme(plot.title    = element_text(hjust=0,size=18, color="#000000"),
               plot.subtitle = element_text(hjust=0,size=18, color="#000000"),
               axis.title.y  = element_text(hjust=1, size=12, color="#000000"),
               axis.title.x  = element_blank(),
               axis.text.x   = element_text(hjust=0.5, size=8, color="#000000"),
               axis.text.y   = element_text(hjust=0.5, size=8, color="#000000"))
#Annotation
gg<-gg + geom_vline(xintercept = as.numeric(as.Date(c("2016-10-01","2017-04-30","2018-05-01", "2019-01-01"))), linetype = 2)
gg<-gg + annotate("text", label = "Saison\nhumide", x =as.Date("2017-01-15"), y = 8000, size=4)
gg<-gg + annotate("text", label = "Données\nmanquantes", x =as.Date("2018-09-01"), y = 8000, size=4)

On cosntate que le nombre de vélos présents sur les routes de Seatle diminue dans le temps si on compare les données de 2014 à 2018. Par contre, j’ai l’impression qu’il y a plus que ce qui est expliqué dans l’article, la diminution commence bien avant la saison humide de octobre de 2016. Le pic d’utilisation de l’été 2015 était déjà mois prononcé que celui de l’été 2014.

En conclusion, si l’objectif du département des transports de Seattle est des quadruplé l’utilisation des vélos d’ici 2030, ils sont sur la mauvaise voie…. Il devrait pousser plus loin leur questionnement pour chercher à comprendre pourquoi l’utilisation des vélos diminue dans le temps et apporter les correctifs nécessaire.

Vous voulez en apprendre plus sur ma démarche? Allez écouter l’épisode de podcast dans lequel j’explique mes réflexions pour arriver à ce résultat.

Courbe de croissance des porcs québeçois

Le Centre d’études sur les coûts de production en agriculture (CECPA) à publié récemment son étude de coût de production Porcelets et Porcs 2017. Plusieurs éléments intéressant y sont présentés, mais ce sont les valeurs de poids d’entrée et de sortie qui ont particulièrement attirées mon attention.

Voici donc la courbe de croissance des porcs québeçois basée sur les résultats de cette étude:

 

 

Podcast ADV #1: Line Chart ou comment utiliser des courbes pour montrer des différences

 

Qu’est-ce que les TidyTuesday? Comment on importe plusieurs .csv en une seule commande? Quand est-ce que je me permet de faire des graphiques plus punchés avec un fond foncé? Qui des hommes ou des femmes sont attêtés le plus souvent pour des contrôles routier en Caroline du Nord? Venez découvrir tout ça et bien plus dans ce premier épisode.

Voici le blog en lien avec cet épisode.

line fra final

TyT2019|W12: Line Chart ou comment utiliser des courbes pour montrer des différences

Pour le #Tidytuesday de cette semaine, nous avons accès aux données des contrôles routiers qui sont fait aux États-Unis. Lors d’une journée type, les policiers peuvent effectuer plus de 50 000 contrôles routiers, mettez tout ça dans une base de données qui comportent quelques années d’historique et on se trouve avec plus de 30 Go de données!! Définitivement de quoi d’amuser! Les données brutes proviennent du site THE STANFORD OPEN POLICING PROJECT. Nous avons aussi accès à une base de données simplifié sur github.

Cette semaine, j’ai deux objectifs en tête:
1) Importer plusieurs .csv en une seule commande et les grouper en une table de données.
2) Visualiser le nombre de contrôle routier qui a été effectué en Caroline du Nord en fonction de l’âge de la personne contrôlée et comparer les différences entre les hommes et les femmes.

IMPORTER

# lire les csv dans l'espace de travail
files <- list.files(path = "~/Documents/ENTREPRISE/Projets R/Tidytuesday/TyT2019/W12/data", pattern = "*.csv", full.names = T)
# grouper tous les fichiers en une seule table de données
tbl %
bind_rows(.id = "id")

EXPLORER

glimpse(tbl)
## Observations: 2,722,013
## Variables: 27
## $ id                 <chr> "/Users/johaniefournier/Documents/ENTREPRIS...
## $ raw_row_number     <int> 1219541, 1221117, 1221124, 1221133, 1221146...
## $ date               <date> 2001-12-28, 2002-01-02, 2002-01-02, 2002-0...
## $ time               <time>       NA, 04:00:00,       NA, 19:50:00, 20...
## $ location           <chr> "Durham, Durham County", "Durham, Durham Co...
## $ county_name        <chr> "Durham County", "Durham County", "Durham C...
## $ subject_age        <int> 22, 28, 21, 28, 36, 68, 24, 30, 38, 56, 28,...
## $ subject_race       <chr> "black", "hispanic", "black", "black", "bla...
## $ subject_sex        <chr> "female", "male", "male", "female", "female...
## $ officer_id_hash    <chr> "5b9908c1a5", "0c140e68b5", "0c140e68b5", "...
## $ department_name    <chr> "Durham Police Department", "Durham Police ...
## $ type               <chr> "vehicular", "vehicular", "vehicular", "veh...
## $ arrest_made        <lgl> FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, F...
## $ citation_issued    <lgl> FALSE, TRUE, FALSE, TRUE, FALSE, FALSE, FAL...
## $ warning_issued     <lgl> TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, FALSE...
## $ outcome            <chr> "warning", "citation", "warning", "citation...
## $ contraband_found   <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ contraband_drugs   <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ contraband_weapons <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ frisk_performed    <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ search_conducted   <lgl> FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, F...
## $ search_person      <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ search_vehicle     <lgl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ search_basis       <chr> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ reason_for_frisk   <chr> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ reason_for_search  <chr> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,...
## $ reason_for_stop    <chr> "Investigation", "Stop Light/Sign Violation...

Nous disposons de plusieurs variables, mais pour ce que j’ai en tête j’ai seulement besoin de la date (au cas), de l’age et du sexe des sujets. Je ne pousserai donc pas plus loin mon analyse du reste des variables de ces données, et je vais commencer par extraire seulement ces variables des données.

PRÉPARER

data%
  select(date,subject_age,subject_sex)%>% # conserver seulement les colonnes pertinentes pour l'analyse
  mutate(year=year(date))%>%
  group_by(subject_age,subject_sex)%>%
  summarise(nb=dplyr::n())%>%
  mutate(nb=nb/1000)

data_sum%
  summarise(sum=sum(nb))%>%
  summarise(sum=sum(sum))

VISUALISER

#Graphique
gg<-ggplot(data=data, aes(x=subject_age, y=nb, group=subject_sex, color=subject_sex))
gg<-gg + geom_line(size=1.5)
gg<-gg + scale_color_manual(values = c("#C003C6", "#A9A9A9"))
#échelle des axes
gg<-gg + scale_y_continuous(breaks=seq(0,80,10), limits = c(0, 80))
gg<-gg + scale_x_continuous(breaks=seq(0,100, 10), limits = c(0, 100))
#modifier la légende
gg<-gg + theme(legend.position="none")
#modifier le thème
gg<-gg +theme(panel.border = element_blank(),
              panel.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              plot.background = element_rect(fill = "#292E1E", colour = "#292E1E"),
              panel.grid.major.y= element_blank(),
              panel.grid.major.x= element_blank(),
              panel.grid.minor = element_blank(),
              axis.line = element_line(size=0.5, color="#A9A9A9"),
              axis.ticks = element_line(size=0.5, color="#A9A9A9"))
#ajouter les titres
gg<-gg + labs(title="Women in North Carolina are less stopped than men by police on the road!",
              subtitle="From 2000 to 2015, the Standford Open Policy Project collected informations of traffic stops by law enforcement in North Carolina.\nDuring those years, there has been over 2.7M of interventions by polices. Over all those interventions, woman are always less\nstopped than men no matter the age.",
              y="number of traffic stops (x1000)",
              x="Age")
gg<-gg + theme(plot.title    = element_text(hjust=0,size=20, color="#C003C6", face="bold"),
               plot.subtitle = element_text(hjust=0,size=12, color="#A9A9A9"),
               axis.title.y   = element_text(hjust=1,size=12, color="#A9A9A9"),
               axis.title.x  = element_text(hjust=0,size=12, color="#A9A9A9"),
               axis.text     = element_text(hjust=0.5,size=12, color="#A9A9A9"))
#Ajouter les étiquettes de données
gg<-gg + annotate(geom="text", x=20,y=60, label="Men", color="#A9A9A9", size=4, hjust=0, fontface="bold")
gg<-gg + annotate(geom="text", x=20,y=30, label="Women", color="#C003C6", size=4, hjust=0, fontface="bold")

J’ai choisi de comparer les nombres d’arrestations enter hommes et les femmes en fonction de l’age. Après avoir importé toutes les .csv de la Caroline du Nord et les avoir regroupés en une seule table de données, il y avait peu de manipulation à faire sur les données. Seulement grouper par catégorie et faire le compte du nombre d’arrestations. Utiliser des courbes m’apparaissaient le meilleur moyen de comparer les hommes et les femmes en fonction de leur âge. Le reste c’est une histoire de présentation graphique. Voici ce que ça donne:

 

Vous voulez en apprendre plus sur ma démarche? Allez écouter l’épisode de podcast dans lequel j’explique mes réflexions pour arriver à ce résultat.