« Dans toute statistique, l’inexactitude du nombre est compensée par la précision des décimales »

Le statisticien et économiste Alfred Sauvy est resté dans les mémoires pour avoir inventé en 1952 le terme “tiers-monde”. Mais on lui a aussi attribué la paternité de la phrase suivante « dans toute statistique, l’inexactitude du nombre est compensée par la précision des décimales ». J’ai du l’entendre alors que j’étais étudiant, et depuis, elle me suit partout.

J’y repensais l’autre jour, quand Mathieu Gallard mentionnait sur Twitter le graphique suivant (correspondant a la popularité du président de la république, en France, dans les 18 mois qui suivent l’élection).

Le tweet disait (entre autres) “ est à ce stade de son quinquennat légèrement moins populaire que “. Pour rappel, ces courbes “de popularité” sont construites par un sondage, avec a chaque fois environ 1000 personnes interrogées (“sur la taille de l’échantillon on est toujours entre 950 et 970 interviews” me disait Mathieu). Bon, tous ceux qui ont des souvenirs de cours de stats se souviennent qu’avec 1000 personnes interrogées, 2 points de différence, c’est rarement significatif. Mais plus globalement, compte tenu de la marge d’erreur, je me suis demande pourquoi les courbes n’étaient pas lissées ? Ça éviterait les discussions stériles pour une variation de 2 points par exemple..

Si on reprend les données brutes (merci Mathieu), on a ici

rate=read.csv2("http://freakonometrics.free.fr/satisfaction.csv")
plot(rate[,2],type="b",ylim=c(.2,.75),xlim=c(0,20),pch=19)
lines(rate[,3],type="b",col="red")
lines(rate[,4],type="b",col="blue")
lines(rate[,5],type="b",col="dark green")
text(18.15,rate[17,2],"EM")
text(18.15,rate[17,3],"FH",col="red")
text(18.15,rate[17,4],"NS",col="blue")
text(18.15,rate[17,5],"JC",col="dark green")

ce qui donne le même que dans le tweet (même si je n’ose pas interpoler linéairement les valeurs manquantes – il y en a deux dans mon fichier)

Prenons la courbe la plus récente, celle d’Emmanuel Macron (avec en plus les valeurs manquantes pour pimenter un peu) et rajoutons les intervalles de confiance ponctuels.

plot(rate$EM,type="b",ylim=c(.2,.5))
p=rate$EM
n=length(p)
arrows(1:n,p-2/sqrt(1000)*sqrt(p*(1-p)),1:n,p+2/sqrt(1000)*sqrt(p*(1-p)),code=3,angle=90,length=.1,col="blue")

Personnellement, j’aurais bien voulu (1) lisser tout ça, (2) rajouter quelque chose qui s’apparente a des bandes de confiance. Mais avec des erreurs de mesure (c’est comme ça qu’on peut interpréter le fait que les points viennent d’un sondage), je ne sais pas trop quoi faire. J’ai tenté la méthode suivante : le tire au hasard des points dans l’intervalle de confiance, puis je lisse sur ce nouveau jeu de points. Et je répète mille fois

library(mgcv)
Y=matrix(NA,73,1000)
for(s in 1:1000){
  x=(1:n)[!is.na(p)]
  pna=p[!is.na(p)]
  ps=rnorm(length(x),pna,1/sqrt(1000)*sqrt(pna*(1-pna)))
  b=data.frame(x=x,y=ps)
  reg=gam(y~s(x),data=b)
  yp=predict(reg,newdata=data.frame(x=seq(0,18,by=.25)))
  Y[,s]=yp
  if(s<100) lines(seq(0,18,by=.25),yp,col="light blue")
} 
lines(seq(0,18,by=.25),apply(Y,1,mean),col="red",lwd=2)
lines(seq(0,18,by=.25),apply(Y,1,function(x) quantile(x,.95)),col="red",lty=2)
lines(seq(0,18,by=.25),apply(Y,1,function(x) quantile(x,.05)),col="red",lty=2)

On voit que notre courbe lissée est réaliste, voire même les pseudo-bandes de confiance autour. Pour obtenir ces trois courbes, on peut utiliser la fonction suivante

courbe=function(j=1){
p=rate[,1+j]
n=length(p)
Y=matrix(NA,73,1000)
for(s in 1:1000){
  x=(1:n)[!is.na(p)]
  pna=p[!is.na(p)]
  ps=rnorm(length(x),pna,1/sqrt(1000)*sqrt(pna*(1-pna)))
  b=data.frame(x=x,y=ps)
  reg=gam(y~s(x),data=b)
  yp=predict(reg,newdata=data.frame(x=seq(0,18,by=.25)))
  Y[,s]=yp
} 
data.frame(
x=seq(0,18,by=.25),
pred=apply(Y,1,mean),
upr=apply(Y,1,function(x) quantile(x,.975)),
lwr=apply(Y,1,function(x) quantile(x,.025)))
}

Sur les quatre colonnes de notre tableau, ça donne

plot(rate[,2],type="b",ylim=c(0,.8),xlim=c(0,20),col="white")
Y=courbe(4)
polygon(c(Y$x,rev(Y$x)),c(Y$upr,rev(Y$lwr)),col=rgb(0,1,0,.4),border=NA)
lines(Y$x,Y$pred,col="dark green",lwd=2)
text(18.65,Y$pred[73],"JC",col="dark green")
Y=courbe(3)
polygon(c(Y$x,rev(Y$x)),c(Y$upr,rev(Y$lwr)),col=rgb(0,0,1,.4),border=NA)
lines(Y$x,Y$pred,col="blue",lwd=2)
text(18.65,Y$pred[73],"NS",col="blue")
Y=courbe(2)
polygon(c(Y$x,rev(Y$x)),c(Y$upr,rev(Y$lwr)),col=rgb(1,0,0,.4),border=NA)
lines(Y$x,Y$pred,col="red",lwd=2)
text(18.65,Y$pred[73],"FH",col="red")
Y=courbe(1)
polygon(c(Y$x,rev(Y$x)),c(Y$upr,rev(Y$lwr)),col="grey",border=NA)
lines(Y$x,Y$pred,col="black",lwd=2)
text(18.65,Y$pred[73],"EM",col="black")

Pourquoi les instituts de sondages, qui produisent les courbes de popularité, ne montrent pas ce genre de courbes ? Elles sont – a mon avis – aussi justes que celles qu’ils fournissent, au centième près, jouant sur une précision que l’incertitude ne devrait pas autoriser…

Régression sur une variable qualitative et ANOVA

Ce matin, pour le cours STT5100, on évoquait la régression sur une variable catégorielle. En particulier, on avait commencé par regarder ce que donnerait la régression sans la constante, et son interprétation. On s’était appuyé sur la base des poids et des tailles des élèves, et de la variable de genre.

Davis=read.table(
  "http://socserv.socsci.mcmaster.ca/jfox/Books/Applied-Regression-2E/datasets/Davis.txt")
Davis[12,c(2,3)]=Davis[12,c(3,2)]
Davis=data.frame(Y=Davis$weight * 2.204622,
                 X1=Davis$sex)

On voulait estimer le modèle y_i =\beta_F\boldsymbol{1}_F(x_i)+\beta_H\boldsymbol{1}_H(x_i)+\varepsilon_iOn avait vu que l’on pouvait passer par l’écriture matricielle

 X=cbind(Davis$X1=='F',Davis$X1=='M') 
 Y=Davis$Y

car la matrice \mathbf{X}^T\mathbf{X} est inversible (une fois que l’on enlève la constante)

 solve(t(X)%*%X)
            [,1]       [,2]
[1,] 0.008928571 0.00000000
[2,] 0.000000000 0.01136364

et donc l’estimateur par moindres carrés est (classiquement)\widehat{\mathbf{\beta}} = (\mathbf{X}^T\mathbf{X})^{-1}\mathbf{X}^T\mathbf{y}

 solve(t(X)%*%X) %*% (t(X)%*%Y)
         [,1]
[1,] 125.4272
[2,] 167.3258

ce qui correspond effectivement à la sortie de R,

 reg=lm(Y~0+X1,data=Davis)
 summary(reg)
 
Coefficients:
    Estimate Std. Error t value Pr(>|t|)    
X1F  125.427      1.960   64.00   <2e-16 ***
X1M  167.326      2.211   75.68   <2e-16 ***

Considérons maintenant les deux sous-populations, avec le poids des femmes, et le poids des hommes

x=Y[X[,1]==1]
y=Y[X[,2]==1]
nx=length(x)
ny=length(y)

On avait vu en cours que les \widehat{\mathbf{\beta}} avaient une interprétation très simple, puisque\widehat{{\beta}}_M = \frac{1}{n_M}\sum_{i:x_i=M} y_iautrement dit \widehat{{\beta}}_M   est le poids moyen des hommes. Et en effet

 mean(y)
[1] 167.3258

C’est finalement très naturel, ou intuitif.

On peut maintenant s’interroger sur l’écart-type de l’estimateur de \widehat{{\beta}}_M . Intuitivement, on aurait envie d’avoir la variance de l’estimateur de la moyenne, soit ici

 sqrt(var(y)/ny)
[1] 2.794391
 sqrt(1/(ny-1)*sum( (y-mean(y))^2 )/ny)
[1] 2.794391

car pour rappel\text{Var}[\overline{y}]=\frac{\text{Var}(y)}{n}Comme on l’a vue dans le modèle de régression multiple, la variance de l’estimateur de \mathbf{\beta} est proportionnel à \sigma^2 , la variance globale des résidus (c’est l’hypothèse d’homoscédasticité ! les deux groupes doivent avoir la même variance). On va donc calculer l’estimateur naturel de \sigma^2

 s2=1/(nx+ny-2)*(sum( (x-mean(x))^2 )+sum( (y-mean(y))^2))
 sqrt(s2/ny)
[1] 2.210863

et en effet, on retombe sur la valeur donnée dans le tableau de régresion

 sqrt(s2/nx)
[1] 1.959721

(pareil pour l’autre coefficient).

On avait ensuite regardé la régression telle qu’elle faite classiquement, sous R : on garde la constante, et on enlève une des variables indicatrices (qui devient alors la “modalité de référence”).

 X=cbind(1,Davis$X1=='M')

Là encore, le modèle devient identifiable, et on obtient ici

 solve(t(X)%*%X) %*% (t(X)%*%Y)
          [,1]
[1,] 125.42724
[2,]  41.89855

On avait noté qu’il y avait un interprétation de cette seconde valeur, comme un différentiel par rapport à la modalité de référence

mean(y)-mean(x)
[1] 41.89855

La sortie de régression devient ici

 reg2=lm(Y~X1,data=Davis)
 summary(reg2)
 
Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept)  125.427      1.960   64.00   <2e-16 ***
X1M           41.899      2.954   14.18   <2e-16 ***

Et comme je l’avais dit, le test de Student correspond ici à un test d’égalité entre la taille moyenne des hommes et celle des femmes. Et en effet, si on fait le test, on voit que la différence est significative, comme attendu (pour la même raison qu’au dessus, on suppose la même variance dans les deux groupes)

 t.test(Y[X[,1]==1],Y[X[,2]==1],var.equal=TRUE)
 
	Two Sample t-test
 
data:  Y[X[, 1] == 1] and Y[X[, 2] == 1]
t = -6.4475, df = 286, p-value = 4.826e-10
alternative hypothesis: true difference in means is not equal to 0
95 percent confidence interval:
 -30.62603 -16.30035
sample estimates:
mean of x mean of y 
 143.8626  167.3258

Je suis par contre un peu surpris que les p-values soient différente. Mon interprétation est que les p-values sont (de toutes façons) très faibles, et donc ça a peu d’importance. En fait, si on rend les deux variables indépendantes (par exemple en mélangeant la variable \mathbf{y} ), ça marche ! Posons

 Davis$Y=sample(Davis$Y)

ce qui revient à permuter toutes les observations de la variable dépendante (mais pas les autres !). La régression donne ici

 reg2=lm(Y~X1,data=Davis)
 summary(reg2)
 
Call:
lm(formula = Y ~ X1, data = Davis)
 
Residuals:
    Min      1Q  Median      3Q     Max 
-57.458 -22.184  -5.512  17.809 118.912 
 
Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept) 143.4382     2.7820   51.56   <2e-16 ***
X1M           0.9645     4.1940    0.23    0.818    
---
Signif. codes:  0***0.001**0.01*0.05 ‘.’ 0.1 ‘ ’ 1
 
Residual standard error: 29.44 on 198 degrees of freedom
Multiple R-squared:  0.000267,	Adjusted R-squared:  -0.004782 
F-statistic: 0.05289 on 1 and 198 DF,  p-value: 0.8183

autrement dit, le genre n’est plus significatif, avec une p-value de 81.8%. Ce qui est bien au dessus de 5%. Si on fait maintenant le test de comparaison de moyenne, sur les deux sous-groupes, on obtient

 Y=Davis$Y
 t.test(Y[X[,1]==1],Y[X[,2]==1],var.equal=TRUE)
 
	Two Sample t-test
 
data:  Y[X[, 1] == 1] and Y[X[, 2] == 1]
t = -0.22998, df = 198, p-value = 0.8183
alternative hypothesis: true difference in means is not equal to 0
95 percent confidence interval:
 -9.235209  7.306165
sample estimates:
mean of x mean of y 
 143.4382  144.4027

et le test a ici également une p-value de 81.8%. Les deux tests sont donc rigoureusement équivalents.

Les transports publics parisiens

