Chapitre 5

library(tidyverse)

Exercice 5.1 : Les prénoms aux USA

1. Commençons par une solution en R classique

library(babynames)
babynames2000 <- babynames[babynames$year==2000,]
babynames2000_split <- split(babynames2000, babynames2000$sex)
babynames2000_split_top10 <- lapply(babynames2000_split, function(df) {df[order(df$n, decreasing = TRUE)[1:10],]})
babynames2000_top10 <- do.call(rbind, babynames2000_split_top10)
babynames2000_top10

Avec data.table, on peut faire

library(data.table)
babynames_dt <- data.table(babynames)
babynames2000_top10_dt <- babynames_dt[year == 2000,.SD[order(n, decreasing = TRUE)[1:10],], by = sex]
babynames2000_top10_dt

Enfin avec dplyr,

babynames_tbl <- babynames
babynames2000_top10_tbl <- babynames_tbl %>%
  filter(year == 2000) %>% 
  group_by(sex) %>%
  top_n(10, n) %>%
  arrange(desc(n), .by_group = TRUE)
babynames2000_top10_tbl      

2. Il faut tout d’abord calculé, pour chaque année et chaque sexe, les 2 prénoms les plus utilisées. On somme ensuite les proportions associées à chaque prénom.

• En R classique ça donne

babynames_split <- split(babynames,list(babynames$sex,babynames$year))
babynames_split_prop <- lapply(babynames_split,
                               function(df) {
                                 df <- df[order(df$prop, decreasing = TRUE)[1:10],]
                                 data.frame(year = df$year[[1]], sex = df$sex[[1]], prop_tot = sum(df$prop))
                               })
babynames_prop <- do.call(rbind, babynames_split_prop)
babynames_prop

• en data.table

babynames_dt[, .SD[order(prop, decreasing = TRUE)[1:10],],by = c("sex", "year")][, .(prop_tot = sum(prop)), by = c("sex", "year")]

• enfin en dplyr

babynames %>% group_by(sex,year) %>% top_n(10,n) %>% summarise(sum_prop=sum(prop))

3. On doit tout d’abord faire une jointure entre la table initiale et la table de la question 1. On somme ensuite les proportions associées à chaue prénom.

• En R classique ça donne

babynames_merge <- merge(babynames2000_top10[,c("sex", "name")],babynames)
babynames_split <- split(babynames_merge,list(babynames_merge$sex,babynames_merge$year))
babynames_split_prop <- lapply(babynames_split,
                               function(df) {
                                 df <- df[order(df$prop, decreasing = TRUE),]
                                 data.frame(year = df$year[[1]], sex = df$sex[[1]], prop_tot = sum(df$prop))
                               })
babynames_prop <- do.call(rbind, babynames_split_prop)
babynames_prop

• en data.table

babynames_dt[babynames2000_top10_dt[,c("sex", "name")],, on = c("sex", "name")][, .(prop_tot = sum(prop)), by = c("sex", "year")]

• enfin en dplyr

left_join(babynames2000_top10_tbl %>% select(sex, name),babynames_tbl) %>% group_by(sex,year) %>% summarize(prop2000=sum(prop))

Joining, by = c("sex", "name")

4. Pour simuler la base à distance, on commence par copier notre table à l’aide de SQLite

library(DBI)
con <- dbConnect(RSQLite::SQLite())
dbWriteTable(con, name = "babynames",babynames, overwrite = TRUE)

On peut alors lancer des requêtes SQL avec dbGetQuery.

• Pour la question 1 on a