Histoire de continuer la série de billets sur la visualisation, et la manipulation de données ouvertes, je vais reprendre de codes de Tony, de la formation Data Science pour l’Actuariat, pour visualiser le transport dans Paris (et la région parisienne). Si j’ai le temps, dans les jours a venir, je ferais une analyse du réseau de métro, compare aux autres grandes villes européennes. Pour commencer, on va récupérer les données, fournies par le site d’open data du stif, le syndicat des transports d’Ile de France (https://opendata.stif.info). Les données sont découpées par semestre, ce qui rend le code un peu lourd… mais bon, ça n’est pas plus complique pour autant.

library(dplyr)
library(stringr)
library(ggplot2)
library(xlsx)
library(ggmap)

On commence par lire tous les fichiers en ligne

nbvalid = list()
download.file("https://opendata.stif.info/explore/dataset/emplacement-des-gares-idf-data-generalisee/download/?format=csv&timezone=Europe/Berlin&use_labels_for_header=true","Gares.csv")
gares = read.csv("Gares.csv", sep=";", header = TRUE)
distr_pers = list()
download.file("https://opendata.stif.info/explore/dataset/validations-sur-le-reseau-ferre-profils-horaires-par-jour-type-1er-sem/download/?format=csv&timezone=Europe/Berlin&use_labels_for_header=true","horaires1.csv")
distr_pers$S1 = read.csv("horaires1.csv", sep=";", header = TRUE)
download.file("https://opendata.stif.info/explore/dataset/validations-sur-le-reseau-ferre-profils-horaires-par-jour-type-2e-sem/download/?format=csv&timezone=Europe/Berlin&use_labels_for_header=true","horaires2.csv")
distr_pers$S2 = read.csv("horaires2.csv", sep=";", header = TRUE)
download.file("https://opendata.stif.info/explore/dataset/validations-sur-le-reseau-ferre-nombre-de-validations-par-jour-1er-sem/download/?format=csv&timezone=Europe/Berlin&use_labels_for_header=true","validations1.csv")
nbvalid$S1 = read.csv("validations1.csv", sep=";", header = TRUE)
download.file("https://opendata.stif.info/explore/dataset/validations-sur-le-reseau-ferre-nombre-de-validations-par-jour-2e-sem/download/?format=csv&timezone=Europe/Berlin&use_labels_for_header=true","validations2.csv")
nbvalid$S2 = read.csv("validations2.csv", sep=";", header = TRUE)
download.file("https://freakonometrics.free.fr/Correspondance_NOM.csv","Correspondance_NOM.csv")
Cooresp = read.csv("Correspondance_NOM.csv", sep=";", header = TRUE)

On a ensuite besoin de définir les dates des vacances, pour 2017

Vacances = list()
Vacances$Noel = append(seq(from = as.Date("01/01/2017", format="%d/%m/%Y"), to=as.Date("02/01/2017", format="%d/%m/%Y"), by=1),seq(from = as.Date("24/12/2017", format="%d/%m/%Y"), to=as.Date("31/12/2017", format="%d/%m/%Y"), by=1))
Vacances$Ski = seq(from = as.Date("04/02/2017", format="%d/%m/%Y"), to=as.Date("19/02/2017", format="%d/%m/%Y"), by=1)
Vacances$Printemps = seq(from = as.Date("02/04/2017", format="%d/%m/%Y"), to=as.Date("17/04/2017", format="%d/%m/%Y"), by=1)
Vacances$Ete = seq(from = as.Date("08/07/2017", format="%d/%m/%Y"), to=as.Date("03/09/2017", format="%d/%m/%Y"), by=1)
Vacances$Toussaint = seq(from = as.Date("21/10/2017", format="%d/%m/%Y"), to=as.Date("05/11/2017", format="%d/%m/%Y"), by=1)
Vacances$All=Reduce(append,Vacances)

Après, un peu de nettoyage est nécessaire, avec des gares en double (par exemple quand passe a la fois le RER et le métro), et pour recuperer leur localisation spatiale (latitude et longitude)

gares$NOM_LONG = as.character(gares$NOM_LONG)
DD = (gares$NOM_LONG[duplicated(gares$NOM_LONG)])
i = (gares$NOM_LONG %in% DD) & gares$MODE_=="Metro"
gares$NOM_LONG[i] = paste(gares$NOM_LONG[i],"M", sep="-")
i = (gares$NOM_LONG %in% DD) & gares$MODE_=="RER"
gares$NOM_LONG[i] = paste(gares$NOM_LONG[i],"R", sep="-")
gares$NOM_LONG=factor(gares$NOM_LONG)
 
a=as.character(gares$Geo.Point)
gares$Y=as.numeric(str_extract_all(a,"^[0-9]+.[0-9]+"))
gares$X=as.numeric(str_extract_all(a,"[0-9]+.[0-9]+$"))

On compte ensuite les nombres de validation de tickets, par gare

Manip_nbvalid = function(Data,DD,gares) {
  i=grep("^[a-zA-Z]+",as.character(Data$NB_VALD))
  Data$NB_VALD[i]=as.integer(5)
  i=is.na(Data$NB_VALD)
  Data$NB_VALD[i]=as.integer(5)
  Data$LIBELLE_ARRET=as.character(Data$LIBELLE_ARRET)
  i=(Data$LIBELLE_ARRET %in% DD) & Data$CODE_STIF_TRNS=="100"
  Data$LIBELLE_ARRET[i]=paste(Data$LIBELLE_ARRET[i],"M", sep="-")
  i=(Data$LIBELLE_ARRET %in% DD) & Data$CODE_STIF_TRNS=="800"
  Data$LIBELLE_ARRET[i]=paste(Data$LIBELLE_ARRET[i],"R", sep="-")
 
  for (i in seq(1,nrow(Cooresp))) { Data$LIBELLE_ARRET=gsub(as.character(Cooresp$nbval[i]),as.character(Cooresp$gares[i]),Data$LIBELLE_ARRET)
  }
gares$NOM_LONG=as.character(gares$NOM_LONG)
Data=dplyr::left_join(Data,gares[,c("NOM_LONG","X","Y")],by=c("LIBELLE_ARRET"="NOM_LONG"))
  Data=Data[is.na(Data$CODE_STIF_ARRET)==FALSE,]
  Data=Data[Data$CODE_STIF_ARRET!="ND",]
  Data$NB_VALD=as.integer(as.character(Data$NB_VALD))
  Data$JOUR=as.Date(Data$JOUR)
  Data$CODE_STIF_TRNS=factor(Data$CODE_STIF_TRNS)
  Data$CODE_STIF_RES=factor(Data$CODE_STIF_RES)
  Data$CODE_STIF_ARRET=factor(Data$CODE_STIF_ARRET)
  Data$LIBELLE_ARRET=factor(Data$LIBELLE_ARRET)
  Data$ID_REFA_LDA=factor(Data$ID_REFA_LDA)
  Data$CATEGORIE_TITRE=factor(Data$CATEGORIE_TITRE)
  Data$JOURSEM=weekdays(Data$JOUR)  
  return(Data)
}
nbvalid=lapply(nbvalid, Manip_nbvalid,DD=DD,gares=gares)

On a ainsi tous les comptages, pour toutes les gares. On fait ensuite un découpage par tranche horaire

Manip_dist_pers = function(DataFrame) {
  DataFrame=DataFrame[(DataFrame$TRNC_HORR_60)!="ND",]
  DataFrame$TRNC_HORR_60=factor(DataFrame$TRNC_HORR_60, levels = c("0H-1H", "1H-2H", "2H-3H", "3H-4H", "4H-5H", "5H-6H", "6H-7H", "7H-8H", "8H-9H", "9H-10H", "10H-11H", "11H-12H", "12H-13H", "13H-14H", "14H-15H", "15H-16H", "16H-17H", "17H-18H", "18H-19H", "19H-20H", "20H-21H", "21H-22H", "22H-23H", "23H-0H")) 
  DataFrame=DataFrame[(DataFrame$CODE_STIF_ARRET)!="ND",]
  DataFrame$CODE_STIF_ARRET=factor(DataFrame$CODE_STIF_ARRET)
DataFrame$TRANCHE=str_extract(as.character(DataFrame$TRNC_HORR_60),"^[0-9]{1,2}")
  return(DataFrame)
}
distr_pers=lapply(distr_pers, Manip_dist_pers)

On peut ensuite recuperer la distribution des validation, par jour

distr_JOURV=list()
distr_JOURV$S1 = nbvalid$S1 %>% group_by(JOUR, JOURSEM,CATEGORIE_TITRE) %>% summarise(NB_VALD=sum(NB_VALD))
distr_JOURV$S2 = nbvalid$S2 %>% group_by(JOUR, JOURSEM,CATEGORIE_TITRE) %>% summarise(NB_VALD=sum(NB_VALD))
distr_JOURV$Y=rbind(distr_JOURV$S1,distr_JOURV$S2)
distr_JOUR=list()
distr_JOUR$S1 = nbvalid$S1 %>% group_by(JOUR, JOURSEM) %>% summarise(NB_VALD=sum(NB_VALD))
distr_JOUR$S2 = nbvalid$S2 %>% group_by(JOUR, JOURSEM) %>% summarise(NB_VALD=sum(NB_VALD))
distr_JOUR$Y=rbind(distr_JOUR$S1,distr_JOUR$S2)
distr_JOUR_Station=list()
distr_JOUR_Station$S1 = nbvalid$S1 %>% group_by(JOUR, JOURSEM,CODE_STIF_ARRET,LIBELLE_ARRET) %>% summarise(NB_VALD=sum(NB_VALD), X=max(X), Y=max(Y))
distr_JOUR_Station$S2 = nbvalid$S2 %>% group_by(JOUR, JOURSEM,CODE_STIF_ARRET,LIBELLE_ARRET) %>% summarise(NB_VALD=sum(NB_VALD), X=max(X), Y=max(Y))
Manip_dist_Jour = function(DataFrame) {
  DataFrame$JOURSEM=factor(DataFrame$JOURSEM,levels = c("lundi","mardi","mercredi","jeudi","vendredi","samedi","dimanche"))
  DataFrame$TypeJ=character(nrow(DataFrame))
  DataFrame$TypeJ[DataFrame$JOUR %in% Vacances$Ete]="Ete"
  DataFrame$TypeJ[DataFrame$JOUR %in% Vacances$Noel]="Noel"
  DataFrame$TypeJ[DataFrame$JOUR %in% Vacances$Ski]="Ski"
  DataFrame$TypeJ[DataFrame$JOUR %in% Vacances$Printemps]="Printemps"
  DataFrame$TypeJ[DataFrame$JOUR %in% Vacances$Toussaint]="Toussaint"
  DataFrame$TypeJ[DataFrame$JOUR %in% Vacances$All == FALSE]="HorsVacances"
  DataFrame$CAT_JOUR=character(nrow(DataFrame))
  DFr=list()
  ii=(DataFrame$JOURSEM!="samedi" & DataFrame$JOURSEM!="dimanche") & DataFrame$TypeJ!="HorsVacances"
  DataFrame$CAT_JOUR[ii]="JOVS"
  DFr$JOVS$Data = DataFrame[ii,]
  DFr$JOVS$Nom="Jours ouvrés Vacances Scolaires"
  ii=(DataFrame$JOURSEM!="samedi" & DataFrame$JOURSEM!="dimanche") & DataFrame$TypeJ=="HorsVacances"
  DataFrame$CAT_JOUR[ii]="JOHV"
  DFr$JOHV$Data = DataFrame[ii,]
  DFr$JOHV$Nom="Jours ouvés Hors Vacances Scolaires"
  ii=DataFrame$JOURSEM=="samedi" & DataFrame$TypeJ!="HorsVacances"
  DataFrame$CAT_JOUR[ii]="SAVS"
  DFr$SAVS$Data = DataFrame[ii,]
  DFr$SAVS$Nom="Samedi VS"
  ii=DataFrame$JOURSEM=="samedi" & DataFrame$TypeJ=="HorsVacances"
  DataFrame$CAT_JOUR[ii]="SAHV"
  DFr$SAHV$Data = DataFrame[ii,]
  DFr$SAHV$Nom="Samedi HV"
  ii=DataFrame$JOURSEM=="dimanche"
  DataFrame$CAT_JOUR[ii]="DIJFP"
  DFr$DIJFP$Data = DataFrame[ii,]
  DFr$DIJFP$Nom="Dimanche"
  return(list("TypeJ"=DFr,"Distr"=DataFrame))
}
res=Manip_dist_Jour(distr_JOUR$Y)
distr_TypeJ=res$TypeJ
distr_JOUR$Y=res$Distr
res=Manip_dist_Jour(distr_JOURV$Y)
distr_TypeJV=res$TypeJ
distr_TypeJ_Station=list()
res=Manip_dist_Jour(distr_JOUR_Station$S1)
distr_TypeJ_Station$S1=res$TypeJ
distr_JOUR_Station$S1=res$Distr
res=Manip_dist_Jour(distr_JOUR_Station$S2)
distr_TypeJ_Station$S2=res$TypeJ
distr_JOUR_Station$S2=res$Distr
rm(res)

On peut alors tracer toutes sortes de graphiques, par exemple le nombre de validations, par jour, entre le 1er janvier et le 31 décembre, en fonction du jour de la semaine.

g0 = ggplot(distr_JOUR$Y, aes(x=JOUR, y=NB_VALD, color = JOURSEM)) + geom_point()
g0 = g0 + labs(title="Nombres de validations chaque jours de 2017", x="Date", y="Nombre de validations")
g0

On peut voir la très forte baisse les jours de semaine pendant les vacances d’été. Au lieu de regarder sur l’année, on peut regarder sur la journée

Fct_FqH = function(DataFrame,distr_pers) {
DataFrame=dplyr::full_join(DataFrame,distr_pers[,c("CAT_JOUR","CODE_STIF_ARRET","pourc_validations","TRANCHE","TRNC_HORR_60")],by=c("CODE_STIF_ARRET"="CODE_STIF_ARRET","CAT_JOUR"="CAT_JOUR"))
  DataFrame$NB_VALD=DataFrame$NB_VALD*DataFrame$pourc_validations
  return(DataFrame)
}
distr_JOUR_Station$S1=Fct_FqH(distr_JOUR_Station$S1, distr_pers$S1)
distr_JOUR_Station$S2=Fct_FqH(distr_JOUR_Station$S2, distr_pers$S2)
distr_JOUR_Station$Y=rbind(distr_JOUR_Station$S1,distr_JOUR_Station$S2)
distr_JOUR_Station$Y=distr_JOUR_Station$Y[is.na(distr_JOUR_Station$Y$NB_VALD)==FALSE,]

On peut alors faire un graphique, en fonction de la tranche horaire, pour certaines périodes, par exemple en dehors de vacances scolaires, en semaine (par heure, on a ici un boxplot)

Graphique_HOR = function(DataFrame,TypeJ,NomJ) {
  # Graphique de la distribution de l'affluence par tranche horaire et type de jours
  g1 = ggplot(DataFrame[DataFrame$CAT_JOUR==TypeJ,], aes(x=TRNC_HORR_60, y=pourc_validations, color = TRNC_HORR_60,las=2)) + geom_boxplot() + ylim(c(0,100))
  g1 = g1 + labs(title=paste(c("Distribution des validations par tranche horaire ",NomJ), sep="", collapse = ""), x="Jours", y="Nombre de validations") +
  theme(axis.text.x= element_text(size = 8, angle = 45))
  g1
}
Graphique_HOR(distr_JOUR_Station$Y,"JOHV","Jours ouvrés Hors Vacances Scolaires")

ou bien le samedi

Graphique_HOR(distr_JOUR_Station$Y,"SAHV","Samedi Hors Vacances Scolaires")

On peut tenter un peu de cartographie. Comme nombre de métros/bus, dans le monde, on a souvent uniquement accès aux nœuds d’entrée dans le réseau (et pas aux nœuds de sortie). Mais ça reste intéressant, et très informatif

get_Paris1 = get_map(c(2.3448688,48.8613029), zoom = 11)
Paris1 = ggmap(get_Paris1)

Par gare, et par heure, on peut regarder le nombre de validations de tickets

Median_Valid = distr_JOUR_Station$Y %>% group_by(CAT_JOUR, LIBELLE_ARRET, X, Y) %>% summarise(NB_VALD=median(NB_VALD))
Median_Valid_Station = distr_JOUR_Station$Y %>% group_by(CAT_JOUR, TRNC_HORR_60,LIBELLE_ARRET, X, Y) %>% summarise(NB_VALD=median(NB_VALD))
 
Carte_Densite = function(Nom,Carte,TypeJ,HOR,DataFrame) {
if (HOR=="") {
    ii=DataFrame$CAT_JOUR==TypeJ
    NomSave=paste("Densité des validations",Nom,TypeJ)
  }
  else {
    ii=DataFrame$CAT_JOUR==TypeJ & DataFrame$TRNC_HORR_60==HOR
    NomSave=paste("Densité des validations",Nom,TypeJ,HOR)
  }
  U=DataFrame[ii,]
  n=round(log10(median(U$NB_VALD)))-1
  n=max(1,10^n)
  Nb_Repete_Stations=ceiling(U$NB_VALD/n)
  U$Size_Stations=U$NB_VALD/max(U$NB_VALD)
  Z=U[rep(1:nrow(U),Nb_Repete_Stations),]
  Carte_A= Carte + geom_point(aes(x=X,y=Y),data=Z,col="coral", size=10*Z$Size_Stations) +
    geom_density2d(data = Z, aes(x=X,y=Y), size = 0.5) + 
    stat_density2d(data = Z, aes(x=X,y=Y,fill = ..level.., alpha = ..level..),size = 0.01, bins = 16, geom = "polygon") +
    scale_fill_gradient(low = "chartreuse", high = "red",guide = FALSE) + 
    scale_alpha(range = c(0, 0.3), guide = FALSE) + ggtitle(NomSave) +
    theme(axis.title.x = element_blank(), axis.title.y = element_blank(), axis.text.x= element_blank(), axis.text.y = element_blank())
 
  suppressWarnings(print(Carte_A))
}

Par exemple, si on regarde les points de validations de tickets entre 5 et 6 heures du matin, on obtient

L=levels(Median_Valid_Station$TRNC_HORR_60)
Carte_Densite("dans la petite ceinture",Paris1,"JOHV",L[6],Median_Valid_Station)

avec beaucoup de ville dans la banlieue proche. Plus tard en journée, entre 11 heures et midi, les gares de validation sont davantage dans le cœur de Paris, avec la Défense a gauche et Saint-Denis au nord

Carte_Densite("dans la petite ceinture",Paris1,"JOHV",L[12],Median_Valid_Station)

En fin de journée, c’est Paris et surtout la Défense qui ressortent

Carte_Densite("dans la petite ceinture",Paris1,"JOHV",L[19],Median_Valid_Station)

Amusant, non ?

Modélisation “appliquée”

Depuis la rentrée, je donne un cours de modélisation appliquée, ou pour être plus précis, intitulé “modèles linéaires appliqués“. Ça a été l’occasion de me rendre compte que le mot “appliqué” pouvait prêter à confusion. Dans ma tête, on allait appliquer une théorie (la théorie des modèles linéaires) à cas concrets. Généralement, je présente les grandes lignes de la théorie : les hypothèses, les principaux résultats, et je fais des démonstrations “avec les mains” pour expliquer de manière intuitive certains passages (genre la perte des degrés de liberté dans le test de Student, le signe de la covariance des estimateurs dans le modèle simple, etc) en renvoyant à des livres de référence pour les preuves complètes. Et j’essaye, autant que faire se peut, d’illustrer sur des données, avec du code R (par exemple vendredi dernier, c’était sur la notion de “modalité de référence” quand on régresse sur une variable catégorielle, montrant que tous les modèles sont équivalent et que ce n’est vraiment qu’une histoire de conventions). J’ai aussi donné un gros devoir, avec des vraies données, 2400 observations, 34 variables (quantitatives mais aussi qualitatives). Bref, un vrai cas d’étude. Et j’ai même proposé de revenir sur leurs modélisations en fin de cours…

Et j’ai été surpris quand un groupe d’élèves est venu me voir à la pause, pour me demander s’il y aurait des “chiffres” : si au lieu d’écrire {\displaystyle {\hat {\beta }}_{1}={\frac {\sum x_{i}\sum y_{i}-n\sum x_{i}y_{i}}{\left(\sum x_{i}\right)^{2}-n\sum x_{i}^{2}}}={\frac {\sum (x_{i}-{\bar {x}})(y_{i}-{\bar {y}})}{\sum (x_{i}-{\bar {x}})^{2}}}}ou encore {\displaystyle {\hat {\beta }}_{0}={\frac {\sum y_{i}-{\hat {\beta }}_{1}\sum x_{i}}{n}}={\bar {y}}-{\hat {\beta }}_{1}{\bar {x}}}il y aurait des calculs, à la calculatrice, avec des chiffres au lieu des x et des y. J’ai été très supris, parce qu’on est en 2018, que tout le monde parle de “big data” et revenir à la calculatrice pour calculer des sommes de 10 nombres, c’est possible. En tous cas, certains profs le font encore. J’ai dit que si ça pouvait les rassurer, je pouvais chercher des bases dans des vieux livres, mais que c’était pas ma manière de comprendre le terme “appliqué” dans le nom du cours. Je me suis souvenu du livre de Robert Pindyck et Daniel Rubinfeld, Econometric Models and Economic Forecasts, qui était le livre de référence de la SOA il y a 20 ans, qui avait des tableaux de ce genre. Mais je ne l’ai pas trouvé en ligne. Par contre, je suis tombé sur la Table 4.3. dans le livre de John Neter, Applied Linear Regression Models, paru en 1974 (repris dans la Table 3.4. de Applied Linear Statistical Models)

On a ici juste 11 observations, un modèle linéaire simple. Il est possible de faire tous les calculs à la main. Mais je me suis dit que ce n’était pas un cadeau : on ne peut pas faire grand chose sans faire un minimum de maths… Faisons juste une régression linéaire sur ces données, pour “voir”

base = data.frame(x=c(125,100,200,75,150,175,75,175,125,200,100),
                  y=c(160,112,124,28,152,156,42,124,150,104,136))
plot(base,xlab="Size of Minumum Deposit",
     ylab="Number of New Accounts",pch=19,ylim=c(30,180))
abline(lm(y~x,data=base),col="red")

La droite de régression (qui minimise la somme des carrés des erreurs) est la courbe (ou ici “droite”, on est sur un modèle linéaire) rouge

summary(lm(y~x,data=base))
 
Coefficients:
            Estimate Std. Error t value Pr(>|t|)
(Intercept)  50.7225    39.3979   1.287     0.23
x             0.4867     0.2747   1.772     0.11

On ne voit rien, littéralement ! Surtout que sur cet exemple, la question qui nous brule les lèvres, c’est “où est le maximum ?” car on voit bien qu’on a une courbe qui semble concave, croissante au début, décroissante sur la fin… On peut faire du lissage non-paramétrique pour s’en convaincre

with(base, 
     scatter.smooth(x, y,
        lpars = list(col = "red"),
        xlab="Size of Minumum Deposit",
       ylab="Number of New Accounts",
       ylim=c(30,180),pch=19))

Peut-aller plus loin, pour répondre à la question “où est le maximum ?”. En particulier, peut-on suggérer une valeur, voir trouver un intervalle de confiance ?

On peut continuer avec un modèle paramétrique – l’essentiel de ce qu’on voit dans les cours de statistique tourne autour des modèles paramétrique. Mais si on est plus pragmatique, on peut considérer un modèle quadratique, autrement dit, notre prévision sera une parabole. Ça pourrait être cohérent avec ce qu’on voit quand on trace les points, et puis souvent, les paraboles ont un maximum

with(base, 
     scatter.smooth(x, y,
        lpars = list(col = "red",lty=2),
        xlab="Size of Minumum Deposit",
        ylab="Number of New Accounts",
        ylim=c(30,180),pch=19))
reg=lm(y~x+I(x^2),data=base)
vx=seq(min(base$x),max(base$x),length=251)
vy=predict(reg,newdata=data.frame(x=vx))
lines(vx,vy,col="red")

On peut voir que le modèle pourrait sembler réaliste, non seulement visuellement, mais en plus si on regarde la sortie de la régression (même si on pourrait discuter ici l’interprétation de la significativité…)

summary(reg)
 
Coefficients:
              Estimate Std. Error t value Pr(>|t|)    
(Intercept) -3.255e+02  5.589e+01  -5.824 0.000394 ***
x            6.569e+00  8.744e-01   7.513 6.84e-05 ***
I(x^2)      -2.203e-02  3.143e-03  -7.011 0.000111 ***
---
Signif. codes:  0***0.001**0.01*0.05 ‘.’ 0.1 ‘ ’ 1

Or on peut montrer que pour une parabole de la forme y=\beta_2x^2+\beta_1x+\beta_0 l’optimum (qui sera un maximum si \beta_2<0 – la courbe part en -\infty à gauche et à droite) sera obtenu en x^\star=\theta=-\beta_1/2\beta_2. Un estimateur naturel de \theta est alors \widehat{\theta}=-\widehat{\beta}_1/2\widehat{\beta}_2 où les estimateurs sont obtenus ici par minimisation de la somme des carrés des erreurs. Mais comment avoir la variance de cet estimateur ? On peut naturellement tenter la \Delta-méthode (décrite sur wikipedia), en considérant \displaystyle{\theta=g(\beta_1,\beta_2)=\frac{-\beta_1}{2\beta_2}}Comme \displaystyle{\frac{\partial \theta}{\partial \beta_1}=\frac{-1}{2\beta_2}}et \displaystyle{\frac{\partial \theta}{\partial \beta_2}=\frac{\beta_1}{2\beta_2^2}}la variance (asymptotique) vaut ici \left[ \frac{-1}{2\beta_2}~~\frac{\beta_1}{2\beta_2^2} \right] \left[ \begin{array}{cc} \sigma_{1}^2 & \sigma_{12} \\ \sigma_{12} & \sigma_{2}^2 \end{array} \right] \left[\frac{-1}{2\beta_2}~~\frac{\beta_1}{2\beta_2^2} \right]^{\text{ T}}soit \frac{\sigma_1^2\beta_2^2-2\beta_1\beta_2\sigma_{12}+\beta_1^2\sigma_2^2}{4\beta_2^2}On obtient alors un estimateur de cette variance asymptotique en remplaçant les valeurs inconnues par leurs estimateurs. Ici, on aurait, numériquement

beta=coefficients(reg)
n=nrow(base)
sigma=n*vcov(reg)[2:3,2:3]
dg = c(-.5/beta[3],.5*beta[2]/beta[3]^2)
theta=-beta[2]/(2*beta[3])
theta
[1]  149.0676 
s2=t(dg) %*% sigma %*% dg
s2
         [,1]
[1,] 94.59911
sqrt(s2)
         [,1]
[1,] 9.726207

Autrement dit, si on suppose la normalité de notre estimateur (ce que nous dit d’ailleurs la \Delta-méthode, tout du moins asymptotiquement), on a l’intervalle de confiance suivant

theta+qt(c(.025,.975),n-3)*sqrt(s2)
[1] 126.6389 171.4963
vx=theta
vy=predict(reg,newdata=data.frame(x=vx))
points(vx,vy,pch=19,cex=1.5,col="red")
arrows(vx-qt(.975,n-3)*sqrt(s2),vy,
       vx+qt(.975,n-3)*sqrt(s2),vy,code=3,angle=90,length=.1,
       col="red",lwd=1.2)

On peut aussi tenter une autre stratégie, basée sur l’utilisation de la vraisemblance profilée. Je renvoie à mon précédent billet pour expliquer l’idée de la méthode, malheureusement pas assez enseignée dans les cours de statistique… Pour notre modèle quadratique, on maximisait la log-vraisemblance, classiquement, sous une hypothèse de résidus Gaussiens et homoscédastiques

logL = function(pm){
  b0=pm[1]
  b1=pm[2]
  b2=pm[3]
  b3=pm[4]
  -sum(log(dnorm( (base$y-(b0+b1*base$x+b2*base$x^2)) ,0,b3)))
}

Ici, la première astuce est d’introduire \theta (là où se trouve le maximum de la parabole) comme un des paramètres du modèle – par exemple à la place de \beta_2

logL = function(pm){
  b0=pm[1]
  b1=pm[2]
  theta=pm[3]
  b3=pm[4]
  -sum(log(dnorm( (base$y-(b0+b1*base$x-.5*b1/theta*base$x^2)) ,0,b3)))
}

Si on cherche juste le maximum de la vraisemblance, on obtient

 optim(par=c(-323,6.5,140,5),logL)
$par
[1] -325.521244    6.569328  149.070597   13.693488
 
$value
[1] 44.39629

ce qui est cohérent avec notre calcul précédant (et c’est normal, c’est la propriété du cours de statistique qui dit qu’on peut reparamétrer le modèle, ça ne change rien). La seconde astuce est celle de la vraisemblance profilée : on dit que dans notre paramètre multivarié, un est plus important que les autres. Et les autres sont juste maximisés, à \theta donné. Techniquement, la log-vraisemblance profilée du paramètre \theta est

logL=function(theta){
  f=function(pm){
  b0=pm[1]
  b1=pm[2]
  b3=pm[3]
  -sum(log(dnorm( (base$y-(b0+b1*base$x-.5*b1/theta*base$x^2)) ,0,b3)))
  }
  optim(par=c(-323,6.5,5),f)$value
}

On peut d’ailleurs la tracer

v1 = seq(130,190)
v2 = Vectorize(logL)(v1)
plot(v1,-v2,type="l",xlim=range(base$x),xlab="",ylab="log vraisemblance")

Le maximum est atteint, ici en

opt
$minimum
[1] 149.068

Ce qui est cohérent avec nos calculs. On peut ensuite un résultat sur le test du rapport de vraisemblance, qui nous dit que la différence entre la log-vraisemblance au maximum et en la vraie valeur suit la moitié du quantile d’une loi du chi-deux à 1 degré de liberté

points(opt$minimum,-opt$objective,pch=19,cex=1.5,col="red")
ref=-opt$objective-.5*qchisq(.95,1)
abline(h=ref,lty=2,col="red")

On peut alors alors tracer l’intervalle de confiance sur le graphique initial

with(base, 
     scatter.smooth(x, y,
                    lpars = list(col = "red",lty=2),
                    xlab="Size of Minumum Deposit",
                    ylab="Number of New Accounts",
                    ylim=c(30,180),pch=19))
reg=lm(y~x+I(x^2),data=base)
vx=seq(min(base$x),max(base$x),length=251)
vy=predict(reg,newdata=data.frame(x=vx))
lines(vx,vy,col="red")
vx=opt$minimum
vy=predict(reg,newdata=data.frame(x=vx))
points(vx,vy,pch=19,cex=1.5,col="red")
arrows(min(v1[id]),vy,max(v1[id]),vy,code=3,angle=90,length=.1,
       col="red",lwd=1.2)

Voilà au moins deux méthodes, basées sur deux résultats du cours de statistique. Après, comme la majorité des techniques de statistique, ce sont des résultats asymptotiques, et rien ne garantie leur validité avec seulement 11 observations (“rien” est un peu fort… on pourrait faire des développements sur ce point).

Une autre solution est d’utiliser des simulations. On suppose que les observations, c’est un modèle, et du bruit. On peut prendre comme modèle le modèle non-paramétrique (lissage local) et supposer le bruit Gaussien. Pour générer d’autres échantillons, on va garder nos observations en x, par contre, pour y, on va utiliser \widehat{y}+\varepsilon\varepsilon sera tiré suivant une loi normale

reg=loess.smooth(x = base$x, y= base$y, evaluation = 501)
pred=function(x) reg$y[which.min(abs(x-reg$x))]
ypred=Vectorize(pred)(base$x)
epsilon = base$y-ypred
simu = function(graph=FALSE){
newbase = data.frame(x= base$x,
                     y= ypred + rnorm(n,mean(epsilon),sd(epsilon)))
reg=loess.smooth(x = newbase$x, y= newbase$y, evaluation = 501)
lines(reg$x,reg$y,col=rgb(1,0,0,.2))
reg$x[which.max(reg$y)]}
for(i in 1:20) simu(TRUE)
lines(loess.smooth(x = base$x, y= base$y, evaluation = 501),lwd=1.2,col="red")

On récupère ainsi plein de modèles, estimés sur ces nouvelles données. Compte tenu de l’asymétrie des données, on va oublier le modèle quadratique, et utiliser un modèle non-paramétrique, là encore. Et on calcule numériquement le maximum. Et on répète 10,000 fois.

V=Vectorize(simu)(1:1e5)
hist(V,probability = TRUE, col="light blue", border="white",ylim=c(0,.07))
lines(density(V),col="blue")
quantile(V,c(.025,.975))

On a ici la distribution empirique du maximum, observée sur nos 10,000 échantillons simulés. On peut même obtenir un intervalle de confiance, en prenant les quantiles empiriques

vy=pred(mean(V))
arrows(quantile(V,.025),vy,quantile(V,.975),vy,code=3,angle=90,length=.1,
       col="red",lwd=1.2)

Bref, j’ai l’impression que pour faire des applications, il vaut mieux bien connaître la théorie… non ?

Analyse des résultats au baccalauréat des séries générales

Pour continuer sur les manipulation de données publiques, je voulais m’inspirer du projet de Cédric, de la formation Data Science pour l’Actuariat sur les résultats au baccalauréat. Les données nécessaires à cette étude sont disponibles sur plusieurs sites,

Il ne s’agit aucunement d’une analyse poussée des résultats, juste un peu de visualisation, sans aucune autre prétention ! Ah oui, même si on ne va pas faire de carte (je les trouve peu lisibles) on va quand même utiliser les données spatiales : les établissements scolaires sont géolocalises, et on peut obtenir des informations locales, sur le taux de chômage, ou le revenu médian. Et faire des graphiques.

Ce préambule passé, on peut commencer.

library(dplyr)
library(readxl)
library(sp)
library(ggmap)
library(raster)
library(leaflet)
library(DT)
library(cowplot)
library(gstat)
library(tmap)

On va commencer par récupérer par établissement, les résultats au bac.

url_resultat_etab = "https://data.education.gouv.fr/explore/dataset/fr-en-indicateurs-de-resultat-des-lycees-denseignement-general-et-technologique/download/?format=csv&amp;timezone=Europe/Berlin&amp;use_labels_for_header=true"
download.file(url_resultat_etab,destfile = paste0(librairie,"import_resultat_etab.csv"), method="curl")
df_resultat_etab = read.csv("import_resultat_etab.csv",header=TRUE, sep= ";", encoding="UTF-8")

Comme bien souvent avec les données des administrations françaises, on a souvent des soucis de typographie. Pour simplifier, on va supprimer les accents, et uniformiser un peu les noms

MiseEnForme_Colonnes = function(text) {
  text &lt;- gsub("è", "e", text)  
  text &lt;- gsub("é", "e", text)         
  text &lt;- gsub("_", ".", text)
  text &lt;- gsub("serie.", "", text)
  text &lt;- gsub("Effectif.Presents.", "Effectif.", text)
  text &lt;- gsub("Taux.","Tx.",text)
  text &lt;- gsub("Brut.de.Reussite.", "Admis.Etab.", text)
  text &lt;- gsub("Reussite.Attendu.", "Admis.", text)
  text &lt;- gsub("brut", "Etab", text)
  text &lt;- gsub("attendu", "Academie", text)
  text &lt;- gsub("toutes.", "TOTAL", text)
  text &lt;- gsub("Total.", "TOTAL", text)
  text &lt;- gsub("..Etablissement", ".Etab", text)
  text &lt;- gsub("Pourcentage", "Tx", text)
  return(text)
}
for(i in 1:ncol(df_resultat_etab)){
  colnames(df_resultat_etab)[i] &lt;- MiseEnForme_Colonnes(names(df_resultat_etab)[i])
}

On va ensuite supprimer les départements et régions d’outre-mer,

df_resultat_etab = df_resultat_etab[-which(toupper(df_resultat_etab$Departement) %in% c("GUADELOUPE","MAYOTTE","MARTINIQUE","REUNION","GUYANE")),]

récupérer les noms des colonnes

Colonnes = colnames(df_resultat_etab)

et comme on s’intéresse aux premières variables

Colonnes_Generiques = Colonnes[1:8]

on les recupere, pour construire quelques statistiques pour colonnes relatives aux séries L, ES et S

Colonnes_Series = Colonnes[grepl("([a-zA-Z]*?.)*\\.S$|([a-zA-Z]*?.)*\\.ES$|([a-zA-Z]*?.)*\\.L$|([a-zA-Z]*?.)*\\.TOTAL$",Colonnes)]

Et on finit avec les autres

Colonnes_Autres = Colonnes[grepl("(Tx.Bacheliers.*)|(Tx.acces.*)|(Effectif.de.*)|(libelle.region)|(code.region)|(element)",Colonnes)] 
df_resultat_etab = cbind(df_resultat_etab[Colonnes_Generiques],df_resultat_etab[Colonnes_Series],df_resultat_etab[Colonnes_Autres])

On peut aussi localiser les établissements

url_carto_etab &lt;- "https://www.data.gouv.fr/s/resources/adresse-et-geolocalisation-des-etablissements-denseignement-du-premier-et-second-degres/20160526-143453/DEPP-etab-1D2D.csv"
 
download.file(url_carto_etab,destfile=paste0(librairie,"import_carto_etab.csv"))
df_carto_etab = read.csv2("import_carto_etab.csv",header=TRUE

On récupère ici la géolocalisation de 66556 établissements nationaux ! On peut croiser avec des données socio-économiques des communes

nom_base_emploi = "base-cc-emploi-pop-act-2014"
url_baseemploi_popactive = paste0("https://www.insee.fr/fr/statistiques/fichier/2862207/",nom_base_emploi,".zip")
download.file(url_baseemploi_popactive,destfile=paste0(librairie,nom_base_emploi,".zip"))
unzip(paste0(nom_base_emploi,".zip"),overwrite = TRUE) 
df_base_emploi_source = read_excel(paste0(nom_base_emploi,".xls"),sheet="COM_2014",skip=5)

On va exclure les territoires d’outre-mer ici

df_base_emploi_source &lt;- df_base_emploi_source[-which(df_base_emploi_source$DEP %in% c("971","972","973","974","975")),]
df_base_emploi_colonnes = c("CODGEO","P14_POP1564","P14_H1564","P14_F1564","P14_ACT1564","P14_ACTOCC1564","P14_CHOM1564","P14_INACT1564", "P14_ETUD1564", "P14_RETR1564", "P14_AINACT1564", "P14_HCHOM1524", "P14_FCHOM1524", "C14_ACT1564","C14_ACT1564_CS1","C14_ACT1564_CS2","C14_ACT1564_CS3","C14_ACT1564_CS4","C14_ACT1564_CS5","C14_ACT1564_CS6","P14_POP15P")
df_base_emploi = df_base_emploi_source[,names(df_base_emploi_source) %in% df_base_emploi_colonnes]

et corriger les soucis classiques de la Corse,

MiseEnForme_CodeGeo = function(text) {
  text &lt;- gsub("2A", "20", text)  
  text &lt;- gsub("2B", "20", text)  
}
df_base_emploi$CODGEO = MiseEnForme_CodeGeo(df_base_emploi$CODGEO)

On peut aussi utiliser des données de revenus, par communes

nom_base_revenus = "indic-struct-distrib-revenu-2014-COMMUNES"
url_baserevenus = paste0("https://www.insee.fr/fr/statistiques/fichier/3126151/",nom_base_revenus,".zip")
download.file(url_baserevenus,destfile=paste0(librairie,nom_base_revenus,".zip"))
unzip(paste0(nom_base_revenus,".zip"),overwrite = TRUE)
df_base_revenus = read_excel("FILO_DISP_COM.xls",sheet="ENSEMBLE",skip=5)[,c(1,4,7)]
df_base_revenus$CODGEO = MiseEnForme_CodeGeo(df_base_revenus$CODGEO)

On recupere des donnees spatiales relatives aux communes

url_geoloc_communes = "http://www.nosdonnees.fr/wiki/images/b/b5/EUCircos_Regions_departements_circonscriptions_communes_gps.csv.gz"
download.file(url_geoloc_communes,destfile=paste0(librairie,"geoloc_communes.csv.gz"))
df_geoloc_communes = read.csv2(gzfile("geoloc_communes.csv.gz"),header=TRUE, stringsAsFactors = FALSE,encoding="UTF-8")

et comme toujours, un peu de corrections s’imposent

df_geoloc_communes = df_geoloc_communes[-which(df_geoloc_communes$numéro_département %in% c("971","972","973","974","975")),]
df_geoloc_communes = df_geoloc_communes[,names(df_geoloc_communes) %in% c("code_insee","latitude","longitude","codes_postaux")]
df_geoloc_communes_nb &lt;- nrow(df_geoloc_communes)

On va ensuite creer une fonction de remplacement des valeurs manquantes, et de correction des séparateurs décimaux

MiseEnForme_CoordonneesGeo = function(valeur){
pretraitement = ifelse(as.character(valeur)=="-","0",as.character(valeur))
traitement = as.numeric(ifelse(pretraitement==".","0",gsub(pattern=",",replacement=".",pretraitement)))
  return(traitement)
}
df_geoloc_communes$latitude = MiseEnForme_CoordonneesGeo(df_geoloc_communes$latitude)
df_geoloc_communes$longitude = MiseEnForme_CoordonneesGeo(df_geoloc_communes$longitude)

On passe ensuite a l’élimination des lignes en double

df_geoloc_communes = unique(df_geoloc_communes)

On va ensuite changer les noms des colonnes pour harmoniser avec les autres bases

names(df_geoloc_communes) = c("Codes_Postaux","CODGEO","coordonnee_y","coordonnee_x")

On peut ensuite rechercher les lignes en double sur les codes insee

liste_CODGEO2 = aggregate(x=df_geoloc_communes$Codes_Postaux,by=list(df_geoloc_communes$CODGEO),FUN="length")
list_geoloc_communes_CODGEO2 = liste_CODGEO2[liste_CODGEO2$x&gt;1,1]
df_geoloc_communes_CODGEO2 = df_geoloc_communes[df_geoloc_communes$CODGEO %in% list_geoloc_communes_CODGEO2,1:2]

Ici, un correction manuelle s’impose pour 4 configurations : les données propres à Lyon, Paris et Marseille ne sont pas géolocalisées, les données propres à la ville de Laguépie sont géolocalisées en doubles

df_geoloc_communes_propre = df_geoloc_communes[!df_geoloc_communes$CODGEO %in% list_geoloc_communes_CODGEO2,]
df_geoloc_communes_corrige = data.frame(Codes_Postaux=c("13001","69001","75001","82250"),                        CODGEO=c("13055","69123","75056","82088"),
coordonnee_y=c(43.3,45.75,48.85,44.15),
coordonnee_x=c(5.4,4.85,2.31,1.97))
df_geoloc_communes = rbind(df_geoloc_communes_propre,df_geoloc_communes_corrige)

On peut enfin fusionner les bases

df_etab = merge(df_resultat_etab,df_carto_etab,by="Cod.Etab")

Certains établissements ne peuvent être géolocalisés pour certaines années

df_etab_total_nongeolocalises &lt;- df_resultat_etab[!df_resultat_etab$Cod.Etab %in% df_carto_etab$Cod.Etab,]

Comme l’étude ne porte que sur les seuls lycées d’enseignement général et technologique, le dataframe est réduit aux observations relatives d’une part aux lycées, d’autre part aux établissements d’enseignement polyvalent, général ou général et technologique.

df_etab = df_etab[grep("LYCÉE",toupper(df_etab$nature_uai_libe)),]
df_etab = df_etab[grep("GÉNÉRAL|POLYVALENT",toupper(df_etab$nature_uai_libe)),]
df_etab_nongeolocalises = df_etab[df_etab$Cod.Etab %in% df_etab_total_nongeolocalises$Cod.Etab,]
df_etab_geolocalise = df_etab[!is.na(df_etab$coordonnee_x),]
df_etab_geolocalise = df_etab_geolocalise[!is.na(df_etab_geolocalise$coordonnee_y),]

Enfin, on va convertir les code géographiques (ici reconnus comme facteur) en chaines de caractères (de 5 caractères) pour pouvoir fusionner les tables

ConvertCODGEO = function(code) {
  if(is.character(code)) {
    code_character = ifelse(nchar(code)&lt;5, paste0("0",code), code)
    return(code_character)
  }
  else if(is.factor(code)){
    code_character = ifelse(code&lt;10000, paste0("0",as.numeric(as.character(code))), as.numeric(as.character(code)))
    return(code_character)
  }
  else if(is.numeric(code)){
    code_character = ifelse(code&lt;10000, paste0("0",code), as.character(code))
    return(code_character)
  } 
}
df_etab_geolocalise$Code.commune = ConvertCODGEO(df_etab_geolocalise$Code.commune) 
df_etab_geolocalise$Secteur.Public.Prive = sapply(df_etab_geolocalise$Secteur.Public.Prive,function(nature) {ifelse(nature=="PU","Lycées Publics","Lycées Privés")})

On conservation alors les établissements dont la commune n’est pas manquante

df_etab_geolocalise = df_etab_geolocalise[!is.na(df_etab_geolocalise$Code.commune),]

Pour finir, on va creer une base, pour ensuite faire une graphique

tbl_etab_nature_res_source = df_etab_geolocalise[,c(3,8,9,10,11,13,14,15)]
for(i in c(6,7,8)){
  temp = tbl_etab_nature_res_source[!is.na(tbl_etab_nature_res_source[i]),c(1,2,i-3,i)]
  temp$Serie = ifelse(i==6,"L",ifelse(i==7,"ES","S"))
  names(temp)[2:4] = c("Nature","Effectif","Tx.Admis")
  if(i==6){
    tbl_etab_nature_result = temp
  }
  else{
    tbl_etab_nature_result = rbind(tbl_etab_nature_result,temp)
  }
}
graph = ggplot(tbl_etab_nature_result,aes(x=Effectif,y=Tx.Admis,colour=factor(Annee))) 
graph = graph + geom_point(alpha=0.45)
graph = graph + facet_grid(Serie~Nature)
graph = graph + xlab("Effectifs de l'établissement en terminale (par série)") + ylab("Taux d'admission (%)") 
graph = graph + scale_color_discrete(name="Année des\nrésultats")
graph = graph + theme(legend.title = element_text(size=9,face="bold"),
       legend.text = element_text(size=9),
       strip.background = element_rect(colour="black", fill="gray95"),
       panel.border = element_rect(linetype = "solid"),
       panel.grid.major = element_line(colour = "gray75",linetype = "dashed"),
       panel.grid.minor = element_line(colour = "gray95",linetype = "dashed"),
       axis.title.x = element_text(size=9, face="bold"),
       axis.text.x  = element_text(size=8),
       axis.title.y = element_text(size=9, face="bold"),
       axis.text.y  = element_text(size=8))
graph

On a ici l’evolution des resultats en fonction de la taille des etablissements.

df_communes_CorrNaN = df_communes_Corr[which(!df_communes_Corr$TxChomage == "NaN" &amp; !df_communes_Corr$TxCadres == "NaN" &amp; !df_communes_Corr$TxOuvriers == "NaN" &amp; !df_communes_Corr$NbPopulation == "NaN" &amp; !df_communes_Corr$TxSenior == "NaN" &amp; !df_communes_Corr$RevenusMedians == "NaN"),]
df_communes_sp = SpatialPointsDataFrame(coords = df_communes_CorrNaN[, c("coordonnee_x", "coordonnee_y")], data = df_communes_CorrNaN) 
Grille              = as.data.frame(makegrid(df_communes_sp, nsig=2, cellsize = 0.1))
names(Grille)       = c("X", "Y")
coordinates(Grille) = c("X", "Y")
gridded(Grille)     = TRUE  
fullgrid(Grille)    = TRUE  
proj4string(Grille) = proj4string(df_communes_sp)

On peut ensuite faire du krigeage, histoire de lisser un peu nos donnees de chomage et de revenu

df_communes_sp.TxChomage = krige(TxChomage ~ 1, df_communes_sp, Grille, nmax=1)
df_communes_sp.RevenusMedians = krige(RevenusMedians ~ 1, df_communes_sp, Grille, nmax=1)
sp_lycee_WGS84@data$TxChomage      = extract(R.TxChomage,sp_lycee_WGS84)
sp_lycee_WGS84@data$TxCadres       = extract(R.TxCadres,sp_lycee_WGS84)
sp_lycee_WGS84@data$TxOuvriers     = extract(R.TxOuvriers,sp_lycee_WGS84)
sp_lycee_WGS84@data$NbPopulation   = extract(R.NbPopulation,sp_lycee_WGS84)
sp_lycee_WGS84@data$TxSenior       = extract(R.TxSenior,sp_lycee_WGS84)
sp_lycee_WGS84@data$RevenusMedians = extract(R.RevenusMedians,sp_lycee_WGS84)

On peut enfin conclure, en faisant une fonction generique de visualisation

Creation_Graphique = function(df, AnneeObs_Ouv, AnneeObs_Clo, Effectifs, Abscisses, Ordonnees, TitreAbs, TitreOrd, CouleurGraph, CouleurLiss, Serie) {
  df_temp = df[which(df$Annee&gt;=AnneeObs_Ouv &amp; df$Annee&lt;=AnneeObs_Clo),]
  df_temp = df_temp[which(!is.na(df_temp[,Effectifs]) &amp; !is.na(df_temp[,Abscisses]) &amp; !is.na(df_temp[,Ordonnees])),]
  df_temp = df_temp[!df_temp[,Effectifs]==0,]
  df_temp = df_temp[,c(Abscisses,Ordonnees)]
  graphique = ggplot(df_temp,aes(x = df_temp[,Abscisses],y = df_temp[,Ordonnees])) 
  graphique = graphique + geom_point(data = df_temp, aes(x = df_temp[,Abscisses],y = df_temp[,Ordonnees]),size=1, color=CouleurGraph,alpha=0.25) 
  graphique = graphique + geom_density2d(aes(colour=..level..),show.legend=F) + scale_colour_gradient(low="gray55",high="gray25") 
  graphique = graphique + scale_y_continuous(breaks= seq(80,100,by=2), limits = c(80,100))
  graphique = graphique + xlab(TitreAbs) + ylab(TitreOrd) 
  graphique = graphique + ggtitle(Serie) 
  graphique = graphique + theme(plot.title   = element_text(size=13,color=CouleurLiss, face="bold", hjust=0),
       axis.title.x = element_text(size=8, face="bold"),
       axis.text.x  = element_text(size=8),
       axis.title.y = element_text(size=8, face="bold"),
       axis.text.y  = element_text(size=8),
       panel.border = element_rect(linetype = "solid"),
       panel.grid.major = element_line(colour = "gray55",linetype = "dashed"),
       panel.grid.minor = element_line(colour = "gray75",linetype = "dashed")) 
graphique = graphique + stat_smooth(method = "loess",fill=CouleurLiss,color=CouleurLiss)
  return(graphique)
}
Production_Graphique_VI_1 = function(df, Titre_General, Axe_Abscisses, Titre_Abscisses, Annee_Observee_Ouv, Annee_Observee_Clo){
  Graph_S = Creation_Graphique(df, Annee_Observee_Ouv, Annee_Observee_Clo, "Effectif.S", Axe_Abscisses, "Tx.Admis.Etab.S", Titre_Abscisses, "Taux d'admission (%)", "dodgerblue3","dodgerblue4","Série S")
  Graph_ES = Creation_Graphique(df, Annee_Observee_Ouv, Annee_Observee_Clo, "Effectif.ES", Axe_Abscisses, "Tx.Admis.Etab.ES", Titre_Abscisses, "Taux d'admission (%)","darkorange2","darkorange3","Série ES")
  Graph_L = Creation_Graphique(df, Annee_Observee_Ouv, Annee_Observee_Clo, "Effectif.L", Axe_Abscisses, "Tx.Admis.Etab.L", Titre_Abscisses, "Taux d'admission (%)", "chartreuse4","darkgreen","Série L")
  Graph_TS = Creation_Graphique(df, Annee_Observee_Ouv, Annee_Observee_Clo, "Effectif.Etab", Axe_Abscisses, "Tx.Admis.Etab", Titre_Abscisses, "Taux d'admission (%)", "indianred1","red4","Toutes séries")
  p = plot_grid(Graph_S, Graph_ES, Graph_L, Graph_TS, ncol = 2, nrow = 2,align = 'hv',
  scale = c(0.95, 0.95, 0.95, 0.95),vjust = 0.9, hjust=-0.5)
  titre &lt;- ggdraw() + draw_label(Titre_General,fontface="bold", size=10)
  plot_grid(titre, p, ncol = 1, rel_heights=c(.25,5))
}

On note ici

df_lycee &lt;- sp_lycee_WGS84@data

et on peut faire un premier graphique, avec le taux de chomage

Production_Graphique_VI_1(df              = df_lycee,
                          Titre_General   = "Taux d'admission par série en fonction du taux de chômage \n dans la population active - Tous lycées confondus",
                          Axe_Abscisses   = "TxChomage",
                          Titre_Abscisses = "Taux de chômage dans la population active (%)",
                          Annee_Observee_Ouv     = "2013",
                          Annee_Observee_Clo     = "2015")

On ne va pas enfoncer les portes ouvertes de l’inference ecologique, en affirmant des choses aussi stupides que “on a moins de chances d’avoir le bac quand on est au chômage”. Mais on peut noter que dans les zones avec un fort taux de chômage, les résultats au bac sont moins bons.

On peut ensuite regarder en fonction du revenu de la commune du lycée

Production_Graphique_VI_1(df                     = df_lycee,
                          Titre_General          = "Taux d'admission par série en fonction du niveau des revenus disponibles médians - Tous lycées confondus",
                          Axe_Abscisses          = "RevenusMedians",
                          Titre_Abscisses        = "Quantile du niveau des revenus disponibles médians (%)",
                          Annee_Observee_Ouv     = "2013",
                          Annee_Observee_Clo     = "2015")

Fascinant, non ? Mais c’est clairement juste une première approche… il faudrait aller plus loin ensuite !

Scraper, ou pas ?

Ce matin, je mettais en ligne un billet scraper la base d’incendies de forêts expliquant comment scraper la base Promethee, en remplaçant automatique une formulaire. Dans la soirée, sur Twitter me faisait remarquer que c’était intéressant, mais peut être inutile (sur cet exemple particulier en tous cas).

Sur Firefox, il existe un “Moniteur Réseau“, qui s’ouvre en cliquant sur le clavier CtrlMaj + E ( CommandOption + E quand on est est sur un Mac). Ça ouvre un espace en bas de la fenêtre

Si maintenant je lance a la main ma requête, on voit ce qui est fait

Une methode GET apparait. En cliquant dessus, on a toute l’information nécessaire a droite

Dans l’onglet ‘Reponse’, on voit l’information sur le fichier json créé,

on a plus d’information bien entendu, si on agrandit

et surtout si on va dans l’onglet ‘En-tetes’

on a l’URL complet de la requête ! On peut ensuite copier le lien, et l’ouvrir

On a ainsi a accès a presque toute la table. Quand on regarde l’URL, seuls 20 incendies sont renvoyés, a cause du &nbrLigne=20& mais on peut tenter de le changer. propose de mettre &nbrLigne=10000& et il affirmait que ça marchait. J’avoue avoir essayé, sans succès.

Mais je retiens le tuyau en tous cas. Parfois, on peut faire simple !

Scraper la base d’incendies de forêts

Aller, deux billets pour parler de scraping, ou harvesting serait peut être plus juste ? Disons qu’on va faire un code automatique pour récupérer des informations en ligne. Plus particulièrement, on va s’intéresser au cas ou les données sont obtenues par une requête manuelle, et le site n’a pas d’API pour générer un joli fichier csv. Pierre-Marie, de la formation Data Science pour l’Actuariat a propose un exemple dont je vais m’inspirer (avec une autre methode pour scraper car j’ai eu des soucis pour installer le logiciel).

En 1973 a été lancée en France Prométhée, une base de données sur les incendies de forêts de la région méditerranéenne (couvrant 15 départements du Sud-Est). Oui, Προμηθεύς est ce titan qui a voulu jouer avec le feu… On peut consulter la base sur http://promethee.com/default/incendies,

En remplissant les champs, on peut faire une extraction suivant tel ou tel critère. Par exemple, en 2016, en Corse, il y a eu 6 incendies de nature “accidentelle”,

On le voit, le lien de la page ne change pas… il faut donc trouver une methode pour remplir manuellement les champs, et récupérer les informations. En particulier, on voit qu’on peut avoir accès aux informations relatives aux différents sinistres en cliquant sur la loupe

Idéalement, on voudrait un code R, automatique, pour faire ça ! Une première solutions, proposée par Pierre-Marie, est de passer par RSelenium. Le package R (non maintenu sur le CRAN depuis quelques semaines) est base sur Selenium, “Selenium automates browsers” comme dit la publicité. Le code pour scraper une page comme par

require("devtools")
devtools::install_github("ropensci/RSelenium")
require(RSelenium)
remDr = remoteDriver(remoteServerAddr = "localhost" 
                      , port = 4445L
                      , browserName = "firefox")

Le soucis est que ce code ne tourne pas sur mon mac. Il y a de nombreuses pages qui parlent des spécificités de mac (en particulier le soucis du port par défaut 4445, qu’il faut changer). J’ai tout essayé, sans succès.

Une autre piste est de passer par un autre package

require("devtools")
devtools::install_github("ropensci/wdman")

wdman, pour “Webdriver Manager“, propose aussi de le faire, en s’appuyant sur diverses technologies, selenium, chromedriver, phantomJS binary ou encore geckodriver. Moyennant l’installation de chrome, la seconde option est intéressante

library(wdman)
cDrv = chrome()
eCaps = list(chromeOptions = list(
  args = c('--headless', '--disable-gpu', '--window-size=1280,800')
))
remDr = remoteDriver(browserName = "chrome", port = 4567, 
                     extraCapabilities = eCaps)
remDr$open()

qui marche ! On peut lui demander d’aller sur la base promethee, et de faire une copie d’écran

remDr$navigate("http://www.promethee.com/default/incendies")
remDr$screenshot(display = TRUE)

On va ensuite remplir les champs, pour notre requête, sur la page. Par exemple, pour la date de début, on peut remonter au début des années 80

webElem = remDr$findElement(using = 'name', 'dtAlerteDeb')
webElem$clearElement()
webElem$sendKeysToElement(list('01/01/1981'))

et terminer fin 2017

webElem = remDr$findElement(using = 'name', 'dtAlerteFin')
webElem$clearElement()
webElem$sendKeysToElement(list('31/12/2017'))

On se focalise seulement sur la Corse

webElem = remDr$findElement(using = 'name', 'codeg')
webElem$sendKeysToElement(list('CORSE'))

et on veut 50 observations par page

webElem = remDr$findElement(using = 'name', 'nbrLigne')
webElem$sendKeysToElement(list('50'))

Ah oui, et on va temporiser entre chaque requête

webElem = remDr$findElement(using = 'name', 'btnSubmit')
webElem$submitElement()
Sys.sleep(15)
remDr$screenshot(TRUE)

(c’est une règle assez classique quand on scrap: on évite d’aller trop vite, pour pas se faire repérer…). On va ensuite commencer a regarder ce que l’on demande

text_base = read_html(remDr$getPageSource()[[1]])
list_tr = html_nodes(text_base, "tr")
a = html_nodes(list_tr[length(list_tr)], "a")
page_max = as.numeric(html_text(a[10]))

On a environ 620 pages ! avec au moins 10 secondes pour changer de pages, et en rajoutant 15 secondes (on en parlait avant), ca fait quelques heures pour scraper.

Que veut-on récupérer en grattant la page ? On peut récupérer les coordonnées de l’incendie (latitude/longitude), les caractéristiques de l’incendie (dates, lieu, surface), et retourner le tout dans une table

scrapping = function(feux, page) {
  list_a = html_nodes(read_html(feux), "a")
  if (length(list_a) &gt;= 2) {
    att = html_attrs(list_a[2])
    longitude = as.numeric(str_extract(att, "[0-9]\\.([0-9])*"))
    latitude = as.numeric(str_extract(att, "([0-9]){2}\\..([0-9])*"))
  } else {
    longitude = 0
    latitude = 0
  }
  list_span = html_nodes(read_html(feux), "span")
  date = html_text(list_span[2])
  commune = html_text(list_span[4])
  surface = as.numeric(html_text(list_span[5]))  
  list_div = html_nodes(read_html(feux), "div")
  if (length(list_a) &gt;= 2) {
    infos1 = html_text(list_div[3])
    infos2 = html_text(list_div[5])
  } else {
    infos1 = html_text(list_div[2])
    infos2 = html_text(list_div[4])
  }
  alerte = gsub("First alert : |First intervention", "", str_extract(infos1, "First alert : (.)*First intervention"))
  deb_inter = gsub("First intervention : |End of intervention", "", str_extract(infos1, "First intervention : (.)*End of intervention"))
  fin_inter = gsub("End of intervention : |Origins of the alert", "", str_extract(infos1, "End of intervention : (.)*Origins of the alert"))
  code_INSEE = gsub("INSEE code : |Locality", "", str_extract(infos2, "INSEE code : (.)*Locality"))
  lieudit = str_trim(gsub("Locality : ", "", str_extract(infos2, "Locality : (.)*")))
  liste_feux = data.frame(commune, date, code_INSEE, longitude, latitude, lieudit, surface, alerte, deb_inter, fin_inter, page)
  return(liste_feux)
}

Reste a faire tourner sur les 620 pages. Pour chaque ligne, on récupère les informations !

df = data.frame()
for (page in 1:page_max) {
  text_base = read_html(remDr$getPageSource()[[1]])
  list_tr = html_nodes(text_base, "tr")
  if (length(html_nodes(read_html(as.character(list_tr[14])), "a")) == 8) {
    deb = 15
  } else {
    deb = 14
  }
  for (i in deb:(deb+49)) {
    feux = as.character(list_tr[i])
    df = rbind(df, scrapping(feux, page))
  }
  if (page == 1) {
    webElem = remDr$findElement(using = 'xpath', '//*[contains(concat( " ", @class, " " ), concat( " ", "page_img", " " ))]')
  } else {
    webElem = remDr$findElement(using = 'xpath', '//*[contains(concat( " ", @class, " " ), concat( " ", "page_img", " " ))][3]')
  }
  webElem$clickElement()
  heure = (floor((page_max-page)*15/60) - floor((page_max-page)*15/60) %% 60) / 60
  minute = floor((page_max-page)*15/60) %% 60
  pb = progress_bar$new(total = 100)
  for (i in 1:100) {
    if (i==1) {cat("page", page, "sur", page_max," -  (reste", heure, "h", minute, "min)",  "\n")}
    pb$tick()
    Sys.sleep(15 / 100)
  }
  remDr$screenshot(TRUE)
}
feux = df

Ça y est, on a une base, avec presque 31 000 lignes ! on va ensuite ranger un peu, et clarifier

colnames(feux)[colnames(feux)=="longitude"] = "x"
colnames(feux)[colnames(feux)=="latitude"] = "y"
feux[, date := as.Date(date, "%d/%m/%Y")]
feux[, date_alerte := as.Date(substr(alerte, 1, 10), "%d/%m/%Y")]
feux$heure_alerte[nchar(feux$alerte) &gt; 10] = substr(feux$alerte[nchar(feux$alerte) &gt; 10], 12, 16)
feux$heure_alerte[!(nchar(feux$alerte) &gt; 10)] = ""
feux[, date_deb_inter := substr(deb_inter, 1, 10)]
feux[, date_deb_inter := as.Date(date_deb_inter, "%d/%m/%Y")]
feux$heure_deb_inter[nchar(feux$deb_inter) &gt; 10] = substr(feux$deb_inter[nchar(feux$deb_inter) &gt; 10], 12, 16)
feux$heure_deb_inter[!(nchar(feux$deb_inter) &gt; 10)] = ""
feux$heure_deb_inter[feux$heure_deb_inter == "00:00"] = ""
feux[, date_fin_inter := substr(fin_inter, 1, 10)]
feux[, date_fin_inter := as.Date(date_fin_inter, "%d/%m/%Y")]
feux$heure_fin_inter[nchar(feux$fin_inter) &gt; 10] = substr(feux$fin_inter[nchar(feux$fin_inter) &gt; 10], 12, 16)
feux$heure_fin_inter[!(nchar(feux$fin_inter) &gt; 10)] = ""
feux$heure_fin_inter[feux$heure_fin_inter == "00:00"] = ""
feux$annee = year(feux$date_alerte)
feux$month = month(feux$date_alerte)

Pour voir un peu nos données, rien de tel que des statistiques descriptives. On peut commencer avec du barplot du nombre de feux de forêts par année

agg_annee = aggregate(alerte~annee, FUN=length, data=feux)
colnames(agg_annee)[colnames(agg_annee)=="alerte"] = "Nombre"
nb = ggplot(agg_annee) +
  geom_bar(aes(x=annee, y=Nombre, fill="Feux de forêts"), stat="identity", width = 0.8) +
  scale_colour_manual(name=NULL, values=c("orange")) +
  ggtitle("Nombre de feux par an") +
  theme(plot.title = element_text(hjust = 0.5, size=14),
        legend.position = "none",
        axis.text.x = element_text(angle=50, vjust=0.5, size=10),
        axis.text.y = element_text(size=12),
        axis.title.x = element_blank(),
        axis.title.y = element_blank()) +
  scale_fill_discrete("") +
  scale_x_discrete(limit=seq(1981, 2017, by = 2))

ou un barplot de la surface de feux de forêts par anee

agg_surface = aggregate(surface~annee, FUN=sum, data=feux)
surf = ggplot(agg_surface) +
  geom_bar(aes(x=annee, y=surface, fill="Feux de forêts"), stat="identity", width = 0.8) +
  scale_colour_manual(name=NULL, values=c("orange")) +
  ggtitle("Surface totale incendiée par an (en ha)") +
  theme(plot.title = element_text(hjust = 0.5, size=14),
        legend.position = "none",
        axis.text.x = element_text(angle=50, vjust=0.5, size=10),
        axis.text.y = element_text(size=12),
        axis.title.x = element_blank(),
        axis.title.y = element_blank()) +
  scale_fill_discrete("") +
  scale_x_discrete(limit=seq(1981, 2017, by = 2)) +
  scale_y_discrete(limit=seq(0, 25000, by = 5000))

Et on fait le graphique

require(grid)
grid.newpage()
pushViewport(viewport(layout = grid.layout(1, 2)))
define_region = function(row, col){
  viewport(layout.pos.row = row, layout.pos.col = col)
} 
print(nb, vp = define_region(1, 1))
print(surf, vp = define_region(1, 2))

Passons aux choses serieuses, avec des cartes (la partie la plus serieuse, on en conviendra, c’etait la phase initiale de scraping). On commence par des informations relatives a la Corse

url="https://raw.githubusercontent.com/data-PM/Promethee/master/communes_corse-shp.zip"
temp="corse.zip"
download.file(url, "corse.zip")
unzip("corse.zip")
communes_corse = sp::spTransform(shapefile("/Users/arthur/communes_corse-shp/communes_corse.shp"), CRS("+proj=longlat +datum=WGS84"))

On se limite aux feux de plus de 1000m2

feux_min1000m2 = feux[feux$surface &gt; 0.1, ]

Maintenant, on peut faire la carte

feux_INSEE = aggregate(x = feux_min1000m2$code_INSEE, by = list(unique.values = feux_min1000m2$code_INSEE), FUN = length)
colnames(feux_INSEE)[colnames(feux_INSEE)=="unique.values"] = "insee"
communes_corse = merge(x = communes_corse, y = feux_INSEE, by = "insee", all.x = TRUE)
communes_corse$x[is.na(communes_corse$x)] = 0
max = max(communes_corse$x)
communes_corse$x2 = communes_corse$x/max * 100
corse2 = gSimplify(communes_corse, tol = 0.001, topologyPreserve = TRUE)
corse2 = SpatialPolygonsDataFrame(corse2, communes_corse@data, match.ID = FALSE)
opar = par(mar = c(0,0,1.2,0))
plot(corse2, col = "#DAE3E6", border = "#8A0641", lwd = 0.7, bg = "#B5D0D0")

Le fond de carte (avec les communes) ressemble a ca

On peut maintenant passer a la carte choroplethe

choroLayer(spdf = corse2, df = corse2@data, var = "x", border = NA, 
           col = carto.pal("wine.pal", 6), legend.pos = "topleft", 
           add = TRUE, method = "fisher-jenks", nclass = 6, legend.title.txt = NULL)
top_villes = corse2[corse2$nom %in% c("Ajaccio", "Bastia", "Corte", "Porto-Vecchio", "Propriano", "Bonifacio", "Calvi"), ]
graphics::points(coordinates(top_villes), pch = 20, cex = 0.5)
labelLayer(top_villes, top_villes@data, txt = "nom", cex = 1, pos = 2, font = 4, offset = 0.5)
layoutLayer(title = "Nombre de feux de forêts depuis 1981 (minimum 1000 m2)",
            source = "Source : 1973-2018 Prométhée ©",
            author = NULL, scale = 10, frame = FALSE, col = "#cdd2d4", coltitle = "#8A5543")

Comme souvent avec R, plusieurs formats sont envisageables. On peut passer a du ggplot2, mais on commence par aller chercher un shapefile global de la Corse

corse = shp_zip("https://raw.githubusercontent.com/data-PM/Promethee/master/corse-shp.zip", "corse")
corse = spTransform(corse, CRS("+proj=longlat +datum=WGS84"))
corse = fortify(corse)
p=data %&gt;%
  ggplot() +
  geom_polygon(data=corse, aes(x=long, y = lat, group = group), fill="grey", alpha=0.3) +
  geom_point(data=feux_min100ha, aes(x=x, y=y, size=surface, color=surface, text=mytext, alpha=surface) ) +
  labs(title = "\nPrincipaux feux de forêts depuis 1981 \n (plus de 100 Ha)") +
  xlim(8.5, 9.6) + ylim(41.3,43.1) +
  scale_size_continuous(range=c(1,5), ) +
  scale_color_viridis(option="inferno", trans="log", name="Surface", limits=c(99, 5700), breaks=c(100, 200, 500, 1000, 2500, 5000)) +
  scale_alpha_continuous(trans="log") +
  theme_void() +
  theme(legend.title = element_text(size=10, face="bold"))
t=800
div(ggplotly(tooltip="text", width=t/1.7, height=t), align = "center")

Joli, non ?

Carte météo dynamique

Pour aller un peu plus loin par rapport au précédent billet, on peut faire une carte dynamique, pour visualiser une tempête, sur une journée. Je vais partir du fait qu’on a encore les objets du précédant billet en mémoire.

On commence par garder uniquement les données relatives a la journée qui nous intéresse,

date_sel = "2016-10-13"
date_sel_OK = paste0(substr(date_sel,9,10),"/",substr(date_sel,6,7),"/",substr(date_sel,1,4))
donnees_carte_0 = subset(data, data$date==as.POSIXct(date_sel))
horaires = sort(unique(donnees_carte_0$heure))

(mais on pourrait prendre une semaine). On recupere ensuite le contour de la France,

download.file("http://biogeo.ucdavis.edu/data/gadm2.8/rds/FRA_adm0.rds","FRA_adm0.rds")
FR0=readRDS("FRA_adm0.rds")
P1=FR0@polygons[[1]]@Polygons[[355]]@coords
P2=FR0@polygons[[1]]@Polygons[[27]]@coords

car seule la France métropolitaine nous intéressera (incluant la Corse, soit 2 gros polygones) dans l’esprit du précédant billet sur le zonier. On va ainsi definir un maillage sur lesquel on va lisser la pluviometrie,

grille = expand.grid(seq(min(donnees_carte_0$longitude),max(donnees_carte_0$longitude),length=101),seq(min(donnees_carte_0$latitude),max(donnees_carte_0$latitude),length=101))
paslong=(max(donnees_carte_0$longitude)-min(donnees_carte_0$longitude))/100
paslat=(max(donnees_carte_0$latitude)-min(donnees_carte_0$latitude))/100
f=function(i){ (point.in.polygon (grille[i, 1]+paslong/2 , grille[i, 2]+paslat/2 , P1[,1],P1[,2])&gt;0)+(point.in.polygon (grille[i, 1]+paslong/2 , grille[i, 2]+paslat/2 , P2[,1],P2[,2])&gt;0) }
indic=unlist(lapply(1:nrow(grille),f))
grille=grille[which(indic==1),]

Pour lisser, on utilise les k-plus proches voisins

knn=function(i,k=10){
  d=distHaversine(grille[i,1:2],donnees_carte[,
    c("longitude","latitude")], r=6378.137) 
  r=rank(d)
  ind=which(r&lt;=k)
  weighted.mean(donnees_carte[ind,"rr3"],(1/d[ind])/sum(1/d[ind]))}

On a ensuite la fonction suivante, pour faire une carte

carto_prec&lt;-function(){
  grille2&lt;-grille
  grille2$rr=Vectorize(knn)(i=1:nrow(grille2))
  bk=seq(0,50,length=21)
  grille2$cuty=cut(grille2$rr,breaks=bk,labels=1:20)
  cols = rev(carto.pal(pal1 = "blue.pal", n1=20, pal2 = "white.pal", n2=1))
  plot(FR0,border=NA)
  polygon(P1)
  polygon(P2)
  points(grille2[,1]+paslong/2,grille2[,2]+paslat/2,col=cols[grille2$cuty],pch=19)
  points(donnees_carte$longitude,donnees_carte$latitude, col="black",pch=19,cex=.5)
  title(main = paste0(date_sel_OK," à ",heure_sel,"H"),
        sub = "Précipitations des 3 dernières heures",
        cex.main = 1.5,   font.main= 4,
        cex.sub = 1, font.sub = 3)
  legend(8.2, 50, legend=seq(0,50,length=5), title='en mm',
         fill=cols[seq(1,20,length=5)], cex=0.8)
}

On va ensuite utiliser 8 fichiers – car on regarde toutes les 3 heures

for (hh in horaires) {
  heure_sel&lt;-hh
  donnees_carte &lt;- subset(donnees_carte_0, donnees_carte_0$heure==heure_sel)
  png(paste0("CartePrec",date_sel,"_",hh,".png"))
  carto_prec()
  dev.off()
}

(mais ça peut se raffiner, avec un lissage spatio-temporel). Et on va ensuite créer notre animation en concaténant les images

frames &lt;- image_morph(
  c(image_scale(image_read("CartePrec2016-10-13_1.png")),
image_scale(image_read("CartePrec2016-10-13_3.png")),
image_scale(image_read("CartePrec2016-10-13_6.png")),
image_scale(image_read("CartePrec2016-10-13_9.png")),
image_scale(image_read("CartePrec2016-10-13_12.png")),
image_scale(image_read("CartePrec2016-10-13_15.png")),
image_scale(image_read("CartePrec2016-10-13_18.png")),
image_scale(image_read("CartePrec2016-10-13_21.png"))), frames = 16)
frames.anim &lt;- image_animate(frames)
image_write(frames.anim, paste0("CartePrecDay",date_sel,".gif"))

Il faut avouer que ça a de gueule… On voit clairement la tempête arriver…

Faire ses cartes météo

Allez, un peu de scraping aujourd’hui (promis, il y aura d’autres billets d’ici la fin de la semaine sur le sujet). Je vais m’inspirer des codes de Romain de la formation Data Science pour l’Actuariat. Le but est de récupérer des données de températures, de précipitations, de vitesse de vent, journalières, en France. On commence par charger quelques librairies,

library(plyr)
library(stringr)
library(OpenStreetMap)
library(leaflet)
library(shiny)
library(rsconnect)
library(mapview)
library(png)
library(magick)
library(yaml)

On va récupérer les deux dernières années, mais comme toujours, le code peut facilement s’adapter.

annee = c(2016:2017)
mois = c('01','02','03','04','05','06','07','08','09','10','11','12')
aaaamm = sort(sub(pattern=' ',replacement = '', x=outer(annee,mois,paste)))
myCols = c(NA,NA,"NULL","NULL","NULL",NA,NA,"factor","NULL","NULL","NULL",NA,"NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL",NA,NA,NA,NA,NA,"NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL","NULL")
for (mois in aaaamm) {
  fichier = paste0("synop_",mois,".csv.gz")
  if (!file.exists(fichier)) {
    page = paste0('https://donneespubliques.meteofrance.fr/donnees_libres/Txt/Synop/Archive/synop.',mois,'.csv.gz')
    download.file(page, fichier, quiet = TRUE, cacheOK = FALSE)
  }
}  
for (mois in aaaamm) {
  fichier = paste0("synop_",mois,".csv.gz")
  if (mois=='201601') {
    data = read.table(gzfile(fichier),header=TRUE, sep=";",quote='"',fileEncoding="UTF-8",colClasses = myCols)
  } else {
    data = rbind(data,read.table(gzfile(fichier),header=TRUE, sep=";",quote='"',fileEncoding="UTF-8",colClasses = myCols))
  }
}

On supprime une des colonnes qui ne sert a rien

data[,"X"] = NULL

et on bricole un peu (sinon on a des soucis avec minuit, qui est décalé de 24 heures)

data$temp = as.numeric(substr(data$date,1,14))
decalage_minuit = function(dateheure){
  r = dateheure
  if (dateheure-trunc(dateheure/1000000)*1000000==0){
    r = dateheure + 10000
  }
  return(r)
}
data$temp = sapply(data$temp,decalage_minuit)
data$jourheure_obs = strptime(data$temp, format = '%Y%m%d%H%M%S', 'UTC')
data$date = as.POSIXct((strptime(data$jourheure_obs,format = "%Y-%m-%d")))
data$heure = as.numeric(substr(data$jourheure_obs, start=12, stop=13))
data[,"temp"] = NULL
data$t = as.numeric(as.character(data$t))-273.15

oui, on doit convertir en degrés Celsius. On peut aussi travailler sur les vitesses de vent

data$dd = as.numeric(as.character(data$dd))
data$ff = as.numeric(as.character(data$ff))/1000*3600
data$ff = round(data$ff/5)*5

que l’on va convertir en km/h, et enfin les précipitations

data$rr1 = pmax(0,as.numeric(as.character(data$rr1)))
data$rr3 = pmax(0,as.numeric(as.character(data$rr3)))
data$rr6 = pmax(0,as.numeric(as.character(data$rr6)))
data$rr12 = pmax(0,as.numeric(as.character(data$rr12)))
data$rr24 = pmax(0,as.numeric(as.character(data$rr24)))

On peut d’ailleurs commencer par une simple visualisation de séries de températures

data_temperature = subset(data, !is.na(data$t))
temp_min = aggregate(x=data_temperature$t,by=list(date=data_temperature$date),FUN=min)
names(temp_min)[2] = "temp_min"
temp_max = aggregate(x=data_temperature$t,by=list(date=data_temperature$date),FUN=max)
names(temp_max)[2] = "temp_max"
temp_moy = aggregate(x=data_temperature$t,by=list(date=data_temperature$date),FUN=mean)
names(temp_moy)[2] = "temp_moy"
temp_stat = cbind(temp_min,temp_max[],temp_moy)
rm(temp_min,temp_max,temp_moy)
temp_stat[,3] = NULL
temp_stat[,4] = NULL

avec le maximum observé, par jour, sur toutes les stations, le minimum, et la moyenne des stations

plot(x=temp_stat$date,y=temp_stat$temp_moy,'l',ylim=c(-15,40),xlab='Date',ylab='Température (°C)')
title('Températures françaises métropolitaines de 01/2016 à 12/2017')
points(x=temp_stat$date,y=temp_stat$temp_min,col="blue",'l')
points(x=temp_stat$date,y=temp_stat$temp_max,col="red",'l')

Pour faire des jolies cartes, il nous faut des informations sur les stations météo.

stations = read.table('https://donneespubliques.meteofrance.fr/donnees_libres/Txt/Synop/postesSynop.csv',header=TRUE, sep=";",quote='"',fileEncoding="UTF-8")
stations = rename(stations, replace=c("ID"="numer_sta"))
stations = rename(stations, replace=c("Nom"="nom"))
stations = rename(stations, replace=c("Latitude"="latitude"))
stations = rename(stations, replace=c("Longitude"="longitude"))
stations = rename(stations, replace=c("Altitude"="altitude"))
data = merge(x=data,y=stations)

Pour la carte, on va se restreindre aux données en France métropolitaine

data = subset(data, data$latitude &gt;= 39)
data = subset(data, data$latitude &lt;= 53)
data = subset(data, data$longitude &gt;= -5.3)
data = subset(data, data$longitude &lt;= 9.8)
coordonnees_stations = unique(data[, c("nom","latitude","longitude")])

Commencons par visualiser le maximum observee le 19 juillet 2016

date_sel = "2016-07-19"
date_sel_OK = paste0(substr(date_sel,9,10),"/",substr(date_sel,6,7),"/",substr(date_sel,1,4))
donnees_carte_0 = subset(data, data$date==as.POSIXct(date_sel))
temp = aggregate(x=donnees_carte_0$t,by=list(numer_sta=donnees_carte_0$numer_sta),FUN="max")
donnees_carte_0 = merge(x=donnees_carte_0,y=temp)
donnees_carte_0 = rename(donnees_carte_0, replace=c("x"="TEMP"))
donnees_carte_0$TEMP = round(donnees_carte_0$TEMP)
donnees_carte = unique(donnees_carte_0[,c('numer_sta','nom','longitude','latitude','TEMP')])
get_france = get_map(c(lon=2.25,lat=46), zoom=5, col='bw')
colfunc = colorRampPalette(c("darkblue","royalblue","cyan","lightblue","orange","red","darkred"))
liste_couleurs = data.frame(TEMP=as.numeric(seq(-49,50,1)),couleur=as.character(colfunc(100)))
donnees_carte = merge(x=donnees_carte,y=liste_couleurs)
france_tmax = ggmap(get_france) + 
  ggtitle(paste0('Températures maximales du ', date_sel_OK)) +
  scale_x_continuous(limits = c(-5, 10), expand = c(0, 0)) +
  scale_y_continuous(limits = c(41.3, 51.1), expand = c(0, 0))
france_tmax = france_tmax + geom_label(data=donnees_carte,aes(x=longitude,y=latitude,label=TEMP),col=as.character(donnees_carte$couleur))
france_tmax

On peut tenter aussi une visualisation des précipitations. On se place le 13 octobre 2016 (oui, il y a eu des inondations dans la region de Montpelier ce jour la)

date_sel = "2016-10-13"
colfunc = colorRampPalette(c('white','darkblue'))
data$precip_en_mm = data$rr3
data_precipitation = subset(data, !is.na(data$precip_en_mm))
precipitations = aggregate(x=data_precipitation$precip_en_mm,by=list(date=data_precipitation$date,station=data_precipitation$nom),FUN=sum)
names(precipitations)[3] = "pp"
precipitations$pp = pmax(precipitations$pp,0)
donnees_carte = subset(precipitations, precipitations$date==date_sel)
qt_prec = quantile(round(donnees_carte$pp),seq(0, 1, 0.05))
donnees_carte$Couleur_prec = colfunc(21)[(findInterval(round(donnees_carte$pp), qt_prec, all.inside=TRUE))]
donnees_carte = rename(donnees_carte, replace=c("station"="nom"))
donnees_carte = merge(x=donnees_carte,y=coordonnees_stations)

On peut tenter un leaflet ici (ça sera plus joli)

france = leaflet() %&gt;% addTiles() %&gt;% fitBounds(lng1=-4.412, lat1=41.92, lng2=9.485, lat2=50.57)
france = france %&gt;% addCircles(lng=donnees_carte$longitude, lat=donnees_carte$latitude, color=donnees_carte$Couleur_prec, opacity = 1, fillColor=donnees_carte$Couleur_prec, fillOpacity = 1, radius=donnees_carte$pp*500)
france

Comme souvent, j’ai des soucis pour integrer du leaflet en wordpress, alors on se contentera dans le billet d’une copie d’ecran (mais un copier/coller du code suffit).

Et pour finir, la meme chose avec les vitesses de vent. On se place le 6 mars 2017 (la encore, la date n’est pas choisie au hasard, c’était la tempete Zeus)

date_sel = "2017-03-06"
date_sel_OK = paste0(substr(date_sel,9,10),"/",substr(date_sel,6,7),"/",substr(date_sel,1,4))
heure_sel = 18
donnees_carte_0 = subset(data, data$date==as.POSIXct(date_sel))
donnees_carte_0 = subset(donnees_carte_0, donnees_carte_0$heure==heure_sel)
donnees_carte = donnees_carte_0

Pour les precipitations, des cercles plus ou moins grands suffisaient. La, on va mettre des fleches

logo = image_trim(image_read("https://image.freepik.com/icones-gratuites/fleche-noire-vers-le-haut_318-30934.jpg"))
if (file.exists('flecheblanche90.png')==FALSE){
  for (angle in seq(10,360, by=10)) {
    temp = image_rotate(logo,angle)
    image_write(temp,paste0('flecheblanche',angle,'.png'))
    temp = image_colorize(image=temp,opacity=40,color='green')
    image_write(temp,paste0('flecheverte',angle,'.png'))
    temp = image_colorize(image=temp,opacity=40,color='yellow')
    image_write(temp,paste0('flechejaune',angle,'.png'))
    temp = image_colorize(image=temp,opacity=40,color='orange')
    image_write(temp,paste0('flecheorange',angle,'.png'))
    temp = image_colorize(image=temp,opacity=40,color='red')
    image_write(temp,paste0('flecherouge',angle,'.png'))
    temp = image_colorize(image=temp,opacity=40,color='black')
    image_write(temp,paste0('flechenoire',angle,'.png'))
  }
}
arrowIcons = icons(
  iconUrl = ifelse(donnees_carte$dd == 0,
            ifelse(donnees_carte$ff&lt;39,
                    'flecheverte360.png',
            ifelse(donnees_carte$ff&lt;79,
                    'flechejaune360.png',
            ifelse(donnees_carte$ff&lt;119,
                    'flecheorange360.png',
            ifelse(donnees_carte$ff&lt;159,
                    'flecherouge360.png',
            ifelse(donnees_carte$ff&gt;159,
                    'flechenoire360.png',
                    'flecheblanche360.png'))))),
            ifelse(donnees_carte$ff&lt;39,
                   paste0('flecheverte',donnees_carte$dd,'.png'),
            ifelse(donnees_carte$ff&lt;79,
                    paste0('flechejaune',donnees_carte$dd,'.png'),
            ifelse(donnees_carte$ff&lt;119,
                    paste0('flecheorange',donnees_carte$dd,'.png'),
            ifelse(donnees_carte$ff&lt;159,
                    paste0('flecherouge',donnees_carte$dd,'.png'),
            ifelse(donnees_carte$ff&gt;159,
                    paste0('flechenoire',donnees_carte$dd,'.png'),
           paste0('flecheblanche',donnees_carte$dd,'.png'))))))),
  iconWidth = 30, iconHeight = 30)

Cette fois, on est bon ! On peut faire la carte

france = leaflet(options = leafletOptions()) %&gt;% addTiles() %&gt;% fitBounds(lng1=-4.412, lat1=41.92, lng2=9.485, lat2=50.57)
france = addMarkers(map = france,lng=donnees_carte$longitude,lat=donnees_carte$latitude,icon=arrowIcons,popup=as.character(donnees_carte$ff))
france

Les données actuarielles des assureurs, un trésor pour la connaissance client ?

Dans le supplément des Échos, publication d’une entrevue datant du printemps dernier.

Quels sont les typologies de données utilisées par les assureurs ?

Les actuaires, ces spécialistes des données et des statistiques chez les assureurs, utilisent les données clients internes, à savoir celles que les assurés leur fournissent, notamment au moment de la souscription de contrat, sur leur véhicule, leur lieu d’habitation, etc. Ils peuvent aussi “piocher” ailleurs, dans la cote argus par exemple, pour estimer le montant maximal d’un sinistre ; dans l’historique des inondations ; les données de cambriolage ; les données INSEE ou encore la météo. À partir de toutes ces données, les actuaires vont créer des modèles afin de prédire des scores d’accidents, de fraudes, de résiliation…

À quoi sert l’analyse des données actuarielles?

Ces données permettent surtout de segmenter le portefeuille, de trouver les bonnes variables tarifaires, pour créer des classes tarifaires en assurance auto ou habitation par exemple. Elles peuvent aussi être utilisées pour trouver le juste prix pour couvrir de nouveaux risques. Elles permettent enfin de répondre aux nouvelles demandes des assurés. Avant, avec l’assurance auto par exemple, lorsque votre voiture tombait en panne, on vous remboursait les frais et ça suffisait. Maintenant, les clients veulent être hébergés, disposer d’une voiture de remplacement… C’est à l’actuaire d’évaluer le coût de ces nouveaux services pour les inclure dans les différentes primes proposées par l’assureur.

« Il y a d’un côté l’approche marketing, qui va chercher à individualiser pour proposer des offres personnalisées ; de l’autre celle de l’actuaire, qui va chercher à trouver des catégories pertinentes, en mutualisant. »

a suivre…

Visualiser la localisation des dinosaures, grâce aux quaternions…

Allez, un petit billet que je rêve de faire depuis des années, mais je viens enfin de trouver un prétexte, grâce à François de la formation Data Science pour l’Actuariat (à qui je vais emprunter l’application qui va suivre). Il y a plusieurs années, j’avais évoqué dans un billet les difficultés de travailler sur les données spatiales, surtout quand on est au pole. Le pole est un point de singularité dans la représentation classique (latitude, longitude) de la sphère. A l’époque, j’avais propose un bricolage simpliste (mettre les points de singularité dans un coin), mais il y a plus propre, à l’aide des quaternions d’Hamilton. Pour les présenter rapidement, et le lien avec les données spatiales, sur le globe terrestre, je vais reprendre la page wikipedia qui explique de manière incroyablement claire l’idée générale, et plus particulièrement les liens des quaternions avec les rotations (qui servent de base dans la représentation de la sphère qu’est le globe terrestre).

Chaque rotation en dimension trois consiste à tourner d’un certain angle \alpha autour d’un certain axe \vec{v}. Pour un angle petit mais non nul (s’il est nul, on parle de rotation identité), l’ensemble des rotations possibles est une petite sphère entourant la rotation identité, où chaque point de la sphère représente un axe pointant dans une direction particulière. Des rotations d’angles de plus en plus grands s’éloignent progressivement de la rotation identité. Aussi, au voisinage de la rotation identité, l’espace abstrait des rotations ressemble à l’espace ordinaire en trois dimensions (qui peut également être vu comme un point central entouré de sphères de différents rayons).

On peut assimiler les différentes directions à partir du pôle (c’est-à-dire les différents méridiens) aux différents axes de rotations et les différentes distances au pôle Nord aux différents angles : on a ainsi une analogie de l’espace des rotations. Mais la surface de la sphère est en deux dimensions alors que les axes de rotation utilisent déjà trois dimensions. L’espace des rotations est donc modélisé par une sphère de dimension 3 dans un espace à 4 dimensions (une hypersphère). Il faut alors penser la sphère ordinaire comme à une section de l’hypersphère (de la même façon qu’un cercle est une section de sphère). On peut prendre la section pour représenter, par exemple, uniquement les rotations d’axes dans le plan xy. Et on peut légitimement penser maintenant aux rotations comme à des points de la sphère en dimension 4.

Bon, rentrons dans les détails. On paramètre la surface d’une sphère à l’aide de deux coordonnées, comme la latitude et la longitude. Mais cela pose des soucis importants aux pôles (comme je l’avais note dans un ancien billet). Le théorème de la boule chevelue montre en fait qu’il n’existe aucun système de coordonnées à deux paramètres  évitant cette dégénérescence. On va donc plonger la sphère dans l’espace à trois dimensions, en la paramétrant a l’aide de trois coordonnées cartésiennes (ici wx et y). Par convention, on place le pôle Nord à (w,y,z) = (1, 0, 0), le pôle Sud à (w,y,z) = (-1, 0, 0) et l’équateur sera le cercle d’équations w = 0 et x^2+y^2=1. Un point (w,x,y) de la sphère représente une rotation de l’espace ordinaire autour de l’axe horizontal dirigé par le vecteur {\displaystyle {\vec {v}}={\begin{pmatrix}x\\y\\0\end{pmatrix}}} et d’angle {\displaystyle \alpha =2\cos ^{-1}w=2\sin ^{-1}{\sqrt {x^{2}+y^{2}}}}
C’est l’idée générale.

Pour parler un peu des quaternions, pour rappel, un plan en dimension 2 peut être paramétré en utilisant les nombres complexes, en introduisant un symbole abstrait \mathbf {i} qui vérifie la règle \mathbf {i}^2=-1. On peut faire la meme chose en dimension 4, en introduisant des symboles abstraits \mathbf {i}, \mathbf {j} et \mathbf {k}. La partie imaginaire {\displaystyle b\mathbf {i} +c\mathbf {j} +d\mathbf {k} } d’un quaternion se comporte comme un vecteur {\displaystyle {\vec {v}}={\begin{pmatrix}b\\c\\d\end{pmatrix}}} d’un espace vectoriel à trois dimensions.

Définissons le quaternion {\displaystyle \mathbf {q}=w+x\mathbf {i} +y\mathbf {j} +z\mathbf {k} =\cos(\alpha /2)+\frac{\vec {v}}{\|v\|}\sin(\alpha /2)} ou bien {\displaystyle \mathbf {q}=w+x\mathbf {i} +y\mathbf {j} +z\mathbf {k} =\cos(\alpha /2)+{\vec {u}}\sin(\alpha /2)} {\displaystyle {\vec {u}}} est un vecteur unitaire. Soit également {\displaystyle {\vec {v}}} un vecteur ordinaire de l’espace en 3 dimensions, considéré comme un quaternion avec une coordonnée réelle nulle. On pourrait que le produit de quaternions{\displaystyle \mathbf{q}{\vec {\nu}}\mathbf{q}^{-1}} renverrait le vecteur {\displaystyle {\vec {\nu}}} tourné d’un angle {\displaystyle \alpha } autour de l’axe dirigé par {\displaystyle {\vec {u}}} . Et c’est effectivement ce qui se passe. Cette opération est connue comme la conjugaison par \mathbf {q}.

Aussi, la multiplication de quaternions correspond à la composition de rotations, car si \mathbf {p} et \mathbf {q} sont des quaternions représentant des rotations, alors la rotation (conjugaison) par \mathbf {pq} est{\displaystyle \mathbf{pq}q{\vec {\nu}}(\mathbf{pq})^{-1}=\mathbf{pq}{\vec {\nu}}\mathbf{q}^{-1}\mathbf{p}^{-1}=\mathbf{p}(\mathbf{q}{\vec {\nu}}\mathbf{q}^{-1})\mathbf{p}^{-1}} ce qui revient à tourner (conjuguer) par \mathbf {q}, puis par \mathbf {p}.

Le quaternion inverse d’une rotation correspond à la rotation inverse, car {\displaystyle q^{-1}(q{\vec {v}}q^{-1})q={\vec {v}}} . Et assez naturellement, le carré d’un quaternion – noté \mathbf {q}^2 – correspond à la rotation de deux fois le même angle autour du même axe. Plus généralement, \mathbf {q}^{ {n}} correspond à une rotation de {n} fois l’angle autour du même axe que \mathbf {q}. Par convention, on peut considérer un réel arbitraire {r}, ce qui permet de calculer des rotations intermédiaires de façon fluide entre des rotations de l’espace.

Un petit exemple. Considérons la rotation f autour de l’axe dirigé par {\displaystyle {\vec {v}}=\mathbf {i} +\mathbf {j} +\mathbf {k} } et d’angle 120°, soit 2\pi/3.

La norme de {\displaystyle {\vec {v}}} est \sqrt{3} , le demi-angle est \pi/3 (ou 60°), le cosinus de ce demi-angle est 1/2, et le sinus est \sqrt{3}/2. Nous devons donc conjuguer avec le quaternion unitaire  {\displaystyle \mathbf{q}=\cos {\frac {\pi }{3}}+\sin {\frac {\pi }{3}}\cdot {\frac {1}{\sqrt {3}}}{\vec {v}}} soit \mathbf{q}={\frac {1}{2}}+{\frac {\sqrt {3}}{2}}\cdot {\frac {1}{\sqrt {3}}}{\vec {v}}={\frac {1}{2}}+{\frac {\sqrt {3}}{2}}\cdot {\frac {\mathbf {i} +\mathbf {j} +\mathbf {k} }{\sqrt {3}}} qui peut finalement s’écrire simplement{\frac {1+\mathbf {i} +\mathbf {j} +\mathbf {k} }{2}}

Si f est la fonction de rotation,{\displaystyle f(a\mathbf {i} +b\mathbf {j} +c\mathbf {k} )=\mathbf{q}(a\mathbf {i} +b\mathbf {j} +c\mathbf {k} )\mathbf{q}^{-1}}

On peut prouver que l’on obtient l’inverse d’un quaternion unitaire simplement en changeant le signe de ses coordonnées imaginaires. Autrement dit{\displaystyle \mathbf{q}^{-1}={\frac {1-\mathbf {i} -\mathbf {j} -\mathbf {k} }{2}}} et donc f(a\mathbf {i} +b\mathbf {j} +c\mathbf {k} ) s’ecrit {\displaystyle {\frac {1+\mathbf {i} +\mathbf {j} +\mathbf {k} }{2}}(a\mathbf {i} +b\mathbf {j} +c\mathbf {k} ){\frac {1-\mathbf {i} -\mathbf {j} -\mathbf {k} }{2}}} En appliquant les règles ordinaires de calcul avec les quaternions, on obtient {\displaystyle f(a\mathbf {i} +b\mathbf {j} +c\mathbf {k} )=c\mathbf {i} +a\mathbf {j} +b\mathbf {k} } Ah oui, et de la même manière qu’on peut associer une matrice 2\times2 à un nombre complexez=a+b\mathbf{i} ~\rightarrow~\begin{pmatrix}a&-b\\b&a\end{pmatrix} on peut associer une matrice 4\times4 à un quaternion\mathbf{q}=a+b\mathbf{i}+c\mathbf{j}+d\mathbf{k} ~\rightarrow~\begin{pmatrix}\quad a&\quad -b&\quad -c&\quad -d\\\quad b&\quad a&\quad -d&\quad c\\\quad c&\quad d&\quad a&\quad -b\\\quad d&\quad -c&\quad b&\quad a\end{pmatrix} (on peut aussi passer par unE matrice 2\times2 à coefficients complexes, mais ça ne servirait qu’à compliquer, ici).

On a vu qu’on pouvait associer une rotation à un quaternion, et un quaternion à une matrice. Si la rotation est d’axe \vec {OM}, où O est le centre de la terre, et M un point sur la surface terrestre, décrit par sa latitude et sa longitude, avec pour angle \alpha (comme décrit dans un billet sur stackoverflow), on a la fonction R suivante

quat = function(lat,long,ang=NA){
  n = length(lat)
  lat = lat/180*pi
  long = long/180*pi
  x = cos(lat) * cos(long)
  y = cos(lat) * sin(long)
  z = sin(lat)
  if (is.na(ang)){
    Q = matrix(c(x,y,z,rep(0,n)), ncol = 4)
  } else {
    Q = matrix(c(sin(ang/2*pi/180) * c(x,y,z), cos(ang/2*pi/180)), ncol =4)
  }
  return(Q)
}

avec la réciproque, permettant de passer d’un quaternion à une rotation, avec une description de l’axe comme auparavant (un point sur la sphère – sur le globe terrestre) et un angle (coordonnées polaires)

polaire = function(Q, digits=2) {
Q = Q/norme(Q)
ang = round(acos(Q[4])*2*180/pi,digits)
n = norme(Q[1:3])
x = Q[1]/n
y = Q[2]/n
z = Q[3]/n
lat = asin(z) * 180/pi
if (z**2 == 1){
long = 0
}  
else {
phi = (x+1i*y)/sqrt(1-z**2)
long = Im(log(phi)) * 180/pi 
}
c(lat,long,ang)
}

à condition de définir au préalable la norme du quaternion

norme = function(Q){
  sqrt(sum(Q**2))
}

On peut aussi définir le produits de quaternion (toutes les opérations sont décrites dans la page wikipedia), qui sera noté \otimes par la suite

pdt_quat = function(Q1,Q2){
  Q=rep(0,4)
  Q[1:3]  = Q1[4]*Q2[1:3]+Q2[4]*Q1[1:3]+pdt_vect(Q1[1:3],Q2[1:3])
  Q[4] = Q1[4]*Q2[4] - pdt_scal(Q1[1:3],Q2[1:3])
  return(Q)
}

mais aussi un produit scalaire

pdt_scal = function(M,N){
  return(sum(M*N))
}

un produit vectoriel

pdt_vect = function(M,N){
  return(c(M[2]*N[3]-M[3]*N[2],
           M[3]*N[1]-M[1]*N[3],
           M[1]*N[2]-M[2]*N[1]))
}

et finalement l’inverse du quaternion \mathbf{q}^{-1}

inv_quat = function(Q){
  (c(0,0,0,2*Q[4])-Q)/norme(Q)
}

On peut aussi demander les coordonnées d’un point M' obtenu comme transformation d’un point M par la rotation \mathbf{q}

rotation = function(M, Q){
polaire(pdt_quat(pdt_quat(Q,M),inv_quat(Q)))[1:2]
}

Maintenant, on va pouvoir passer aux choses sérieuses….

Je l’ai évoqué en introduction, les quaternions peuvent permettre de contourner certains problèmes, comme manipuler des objets (comme la calotte glaciaire) qui sont situés autour du pole (qui est un point de singularité dans la représentation par coordonnées polaires). Une autre application, présentée par François, est celle du déplacement des plaques tectoniques. En particulier, on peut utiliser un fichier de rotations des plaques tectoniques entre aujourd’hui et une certaine date dans le passé (cette idée se retrouve dans le projet gplates programmé avec des librairies python). Ou plus généralement entre deux dates, t_1 et t_2. Le fichier a notre disposition contient ainsi des quaternions \mathbf{q}^{P_0}_{t,P} pour une date t et une plaque P (défini comme un polygone décrit par une collection de latitudes et de longitudes), ou le deplacement de la plaque est décrit relativement a la plaque P_0. Pour des soucis de calculs, on va supposer qu’on peut interpoler linéairement les quaternions,\mathbf{q}^{P_0}_{t,P}=(1-\lambda)\mathbf{q}^{P_0}_{t_1,P}+\lambda\mathbf{q}^{P_0}_{t_2,P}avec\lambda=\frac{t-t_1}{t_2-t_1}et que récursivement, on peut composer les rotations, au sens ou\mathbf{q}^{P_3}_{t,P_1}\mathbf{q}^{P_3}_{t,P_2}\otimes\mathbf{q}^{P_2}_{t,P_1}Aussi, a partir de notre fichier de rotations, on peut creer une fonction qui calcule l’ensemble des quaternions de rotation, pour les plaques plates données. A priori un quaternion \mathbf{q}^{P_0}_{t,P} ne sera calculé qu’une fois

projecteur = function(t,plates,rot){
  ll = length(plates)
  Q0 = matrix(rep(0,4),ll,4)
  for (i in seq(ll)){ 
    cur_plate = i
    Q = c(0,0,0,1)
    while(cur_plate &gt; 0){
  df = rot[rot$Start = t &amp; rot$plate == plates[cur_plate],]
  if (dim(df)[1] &gt; 0) {
  Q1 = Q0[cur_plate,]
  cur_plate = 0 
  if (norme(Q1)==0){
  Q_St = quat(df$lat_St, df$lon_St, df$ang_St)
  Q_End = quat(df$lat_End, df$lon_End, df$ang_End)
  periode = df$End - df$Start
  pct = 0
  if (periode &gt; 0) pct = min(max(0,(t - df$Start)/periode),1)
  Q1 = Q_St + pct * (Q_End - Q_St)
  cur_plate = which(plates==df$anchor)
  if (length(cur_plate) == 0) cur_plate = 0
  } 
  Q = pdt_quat(Q1,Q)
  } else {cur_plate = 0}
  }    
  Q0[i,] = Q
  }
  return(Q0)
}

On peut maintenant appliquer ces outils a des données. Ici, trois bases issues du site http://paleobiodb.org seront exploitées, pour visualiser ou les dinosaures vivaient :
– une base des collections recensant les sites de fouilles (et en particulier leur géolocalisation)
– une base d’occurrences recensant les spécimens trouvés, par collection
– une base des spécimens décrivant les spécimens de dinosaures.

site="http://paleobiodb.org/data1.2/"
req=".txt?datainfo&amp;rowcount&amp;max_ma=999&amp;min_ma=0"
limit = "" #"&amp;limit=100"
names = c("colls/list", "occs/taxa", "occs/list")
destfile = rep('',length(names))
for (i in 1:length(names)) {
  destfile[i] = paste0("data/",sub("/","_",names[i]),".csv")
  download.file(paste0(site,names[i],req,limit),destfile=destfile[i])
}

Pour les données de collection

collection = read.csv(destfile[1],skip=17,sep = ",", header = TRUE)
coll = select(collection, c(collection_no, lng, lat, max_ma, min_ma))
remove(collection)
names(coll) = c('no', 'lng', 'lat', 'max_ma', 'min_ma')

et pour les données d’occurrence

occurence = read.csv(destfile[3],skip=17, sep = ",", header = TRUE)
occ = select(occurence, c(occurrence_no, collection_no, accepted_no))
remove(occurence)
names(occ) = c('no', 'coll_no', 'taxo_no')

Les espèces que nous étudierons ici sont les dinosaures de l’ordre des Ornithischia et des Saurischia (qui incluent les grandes familles classiques de dinosaures – a ce que j’ai pu comprendre)

 taxonomie = read.csv(destfile[2],sep = ",", skip=20, header = TRUE)
    taxo = select(taxonomie,c(orig_no, accepted_rank, accepted_name, parent_no, container_no))
    remove(taxonomie)
    names(taxo) = c('N0', 'rang0', 'nom0', 'parent', 'container')
    taxo = taxo[!is.na(taxo$N0),]
    taxo["N1"]=as.character(taxo$container)
    taxo[taxo$container=='',]$N1 = as.character(taxo[taxo$container=='',]$parent)
    taxo$container = as.factor(taxo$container)
    taxo$parent = NULL
    taxo$container = NULL
    t0 = taxo
    i = 0
    while(dim(taxo[!is.na(taxo[paste0("N",i)]),])[1] &gt; 0){
      i = i+1
      colnames(t0) = c(paste0('N',i),paste0('rang',i), paste0('nom',i), paste0('N',i+1))
      taxo = merge(taxo,t0,all.x=TRUE)
      if (i==10) break
    }
    t1 = select(taxo,N0)
    for (niveau in levels(taxo$rang0)){
      if (niveau != ""){
        t1[niveau]=""
        for (j in seq(0,i)){
          test = which(taxo[paste0("rang",j)]==niveau) 
          t1[test,niveau] = as.character(taxo[test,paste0("nom",j)])
        }  
      }
    }
    taxo=t1[t1["unranked clade"%in%c("Ornithischia","Saurischia")],]
    head(taxo,5)

On peut alors fusionner nos bases

M1 = merge(occ,taxo, by.x=c('taxo_no'),by.y=c('N0'), all=FALSE)
M2 = merge(M1,coll,by.x=c('coll_no'),by.y=c('no'), all.x=TRUE)
paste(dim(M2)[1], "specimens étudiés")

ce qui donne 9771 spécimens

head(M2,5)
coll_no taxo_no     no class           family             genus
1    5195   55999 373398           Nodosauridae      Pawpawsaurus
2   10755   55580 130209       Chaoyangsauridae    Chaoyangsaurus 
3   10760   38561 144305        Dromaeosauridae                  
4   10764   66066 130295        Caudipterygidae       Caudipteryx
5   10764   66068 130294                        Protarchaeopteryx
  infraclass kingdom        order   phylum                   species
1                                 Chordata    Pawpawsaurus campbelli
2                                 Chordata     Chaoyangsaurus youngi
3                    Avetheropoda Chordata                          
4                    Avetheropoda Chordata          Caudipteryx zoui
5                    Avetheropoda Chordata Protarchaeopteryx robusta
  subclass subfamily subgenus suborder subspecies superclass superfamily
1                                                                       
2                                                                       
3                                                                       
4                                                                       
5                                                                       
  superphylum tribe unranked clade      lng      lat max_ma min_ma
1                     Ornithischia -97.3000 32.86667  105.3  99.60
2                     Ornithischia 123.9667 42.93330  150.8 132.90
3                       Saurischia  21.0500 46.11667   70.6  66.00
4                       Saurischia 120.7333 41.80000  130.0 122.46
5                       Saurischia 120.7333 41.80000  130.0 122.46

Voila pour les dinosaures. On peut maintenant chercher des informations sur les plaques tectoniques,

chemin = "data/Shapefile"
download.file('https://www.earthbyte.org/webdav/ftp/earthbyte/GPlates/SampleData_GPlates2.0/Individual/FeatureCollections/Coastlines.zip', 'data/coastlines.zip')
coast_file = 'Matthews_etal_GPC_2016_Coastlines'
unzip(zipfile='data/coastlines.zip', exdir= chemin, junkpaths = TRUE)
continents = readOGR(dsn=chemin,layer=coast_file,verbose=TRUE)

Matthews et al. (2016) a mis en ligne un fichier de rotations simulant la dérive des plaques

download.file('https://www.earthbyte.org/webdav/ftp/earthbyte/GPlates/SampleData_GPlates2.0/Individual/FeatureCollections/Rotations.zip', 'data/rot.zip')
rot_file = 'Matthews_etal_GPC_2016_410-0Ma_GK07.rot'
unzip(zipfile='data/rot.zip', files = c(paste0('Rotations/',rot_file)), exdir= 'data', junkpaths = TRUE)
rot = paste0("data/",rot_file)

On va corriger quelques anomalies

x = readLines(rot)
y = gsub( "!101 !", "!", x )
cat(y, file=rot, sep="\n")
remove(x,y)

et on charge les données en mémoire (pour faire ensuite notre visualisation)

rot_file2 = read.csv(file=rot,header=FALSE,sep='', comment.char = '!')
ll = dim(rot_file2)[1]
rot_file3 = cbind(rot_file2[1:ll-1,],rot_file2[2:ll,])
names(rot_file3) = c('plate','Start','lat_St', 'lon_St', 'ang_St', 'anchor','plate2','End','lat_End', 'lon_End', 'ang_End', 'anchor2') 
rot_file = rot_file3[rot_file3$plate==rot_file3$plate2,]
rot_file$plate2 = NULL
rot_file$anchor2 = NULL
PLATES = sort(unique(rot_file$plate))

On ne va garder que les dinosaures qui peuvent etre rattaches à une plaque tectonique

X = M2%&gt;%select(lng, lat)
Y = SpatialPoints(X,proj4string = continents@proj4string)
plaques = over(Y,continents)$PLATEID1
filtre = which(!is.na(plaques))
X0       = X[filtre,]
NBX = dim(X0)[1]
print(paste0(NBX, " spécimens retenus"))

ce qui laisse quand même 9617 spécimens

PERIOD = M2%&gt;%select(max_ma, min_ma)
PERIOD  = PERIOD[filtre,]
plaques = plaques[filtre]
plaque_id = rep(0,NBX)
for (j in seq(1,NBX)){
    plaque_id[j]=which(PLATES==plaques[j])
}
dataX = M2[filtre,]
dataX["plaques"] = plaques

On y est presque… on va maintenant remonter de -250 millions d’annees a aujourd’hui, en faisant des bonds de 10 millions d’annees

TMAX = 250
TMIN = 0
PAS = 10

Pour toutes ces dates, on calcule les quaternions

ROT = array(rep(0,4),c(TMAX/PAS,length(PLATES),4))
for (t in seq(1,TMAX/PAS)){
  ROT[t,,] = projecteur(t*PAS, PLATES, rot_file)
}
QM = list()
plaque=list()
xy = list()
ll = length(continents@polygons)
for (i in seq(1,ll)){
  M = continents@polygons[[i]]@Polygons[[1]]@coords
  xy[[i]] = M
  QM[[i]] = quat(M[,2],M[,1])
  plaque[[i]] = which(PLATES==continents$PLATEID1[i])
}
QX = quat(X0[,2],X0[,1])

On va ensuite projeter

projete=list()
Xt = list()
X = X0
cpt = 0
for (TIME in seq(TMAX,TMIN,-PAS)){
  # setTxtProgressBar(pb, -TIME)
  cpt = cpt+1
  projete[[cpt]] = continents
  Xt[[cpt]] = X0
  if (TIME &gt; 0 ) {
    for (i in seq(1,ll)){
      M = xy[[i]]
      for (j in seq(1,dim(M)[1])){
        M[j,] = rev(rotation(QM[[i]][j,],ROT[TIME/PAS,plaque[[i]],]))
      }
      inf_180 = which(M[,1] &lt; -90); inf_180_ = length(inf_180)
      sup_180 = which(M[,1] &gt; 90); sup_180_ = length(sup_180)
      if (inf_180_ &gt; 0 &amp; sup_180_ &gt; 0) {
        if(sup_180_&gt;inf_180_) {
          M[inf_180,] = t(t(M[inf_180,]) + c(360,0))
        } else { M[sup_180,] = t(t(M[sup_180,]) - c(360,0))}
      } 
      projete[[cpt]]@polygons[[i]]@Polygons[[1]]@coords = M
    }
 
    # setTxtProgressBar(pb, -TIME + PAS/2)
    for (j in seq(1,NBX)){
      if (PERIOD$max_ma[j] &gt; TIME &amp; PERIOD$min_ma[j] &lt;= TIME){
        X[j,] = rev(rotation(QX[j,],ROT[TIME/PAS,plaque_id[j],]))
      } else{
        X[j,] = c(NA, NA)
      }
    }
    filtre = which(!is.na(X$lng))
    if (length(filtre) &gt; 0){
      Xt[[cpt]]=SpatialPointsDataFrame(coords = X[filtre,], data = dataX[filtre,])  
    } else {
      Xt[[cpt]]=X
    }
  }
}

On peut faire en première carte, 70 millions d’années avant notre ere

t = 1 + (TMAX-70)/PAS
leaflet(options = leafletOptions(minZoom = 1)) %&gt;%  
  addPolygons(data=projete[[t]], weight=2) %&gt;% 
  addMarkers(data = Xt[[t]], 
             popup = ~paste(sep = "
", paste("espèce :", Xt[[t]]$species),
                            paste("genre :", Xt[[t]]$genus),
                            paste("famille :", Xt[[t]]$family),
                            paste("ordre : ", Xt[[t]]["unranked clade",]) ),
             icon = dinoIcon)

Je mets ici une copie d’écran du leaflet ainsi créé

(l’idée est qu’on peut zoomer, ce qui rend l’analyse plus interactive)

Mais on peut aussi aller 200 millions d’années avant notre ere

t = 1 + (TMAX-200)/PAS
leaflet(options = leafletOptions(minZoom = 1)) %&gt;%  
  addPolygons(data=projete[[t]], weight=2) %&gt;% 
  addMarkers(data = Xt[[t]], 
             popup = ~paste(sep = "
", paste("espèce :", Xt[[t]]$species),
                            paste("genre :", Xt[[t]]$genus),
                            paste("famille :", Xt[[t]]$family),
                            paste("ordre : ", Xt[[t]]["unranked clade",]) ),
             icon = dinoIcon)

Amusant, non ? en tout cas, merci François pour cette jolie application des quaternions ! Et merci d’avoir suggéré d’utiliser autre chose que des points rouges sur une carte !

dinoIcon = makeIcon(iconUrl = "https://www.ludeek.com/wp-content/uploads/2015/03/uploadfsdfsdf1426350179.1426350368774.png",
                    iconWidth = 30, iconHeight = 50,
                    iconAnchorX = 15, iconAnchorY = 25)

Le sport en France

Je voulais profiter de la rentree pour mettre en ligne quelques billets sur la data science (comme on dit), en particulier en me basant sur des projets R de la formation en Data Science pour l’Actuariat. L’an passe, j’avais déjà mis en ligne un billet sur le sport (“le sport, une activité de riches“). Cette fois, en m’inspirant de ce qu’a proposé Benoit, on va regarder qui sont les licenciés des différentes fédérations sportives, et ou ils vivent. Comme toujours en R, on charge les librairies qu’on va utiliser…

library(rgdal)
library(sp)
library(reshape2)
library(data.table)
library(ggplot2)
library(gridExtra)
library(ggmap)
library(RColorBrewer)
library(classInt)
library(backports)
library(OpenStreetMap)

J’ouvre une parenthèse rapide, mais en pratique on sait rarement ce qui va servir… ex-post, on va les ramener ce chargement de librairies au début. Je pense que ça serait mieux de les charger juste quand on les utilise. Bon, ensuite, il faut les donnees

Url_Licences = "https://www.data.gouv.fr/s/resources/recensement-des-licences-et-clubs-aupres-des-federations-sportives-agreees-par-le-ministere-charge-d/20180131-163516/Licences_2015.csv"
Licences_2015 = read.csv(file=Url_licences, header=TRUE, sep=",",stringsAsFactors = FALSE) 
Url_Federation = "http://freakonometrics.free.fr/Projet_R/Code_federation.csv"
Code_Fede = read.csv(Url_Federation, sep=";",header=FALSE, skip=3)
colnames(Code_Fede) = c("Code_Federation","Libelle_Federation")

On change ici le nom des variables, ça sera plus simple ensuite, et on retient juste quelques lignes interessantes

Code_Fede = Code_Fede[c(1:31,33:92),c(1:2)]

Il faut ensuite les coordonnées des villes pour faire une carte

Commune = read.csv(file="https://www.data.gouv.fr/fr/datasets/r/554590ab-ae62-40ac-8353-ee75162c05ee", sep=";", header=TRUE)

En fait, juste la latitude de la longitude nous interesse

Geocod = colsplit(Commune$coordonnees_gps, ",", c("Latitude", "Longitude"))
Commune = data.frame(Commune,Geocod)

Un peu de menage ne fera pas de mal

Commune$Ligne_5 = NULL
Commune$coordonnees_gps = NULL
doublons = which(duplicated(Commune$Code_commune_INSEE)) #détecte les lignes où il y a doublon
Commune_Indiv = Commune[-doublons,]

On rajoute maintenant un libelle pour chaque sport

Licences_2015 = merge(x=Licences_2015, y=Code_Fede, by.x="fed_2014", by.y="Code_Federation", all.y=TRUE)

Et on supprime également les lignes ou les codes commune ne sont pas renseignés (car les données ne seront pas exploitables)

Licences_2015 = Licences_2015[!is.na(Licences_2015$newcog2),]

On a besoin de faire un peu attention a Paris et Marseille, car on a des données par arrondissement,

for (i in 1:nrow(Licences_2015)){
  if (Licences_2015[i,c("newcog2")]=="75056") {
    (Licences_2015[i,c("newcog2")] = "75101")}
  if (Licences_2015[i,c("newcog2")]=="13055") {
    (Licences_2015[i,c("newcog2")] = "13101")}}
Licences_2015 = merge(x=Licences_2015, y=Commune_Indiv, by.x="newcog2", by.y="Code_commune_INSEE", all.x=TRUE)

On y est presque. On va créer la variable taux de licenciés (nombre de licences rapporté a la population) pour chaque commune

Licences_2015$Taux_Licencies = ifelse(Licences_2015$pop_2014 != 0,Licences_2015$l_2015/Licences_2015$pop_2014,0)

Maintenant, on peut jouer ! Ou presque… reste a faire quelques regroupements en fonction de ce qu’on veut représenter.

df_Nb_Lic_Agg_Fed = aggregate(data.frame(
Nb_Licence = Licences_2015$l_2015,
Nb_hommes = Licences_2015$l_h_2015,
Nb_femmes = Licences_2015$l_f_2015,
NbLicences_0_4_Ans=Licences_2015$l_0_4_2015,
NbLicences_5_9_Ans=Licences_2015$l_5_9_2015,
NbLicences_10_14_Ans=Licences_2015$l_10_14_2015,
NbLicences_15_19_Ans=Licences_2015$l_15_19_2015,
NbLicences_20_29_Ans=Licences_2015$l_20_29_2015,
NbLicences_30_44_Ans=Licences_2015$l_30_44_2015,
NbLicences_45_59_Ans=Licences_2015$l_45_59_2015,
NbLicences_60_74_Ans=Licences_2015$l_60_74_2015,
NbLicences_75_Ans=Licences_2015$l_75_2015,
Nb_0_4_Ans=Licences_2015$pop_0_4_2014,
Nb_5_9_Ans=Licences_2015$pop_5_9_2014,
Nb_10_14_Ans=Licences_2015$pop_10_14_2014,
Nb_15_19_Ans=Licences_2015$pop_15_19_2014,
Nb_20_29_Ans=Licences_2015$pop_20_29_2014,
Nb_30_44_Ans=Licences_2015$pop_30_44_2014,
Nb_45_59_Ans=Licences_2015$pop_45_59_2014,
Nb_60_74_Ans=Licences_2015$pop_60_74_2014,
Nb_75_Ans=Licences_2015$pop_75_2014,
Pop_femmes=Licences_2015$popf_2014,
Pop_hommes=Licences_2015$poph_2014,
Pop_Totale=Licences_2015$pop_2014), 
by = list(Federation = Licences_2015$Libelle_Federation), sum, na.rm = TRUE)

On peut ainsi calculer le “taux de féminisation” de chaque sport

df_Nb_Lic_Agg_Fed$tx_femmes = ifelse(df_Nb_Lic_Agg_Fed$Nb_Licence!=0,df_Nb_Lic_Agg_Fed$Nb_femmes/df_Nb_Lic_Agg_Fed$Nb_Licence,0)

ou la répartition par classe d’âge du nombre de licenciés par fédération

df_Nb_Lic_Agg_Fed$Nb_Licence_Norme = 
  df_Nb_Lic_Agg_Fed$NbLicences_0_4_Ans+
  df_Nb_Lic_Agg_Fed$NbLicences_5_9_Ans+
  df_Nb_Lic_Agg_Fed$NbLicences_10_14_Ans+
  df_Nb_Lic_Agg_Fed$NbLicences_15_19_Ans+
  df_Nb_Lic_Agg_Fed$NbLicences_20_29_Ans+
  df_Nb_Lic_Agg_Fed$NbLicences_30_44_Ans+
  df_Nb_Lic_Agg_Fed$NbLicences_45_59_Ans+
  df_Nb_Lic_Agg_Fed$NbLicences_60_74_Ans+
  df_Nb_Lic_Agg_Fed$NbLicences_75_Ans

Pour la classe d’age 0-14 ans, on pose alors

df_Nb_Lic_Agg_Fed$Tx_Licences_0_14_Ans = ifelse(df_Nb_Lic_Agg_Fed$Nb_Licence_Norme != 0,      (df_Nb_Lic_Agg_Fed$NbLicences_0_4_Ans+df_Nb_Lic_Agg_Fed$NbLicences_5_9_Ans+df_Nb_Lic_Agg_Fed$NbLicences_10_14_Ans)/df_Nb_Lic_Agg_Fed$Nb_Licence_Norme,0)

et pour la classe d’age 15-29 ans

df_Nb_Lic_Agg_Fed$Tx_Licences_15_29_Ans = ifelse(df_Nb_Lic_Agg_Fed$Nb_Licence_Norme != 0,
(df_Nb_Lic_Agg_Fed$NbLicences_15_19_Ans+
df_Nb_Lic_Agg_Fed$NbLicences_20_29_Ans)/df_Nb_Lic_Agg_Fed$Nb_Licence_Norme,0)

pour la classe d’age 30-44 ans

df_Nb_Lic_Agg_Fed$Tx_Licences_30_44_Ans = ifelse(df_Nb_Lic_Agg_Fed$Nb_Licence_Norme != 0,(df_Nb_Lic_Agg_Fed$NbLicences_30_44_Ans)/df_Nb_Lic_Agg_Fed$Nb_Licence_Norme,0)

pour la classe d’age 45-59 ans

df_Nb_Lic_Agg_Fed$Tx_Licences_45_59_Ans = ifelse(df_Nb_Lic_Agg_Fed$Nb_Licence_Norme != 0,                                        (df_Nb_Lic_Agg_Fed$NbLicences_45_59_Ans)/df_Nb_Lic_Agg_Fed$Nb_Licence_Norme,0)

pour la classe d’age 60 ans et plus (on a compris le truc)

df_Nb_Lic_Agg_Fed$Tx_Licences_60_Ans = ifelse(df_Nb_Lic_Agg_Fed$Nb_Licence_Norme != 0, (df_Nb_Lic_Agg_Fed$NbLicences_60_74_Ans+ df_Nb_Lic_Agg_Fed$NbLicences_75_Ans)/df_Nb_Lic_Agg_Fed$Nb_Licence_Norme,0)

On passe a la détermination des 25 premières fédérations en nombre de licenciés

dt_Nb_Lic_Agg_Fed = data.table(df_Nb_Lic_Agg_Fed)
setorder(dt_Nb_Lic_Agg_Fed,-Nb_Licence,na.last=TRUE)
dt_Nb_Lic_Agg_Main_Fed = dt_Nb_Lic_Agg_Fed[1:25,]
graph1 = ggplot(data=dt_Nb_Lic_Agg_Main_Fed, aes(x=reorder(Federation,Nb_Licence), y=Nb_Licence)) + 
  geom_bar(stat="Identity",fill = "blue")+
  geom_text(aes(label=Nb_Licence),check_overlap = TRUE, vjust=0.5, hjust=0, color="blue")+
  ggtitle("TOP 25 des fédérations sportives en termes de licenciés")+
  ylim(0, 2500000)+
  xlab("Fédérations") + ylab("Nombre de licences")
graph1+coord_flip()

On ordonne ensuite par taux de femmes,

setorder(dt_Nb_Lic_Agg_Main_Fed,-tx_femmes,na.last=TRUE)
graph2 = ggplot(data=dt_Nb_Lic_Agg_Main_Fed) +
  aes(x =reorder(Federation,tx_femmes), y = tx_femmes) + geom_bar(stat="Identity",fill = "pink")+
geom_text(aes(label=paste(round(100*tx_femmes, 0), "%", sep="")),check_overlap = TRUE, vjust=0.5, hjust=0.5, color="black")+
xlab("Fédération") + ylab("part des licenciées femmes")+
ggtitle("la pratique sportive féminine par fédération")  
graph2+coord_flip()

Et finalement on va regarder par classe d’age

df_Nb_Lic_Agg_Main_Fed = data.frame(dt_Nb_Lic_Agg_Main_Fed)
Licence_Age = melt(df_Nb_Lic_Agg_Main_Fed, id=c("Federation"), measured=c("Tx_Licences_0_14_Ans","Tx_Licences_15_29_Ans", "Tx_Licences_30_44_Ans", "Tx_Licences_45_59_Ans","Tx_Licences_60_Ans"))
Licence_Age_Clean = Licence_Age[(Licence_Age$variable=="Tx_Licences_0_14_Ans" |       Licence_Age$variable=="Tx_Licences_15_29_Ans" | Licence_Age$variable=="Tx_Licences_30_44_Ans" |
Licence_Age$variable=="Tx_Licences_45_59_Ans" |
Licence_Age$variable=="Tx_Licences_60_Ans"),]  
dt_Licence_Age_Clean = data.table(Licence_Age_Clean)
setorder(dt_Licence_Age_Clean,-variable,na.last=TRUE)
setorder(Licence_Age_Clean,variable,na.last=TRUE)
graph3 = ggplot(data=Licence_Age_Clean, aes(x=Federation, y=value, fill=variable)) +
geom_bar(stat="identity")+
xlab("Fédération") + ylab("répartition par classe d'âge")+
ggtitle("Répartition des licenciés par classe d'âge")  
graph3+coord_flip()+scale_fill_brewer(palette="Paired")

A la lecture du graphique ci-dessus, les sports pourraient être classés en 3 catégories :

  • les “sports de jeunes” : ceux-ci ont plus de la motié de leurs licenciés âgés de moins de 15 ans : il s’agit de la gymnastique, du judo, du handball, de la natation, ou encore de la voile.
  • les “sports de vieux” : on retrouve ici sans surprise la randonnée, le cyclotourisme, le golf, la pétanque, le tir ou encore les sports sous-marins. Ceux-ci voient leurs licenciés avoir plus de 45 ans pour tois quart d’entre eux.
  • les “sports pour tous” qui correspondent à ceux qui n’ont pas encore été cités et pour lesquels classes d’âge apparaissent plus équilibrés

Finallement, on peut regarder quelques sports, sur une carte

map.France = get_map(location = c(lon=1.75, lat=46.70), zoom = 6)
Rugby_2015 = Licence_Max_2015[Licence_Max_2015$fed_2014=="133",]
Voile_2015 = Licence_Max_2015[Licence_Max_2015$fed_2014=="128",]
Ski_2015 = Licence_Max_2015[Licence_Max_2015$fed_2014=="121",]
PetanQ_2015 = Licence_Max_2015[Licence_Max_2015$fed_2014=="242",]
Rugby = ggmap(map.France, extent = "normal") +
  geom_point(aes(x = Longitude, y = Latitude), data = Rugby_2015, colour="red", alpha = 0.5, size=2.0, na.rm=TRUE)+
  theme_nothing(legend = TRUE) +
  theme(legend.position = "bottom")+
  ggtitle("Rugby")+
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5, color="red"))
Voile = ggmap(map.France, extent = "normal") +
  geom_point(aes(x = Longitude, y = Latitude), data = Voile_2015, colour="blue", alpha = 0.5, size=2.0, na.rm=TRUE)+
  theme_nothing(legend = TRUE) +
  theme(legend.position = "bottom")+
  ggtitle("Voile")+
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5, color="blue"))
Ski = ggmap(map.France, extent = "normal") +
  geom_point(aes(x = Longitude, y = Latitude), data = Ski_2015, colour="grey", alpha = 0.5, size=2.0, na.rm=TRUE)+
  theme_nothing(legend = TRUE) +
  theme(legend.position = "bottom")+
  ggtitle("Ski")+
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5, color="grey"))
Petanque = ggmap(map.France, extent = "normal") +
  geom_point(aes(x = Longitude, y = Latitude), data = PetanQ_2015, colour="chocolate3", alpha = 0.5, size=2.0, na.rm=TRUE)+
  theme_nothing(legend = TRUE) +
  theme(legend.position = "bottom")+
  ggtitle("pétanque et jeu provençal")+
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5, color="chocolate3"))
grid.arrange(Rugby,Voile,Ski,Petanque, ncol=2, nrow = 2,top="visualisation géographique de sports \n à fort ancrage régional")

Amusant, non?

(A brief) history of randomness, and simulation techniques

Hearing “there is a 10% chance of rain today” or “the medical test has a positive predictive value of 75%” shows that the probabilities are now everywhere. A probability is a quantity that is difficult to grasp, but essential when trying to theorize and measure chance, or randomness. And if mathematical theory finally came very late, as Hacking (2006) points out, this did not prevent insurance from developing early enough, and from having the first (actuarial) mortality tables even before the “probability of death” or “life expectancy” had a mathematical basis. And in the same way, many techniques were invented to “generate randomness“, before the explosion of the so-called Monte Carlo methods, in parallel with the development of computing (and the fact that a machine could generate chance). Continue reading (A brief) history of randomness, and simulation techniques

(Petite) histoire du hasard et de la simulation

Entendre « il y a 10% de chances de pluie aujourd’hui » ou « le test médical a une valeur prédictive positive de 75% » montre que les probabilités sont aujourd’hui partout[i]. Une probabilité est une grandeur difficile à appréhender, mais incontournable quand on cherche à théoriser et mesurer le hasard. Et si la théorie mathématique est finalement arrivée très tard, comme le rappelle Hacking (2006), cela n’a pas empêché l’assurance de se développer assez tôt, et d’avoir les premières tables (actuarielles) de mortalité avant même que la « probabilité de décès » ou « l’espérance de vie » n’ait de fondement mathématique. Et de la même manière, de nombreuses techniques ont été inventées pour « générer du hasard », avant l’explosion des méthodes dites de Monte Carlo, en parallèle avec le développement de l’informatique (et du fait qu’une machine pouvait générer du hasard). Continue reading (Petite) histoire du hasard et de la simulation