dbGetQuery(con,
           'SELECT * FROM
           (SELECT *, RANK() OVER (PARTITION BY "sex" ORDER BY "n" DESC) as rank  FROM  babynames WHERE ("year" = 2000)) as TMP
           WHERE rank <= 10')

• pour la question 2

dbGetQuery(con,
           'WITH babynames_top AS
           (SELECT * 
           FROM
           (SELECT *, RANK() OVER (PARTITION BY sex,  "year" ORDER BY n DESC) as rank  FROM  babynames) as TMP
           WHERE rank <= 10)
           
           SELECT "year", sex, SUM(prop) as prop_tot FROM
           babynames_top 
           GROUP BY "year", sex')

• et enfin la question 3

dbGetQuery(con,
           'WITH babynames_top2000 AS (
           SELECT * 
           FROM
           (SELECT *, RANK() OVER (PARTITION BY "sex" ORDER BY "n" DESC) as rank  FROM  babynames WHERE ("year" = 2000)) as TMP
           WHERE rank <= 10
           ), 
           babynames_merge AS (
            SELECT  babynames."year" as "year",
                    babynames.sex as sex,
                    babynames.name as name,
                    babynames.n as n,
                    babynames.prop as prop
            FROM 
            babynames_top2000
            LEFT JOIN 
            babynames ON (babynames_top2000.sex = babynames.sex AND babynames_top2000.name = babynames.name))
            SELECT "year", sex, SUM(prop) as prop_tot FROM
            babynames_merge 
            GROUP BY "year", sex')

Une alternative aux requêtes SQL est l’utilisation du package dbplyr :

babynames_sql <- tbl(con, "babynames")

• On obtient pour la question 1

babynames2000_sql <- babynames_sql %>%
  filter(year == 2000) %>% 
  group_by(sex) 

babynames2000_top10_sql <- babynames2000_sql %>% collect() %>% top_n(10,n)
babynames2000_top10_sql

• Pour la question 2

babynames_sql %>% group_by(sex,year) %>% arrange(desc(n),.by_group=TRUE) %>% collect() %>% top_n(10,n) %>% summarise(sum_prop=sum(prop))

• et enfin pour la question 3

dbWriteTable(con, name = "babynames2000_top10_sql",babynames2000_top10_sql, overwrite = TRUE)
babynames2000_top10_sql <- tbl(con, "babynames2000_top10_sql")

left_join(babynames2000_top10_sql %>% select(sex, name),babynames_sql) %>% group_by(sex,year) %>% summarize(prop2000=sum(prop))

Et on n’oublie pas de se déconnecter !

dbDisconnect(con)

Exercice 5.2 : Les tournois majeurs au tennis en 2013

1. On utilise read_csv pour travailler avec un tibble.

df <- read_csv("FrenchOpen-men-2013.csv")

df %>% distinct(Player1)

df %>% distinct(Player2)

df %>% filter(Player1=="Roger Federer" | Player2=="Roger Federer") %>% select(contains("Play"))

df %>% filter(Round==6) %>% select(contains("Play"))

df %>% mutate(nb_points=TPW.1+TPW.2) %>% summarise(nb_points_moy=mean(nb_points))

df %>% mutate(nb_ace=ACE.1+ACE.2) %>% group_by(Round) %>% 
  summarise(min=min(nb_ace),max=max(nb_ace),moy=mean(nb_ace))

df %>% mutate(dbf=DBF.1+DBF.2) %>% summarize(tot.df=sum(dbf,na.rm=TRUE))

df %>% mutate(dbf=DBF.1+DBF.2) %>% ggplot() + aes(x=dbf) + geom_histogram(bins=10) + theme_bw()

df %>% mutate(dbf=DBF.1+DBF.2) %>% group_by(Round) %>% summarize(dbf=mean(dbf,na.rm=TRUE)) %>%
  ggplot() + aes(x=Round,y=dbf) + geom_bar(stat="identity",fill="red") + theme_classic()

df %>% select(Result,FSP.1,FSP.2) %>% gather(key="Player",value="FSP",-Result) %>% 
  mutate(Result=as.character((Result==1 & Player=="FSP.1") | (Result==0 & Player=="FSP.2"))) %>% 
  mutate(Result=fct_recode(Result,vic="TRUE",def="FALSE")) %>%
  ggplot() + aes(x=Result,y=FSP)+geom_boxplot()+theme_classic()

Il semble qu’il y ait une légère influence du pourcentage de premier service sur le résultat. On effectue un test de comparaison de moyennes pour vérifier :

df1 <- df %>% select(Result,FSP.1,FSP.2) %>% gather(key="Player",value="FSP",-Result) %>% 
  mutate(Result=as.character((Result==1 & Player=="FSP.1") | (Result==0 & Player=="FSP.2"))) %>% 
  mutate(Result=fct_recode(Result,vic="TRUE",def="FALSE"))
t.test(FSP~Result,data=df1)

    Welch Two Sample t-test

data:  FSP by Result
t = -1.8395, df = 247.3, p-value = 0.06704
alternative hypothesis: true difference in means is not equal to 0
95 percent confidence interval:
 -3.6279302  0.1239302
sample estimates:
mean in group def mean in group vic 
           61.536            63.288 

Au niveau 10%, on concluera qu’il y a une influence.

Exercice 5.3 : Le vélo STAR, encore !

1. On importe les tables

url <- paste0(
"https://data.rennesmetropole.fr/api/records/1.0/search/",
"?dataset=etat-des-stations-le-velo-star-en-temps-reel",
"&rows=100",
"&facet=nom",
"&facet=etat",
"&facet=nombreemplacementsactuels",
"&facet=nombreemplacementsdisponibles",
"&facet=nombrevelosdisponibles",
"&facet=coordonnees"
)
ll <- jsonlite::fromJSON(url)
etat <- ll$records$fields

url1 <- paste0(
"https://data.rennesmetropole.fr/api/records/1.0/search/",
"?dataset=topologie-des-stations-le-velo-star",
"&rows=100")
ll1 <- jsonlite::fromJSON(url1)
topo <- ll1$records$fields

2. On créé la table demandée

glimpse(etat)

Observations: 55
Variables: 8
$ etat                          <chr> "En fonctionnement", "En fonctionnement", "En fonctionnement", "En fonctionnement", "En fonctionnement", "En fonctionne…
$ lastupdate                    <chr> "2020-03-15T16:59:10+00:00", "2020-03-15T16:59:10+00:00", "2020-03-15T16:59:10+00:00", "2020-03-15T16:59:10+00:00", "20…
$ nombrevelosdisponibles        <int> 6, 3, 21, 10, 14, 4, 8, 1, 9, 16, 15, 5, 12, 13, 4, 0, 15, 7, 27, 8, 1, 8, 9, 9, 10, 11, 3, 6, 6, 11, 20, 15, 11, 7, 4,…
$ nombreemplacementsactuels     <int> 16, 24, 23, 24, 20, 24, 18, 18, 16, 28, 20, 24, 24, 26, 28, 18, 20, 20, 30, 28, 16, 28, 20, 20, 24, 16, 30, 18, 14, 25,…
$ nom                           <chr> "Musée Beaux-Arts", "Champs Libres", "La Criée", "Brest - Verdun", "Marbeuf", "Plaine de Baud", "Gros-Chêne", "Painlevé…
$ nombreemplacementsdisponibles <int> 10, 21, 2, 14, 6, 20, 10, 17, 7, 12, 5, 19, 12, 13, 24, 18, 5, 13, 3, 20, 15, 20, 11, 11, 14, 5, 27, 12, 8, 14, 4, 7, 5…
$ idstation                     <chr> "5510", "5516", "5521", "5534", "5538", "5546", "5578", "5580", "5581", "5582", "5587", "5502", "5505", "5506", "5512",…
$ coordonnees                   <list> [<48.10960, -1.67408>, <48.105537, -1.674328>, <48.107626, -1.680085>, <48.113009, -1.693264>, <48.111749, -1.702077>,…

latlong <- etat$coordonnees %>% unlist() %>% matrix(ncol=2,byrow=T) %>% as.data.frame()
names(latlong) <- c("latitude","longitude")
etat1 <- bind_cols(etat,latlong) %>% select(-coordonnees)
df <- inner_join(etat1,topo,by="nom") %>% select(id,nom,idstationproche1,latitude,longitude) %>% mutate(id=as.numeric(id))
df1 <- left_join(df,df,by=c("idstationproche1"="id")) %>% mutate(dist=(latitude.x-latitude.y)^2+(longitude.x-longitude.y)^2) 

3. On calcule les stations les plus proches du point demandé

etat1 %>% mutate(distance=(latitude-48.1179151)^2+(longitude+1.7028661)^2) %>% arrange(distance) %>% head(3) %>%
  arrange(distance,nombreemplacementsdisponibles) %>% select(nom,distance,nombreemplacementsdisponibles)

Exercice 5.4 : Se cultiver par hasard

library(rvest)

1. On se connecte à la page wikipedia

wikipedia <- "https://fr.wikipedia.org/"
accueil <- "wiki/Wikipédia:Accueil_principal"
url0 <- paste0(wikipedia,accueil)
data_html <- read_html(url0)

2. On obtient les liens de la page avec

internal_links <- 'a[href*="/wiki/"]:not([href*="//"])'
lien0 <- data_html %>% html_nodes(internal_links) %>% html_attr("href")
head(lien0)

[1] "/wiki/Wikip%C3%A9dia:Accueil_de_la_communaut%C3%A9" "/wiki/Aide:D%C3%A9buter"                           
[3] "/wiki/Portail:Accueil"                              "/wiki/Wikip%C3%A9dia:Principes_fondateurs"         
[5] "/wiki/Aide:Accueil"                                 "/wiki/Aide:Poser_une_question"                     

4. On choisit une page au hasard

set.seed(123)
lien_sel <- lien0 %>% sample(1)
lien_sel

[1] "/wiki/Guerre_civile_syrienne"

que l’on lit puis, sur laquelle on rechoisit une page au hasard

set.seed(1234)
url1 <- paste0(wikipedia,lien_sel)
read_html(url1) %>% html_nodes(internal_links) %>% html_attr("href") %>% sample(1)

[1] "/wiki/Front_islamique_de_lib%C3%A9ration_syrien"

5. On peut écrire une fonction qui sélectionne un lien aléatoirement sur une page donnée :

select_link <- function(url){
  read_html(url) %>%
    html_nodes(internal_links) %>%
    html_attr("href") %>%
    sample(1)
}

On peut ainsi en déduire les pages visitées pendand un nombre de jour donnée :

library(magrittr)
pages_visitees <- function(nb_jours){
  liens_visites <- c()
  for(i in 1:nb_jours){
    wikipedia %>%
      select_link() %T>%
      {liens_visites <<- append(liens_visites, .)} %>%
      str_c(wikipedia, .) %>%
      select_link() %>%
      {liens_visites <<- append(liens_visites, .)}
  }
  return(unique(liens_visites))
}

6. Par exemple en 10 ans on aura visité :

pages_10ans <- pages_visitees(3652)
head(pages_10ans)

[1] "/wiki/%C3%89lection_pr%C3%A9sidentielle_fran%C3%A7aise_de_1981" "/wiki/Syst%C3%A8me_mon%C3%A9taire_europ%C3%A9en"               
[3] "/wiki/Wikip%C3%A9dia:V%C3%A9rifiabilit%C3%A9"                   "/wiki/Wikip%C3%A9dia:R%C3%A8gles_et_recommandations"           
[5] "/wiki/44_av._J.-C."                                             "/wiki/Marcus_Junius_Brutus"                                    

length(pages_10ans)

[1] 2583

7. On peut renouveler le protocole 20 fois (il faudrait plus mais c’est très long !):

set.seed(1234)
nb_visite <- rep(0,20)
for (i in 1:20){
  nb_visite[i] <- pages_visitees(3652) %>% length()
}

On peut regarder le résumé

summary(nb_visite)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   2520    2545    2563    2566    2585    2629 

et visualiser l’histogramme

Exercice 5.5 : Un peu de musique

1. On se connecte à la base de données et on inspecte les différentes bases.

library(DBI)
conn <- dbConnect(RSQLite::SQLite(), dbname = "Chinook_Sqlite.sqlite")
dbListTables(conn)

 [1] "Album"         "Artist"        "Customer"      "Employee"      "Genre"         "Invoice"       "InvoiceLine"   "MediaType"     "Playlist"     
[10] "PlaylistTrack" "Track"        

dbListFields(conn,"Playlist")

[1] "PlaylistId" "Name"      

dbListFields(conn,"PlaylistTrack")

[1] "PlaylistId" "TrackId"   

dbListFields(conn,"Track")

[1] "TrackId"      "Name"         "AlbumId"      "MediaTypeId"  "GenreId"      "Composer"     "Milliseconds" "Bytes"        "UnitPrice"   

dbListFields(conn,"Album")

[1] "AlbumId"  "Title"    "ArtistId"

2. On affecte les tables de la base de données à une liste de tibbles. On pourrait croire que c’est très gourmand en mémoire pour de gros tableaux mais en fait pas du tout. C’est juste une liste d’objets qui permettent de faire une connexion avec la base de données. Donc on peut il aller gaiment !

musique <- list()
for(name in dbListTables(conn)){
  musique[[name]] <- tbl(conn, name)
}
names(musique)

 [1] "Album"         "Artist"        "Customer"      "Employee"      "Genre"         "Invoice"       "InvoiceLine"   "MediaType"     "Playlist"     
[10] "PlaylistTrack" "Track"        

La requête (après avoir regardé un peu la structure des tables) est la suivante

result <- musique$Playlist %>%
  filter(Name == "Classical") %>%
  left_join(musique$PlaylistTrack, by = "PlaylistId") %>%
  left_join(musique$Track, by = "TrackId") %>%
  select(Song = Name.y, AlbumId) %>%
  left_join(musique$Album, by = "AlbumId") %>%
  select(Song, Album = Title)

On regarde les résultats

result %>% collect()

3. On peut regarder la requête SQL

result %>% show_query()

<SQL>
SELECT `Song`, `Title` AS `Album`
FROM (SELECT `LHS`.`Song` AS `Song`, `LHS`.`AlbumId` AS `AlbumId`, `RHS`.`Title` AS `Title`, `RHS`.`ArtistId` AS `ArtistId`
FROM (SELECT `Name.y` AS `Song`, `AlbumId`
FROM (SELECT `LHS`.`PlaylistId` AS `PlaylistId`, `LHS`.`Name` AS `Name.x`, `LHS`.`TrackId` AS `TrackId`, `RHS`.`Name` AS `Name.y`, `RHS`.`AlbumId` AS `AlbumId`, `RHS`.`MediaTypeId` AS `MediaTypeId`, `RHS`.`GenreId` AS `GenreId`, `RHS`.`Composer` AS `Composer`, `RHS`.`Milliseconds` AS `Milliseconds`, `RHS`.`Bytes` AS `Bytes`, `RHS`.`UnitPrice` AS `UnitPrice`
FROM (SELECT `LHS`.`PlaylistId` AS `PlaylistId`, `LHS`.`Name` AS `Name`, `RHS`.`TrackId` AS `TrackId`
FROM (SELECT *
FROM `Playlist`
WHERE (`Name` = 'Classical')) AS `LHS`
LEFT JOIN `PlaylistTrack` AS `RHS`
ON (`LHS`.`PlaylistId` = `RHS`.`PlaylistId`)
) AS `LHS`
LEFT JOIN `Track` AS `RHS`
ON (`LHS`.`TrackId` = `RHS`.`TrackId`)
)) AS `LHS`
LEFT JOIN `Album` AS `RHS`
ON (`LHS`.`AlbumId` = `RHS`.`AlbumId`)
)

Et on n’oublie pas de se déconnecter !

dbDisconnect(conn)

Exercice 5.6 : Du trampoline sur Wikipedia

1. On récupère tout d’abord le tableau

url <- "https://fr.wikipedia.org/wiki/Liste_des_médaillés_olympiques_au_trampoline"
tramp <- read_html(url)
tab <- tramp %>% html_table()
tramp.f <- tab[[2]]

2. On créé le dataframe

tramp.f1 <- tramp.f %>% gather(key="med",value="ath_p",Or,Argent,Bronze) %>%
  separate(ath_p,into=c("nom","pays"),sep="\\(") %>% mutate(pays=str_remove(pays,"\\)"))
tramp.f1

3.On le classe en fonction des médailles

tramp.f1 %>% group_by(pays,med) %>% summarize(nomb=n()) %>% spread(med,nomb) %>% select(c(1,4,2,3)) %>%
  arrange(desc(Or,Argent,Bronze))

4. On fait la même chose pour les hommes

tramp.h <- tab[[1]]
tramp.h1 <- tramp.h %>% gather(key="med",value="ath_p",Or,Argent,Bronze) %>%
  separate(ath_p,into=c("nom","pays"),sep="\\(") %>% mutate(pays=str_remove(pays,"\\)"))
tramp.h1 %>% group_by(pays,med) %>% summarize(nomb=n()) %>% spread(med,nomb) %>% select(c(1,4,2,3)) %>%
  arrange(desc(Or,Argent,Bronze))

et enfin pour le tableau mixte

tramp.fh <- bind_rows(tab[[1]],tab[[2]])
tramp.fh1 <- tramp.fh %>% gather(key="med",value="ath_p",Or,Argent,Bronze) %>%
  separate(ath_p,into=c("nom","pays"),sep="\\(") %>% mutate(pays=str_remove(pays,"\\)"))
tramp.fh1 %>% group_by(pays,med) %>% summarize(nomb=n()) %>% spread(med,nomb) %>% select(c(1,4,2,3)) %>%
  arrange(desc(Or,Argent,Bronze))

Exercice 5.7 : Débouchés dans l’enseignement supérieur français

df <- jsonlite::fromJSON("fr-esr-insertion_professionnelle-master.json")$fields

df1 <- df %>% select(etablissement,salaire_net_median_des_emplois_a_temps_plein,salaire_net_mensuel_median_regional) %>%
  mutate(salaire_net_median_des_emplois_a_temps_plein=as.numeric(salaire_net_median_des_emplois_a_temps_plein),
         salaire_net_mensuel_median_regional=as.numeric(salaire_net_mensuel_median_regional))

NAs introduced by coercionNAs introduced by coercion

df2 <- df1 %>% group_by(etablissement) %>% summarize(sal.temps.plein=mean(salaire_net_median_des_emplois_a_temps_plein,na.rm=TRUE),
                                              sal.reg=mean(salaire_net_mensuel_median_regional,na.rm=TRUE))
df2

2. On classe selon le ratio demandé.

df2 %>% mutate(ratio=sal.temps.plein/sal.reg) %>% arrange(desc(ratio))