Tag Archives: computer

How long could it take to run a regression

This afternoon, while I was discussing with Montserrat (aka @mguillen_estany) we were wondering how long it might take to run a regression model. More specifically, how long it might take if we use a Bayesian approach. My guess was that the time should probably be linear in , the number of observations. But I thought I would be good to check.

Let us generate a big dataset, with one million rows,

> n=1e6
> X=runif(n)
> Y=2+5*X+rnorm(n)
> B=data.frame(X,Y)

Consider as a benchmark the standard linear regression,

> lm_freq = function(n){
+   idx = sample(1:1e6,size=n)
+   reg = lm(Y~X,data=B[idx,])
+   summary(reg)
+ }

Here the regression is a subset of smaller size. We can do the same with a Bayesian approach, using stan,

> stan_lm ="
+ data {
+ int N;
+ vector[N] x;
+ vector[N] y;
+ }
+ parameters {
+ real alpha;
+ real beta;
+ real tau;
+ }
+ transformed parameters {
+ real sigma;
+ sigma <- 1 / sqrt(tau);
+ }
+ model{
+ y ~ normal(alpha + beta * x, sigma);
+ alpha ~ normal(0, 10);
+ beta ~ normal(0, 10);
+ tau ~ gamma(0.001, 0.001);
+ }
+ "

Define then the model

> library(rstan)
> system.time( 
  stanmodel <<- stan_model(model_code = stan_lm))
utilisateur     système      écoulé 
      0.043       0.000       0.043

We want to see how long it might take to run a regression,

> lm_bayes = function(n){
+   idx = sample(1:1e6,size=n)
+   fit = sampling(stanmodel,
+       data = list(N=n,
+                   x=X[idx],
+                   y=Y[idx]),
+       iter = 1000, warmup=200)
+   summary(fit)
+ }

We use the following package to see how long it takes

> library(microbenchmark)
> time_lm = function(n){
+  M = microbenchmark(lm_freq(n),
+      lm_bayes(n),times=50)
+  return(apply( matrix(M$time,nrow=2),1,mean))
+ }

We can now compare the time it took with ten, one hundred, on thousand, and ten thousand observations,

> vN = c(10,100,1000,10000)
> T = Vectorize(time_lm)(vN)

we can then plot it

> plot(vN,T[2,]/1e6,log="xy",col="red",type="b",
+      xlab="Number of Observations",ylab="Time")
> lines(vN,T[1,]/1e6,col="blue",type="b")

It looks like (if we forget about the very small sample) that the time it takes to run a regression is linear, with the two techniques (the frequentist and the Bayesian ones).

And actually, the same story olds for logistic regressions. Consider the following dataset

> n=1e6
> X=runif(n)
> S=-3+2*X+rnorm(n)
> Y=rbinom(n,size=1,prob=exp(S)/(1+exp(S)))
> B=data.frame(X,Y)

The frequentist version of the logistic regression is

> glm_freq = function(n){
+   idx = sample(1:1e6,size=n)
+   reg = glm(Y~X,data=B[idx,],family=binomial)
+   summary(reg)
+ }

and the Bayesian one, using stan,

> stan_glm = "
+ data {
+ int N;
+ vector[N] x;
+ int<lower=0,upper=1> y[N];
+ }
+ parameters {
+ real alpha;
+ real beta;
+ }
+ model {
+ alpha ~ normal(0, 10);
+ beta ~ normal(0, 10);
+ y ~ bernoulli_logit(alpha + beta * x);
+ }
+ "
> stanmodel = stan_model(model_code = stan_glm) )
> glm_bayes = function(n){
+   idx = sample(1:1e6,size=n)
+   fit = sampling(stanmodel,
+        data = list(N=n,
+        x = X[idx],
+        y = Y[idx]),
+        iter = 1000, warmup=200)
+   summary(fit)
+ }

Again, we can see how long it takes to run those regression models

> time_gl m= function(n){
+   M = microbenchmark(glm_freq(n),
+   glm_bayes(n),times=50)
+   return(apply( matrix(M$time,nrow=2),1,mean))
+ }

 

Where People Live, part 2

Following my previous post, I wanted to use another dataset to visualize where people live, on Earth. The dataset is coming from sedac.ciesin.columbia.edu. We you register, you can download the database

> base=read.table("glp00ag15.asc",skip=6)

The database is a ‘big’ 1440×572 matrix, in each cell (latitude and longitude) we have the population

>  X=t(as.matrix(base,ncol=1440))
>  dim(X)
[1] 1440  572

The dataset looks like

> image(seq(-180,180,length=nrow(X)),
+ seq(-90,90,length=ncol(X)),
+ log(X+1)[,ncol(X):1],col=rev(heat.colors(101)),
+ axes=FALSE,xlab="",ylab="")

Now, if we keep only place where people actually live (i.e. removing cold desert and oceans) we get

> M=X>0
> image(seq(-180,180,length=nrow(X)),
+ seq(-90,90,length=ncol(X)),
+ M[,ncol(X):1],col=c("white","light green"),
+ axes=FALSE,xlab="",ylab="")

Then, we can visualize where 50% of the population lives,

> Order=matrix(rank(X,ties.method="average"),
+ nrow(X),ncol(X))
> idx=cumsum(sort(as.numeric(X),
+ decreasing=TRUE))/sum(X)
> M=(X>0)+(Order>length(X)-min(which(idx>.5)))
> image(seq(-180,180,length=nrow(X)), + seq(-90,90,length=ncol(X)), + M[,ncol(X):1],col=c("white",
+ "light green",col="red"), + axes=FALSE,xlab="",ylab="")

50% of the population lives in the red area, and 50% in the green area. More precisely, 50% of the population lives on 0.75% of the Earth,

> table(M)/length(X)*100
M
         0          1          2 
69.6233974 29.6267968  0.7498057

And 90% of the population lives in the red area below (5% of the surface of the Earth)

> M=(X>0)+(Order>length(X)-min(which(idx>.9)))
> table(M)/length(X)*100
M
        0         1         2 
69.623397 25.512335  4.864268 
> image(seq(-180,180,length=nrow(X)),
+ seq(-90,90,length=ncol(X)),
+ M[,ncol(X):1],col=c("white",
+ "light green",col="red"),
+ axes=FALSE,xlab="",ylab="")

Supports de cours en R

Lundi, second cours de R pour la formation Actuaire: Data Science. Pour la première fois, je quitte mon format de slides (au format pdf) pour autre chose. Plus pratique pour présenter du code R. Une solution est de passer par R Markdown, et plus spécifiquement Slidify (qui permet de créer des slides)

On a un document, dans l’éditeur de RStudio, et la structure est assez simple. On a un préambule, et ensuite du texte,

C’est du Markdown, tout simplement. Mais on peut aussi mettre du code R, pour générer des tableaux, des sorties, des graphes,

Ensuite, au  lieu de faire run pour exécuter le code, on utilise Knit HTML, qui va permettre de générer les slides

Plus précisément, ces derniers vont s’ouvrir dans une fenêtre RStudio, mais qu’on peut aussi visualiser dans un browser,

C’est  avec ces fonctions que les slides ont été générés.

Une autre solution est de passer par Jupyter. L’installation prend un peu de temps (mais c’est relativement bien documenté). En lançant Jupyter, on crée un notebook en R,

Par défaut, on a un premier bloc de lignes de commandes

Pour en rajouter avant, ou après, rien de plus simple

On a alors un second blog, après l’affichage d’une sortie de régression, afin de générer un graphique

On peut soit garder les instructions, telles quelles, soit les exécuter, afin de visualiser les sorties

qui peuvent être des sorties de régression, ou des graphiques

On peut aussi insérer des blocs qui seront un Markdown (du texte, quoi), et pas seulement du code

On peut par exemple insérer un ‘titre’ de section

Et là encore, on exécute, pour afficher.

Cette année, pour mon cours de R, j’ai opté pour Slidify, mais peut être que Jupyter pourrait être une alternative intéressante, pour rendre le cours plus interactif. On en reparlera…

Prévision de l’intérêt pour le chocolat, avec des modèles ARIMA

Hier en cours, on s’était lancé sur la prévision de la série obtenue sur Google Trends pour le mot clé “chocolat“. La série est la suivante

> url = "http://freakonometrics.free.fr/report-chocolat.csv"
> report = read.csv(url,skip=6,
+ header=FALSE,nrows=636)
> X=report$V2
> plot(X,type="l")

Comme on l’avait évoqué, c’est plus simple de construire un modèle ARIMA sur des séries mensuelles qu’hebdomadaire. Donc on va mensualiser la série. Ah oui, on va aussi enlever les deux dernières années pour faire une comparaison de modèles (en confrontant les prévision avec les observations)

> date1=substr(as.character(report$V1),1,10)
> date2=substr(as.character(report$V1),14,23) 
> d1=as.Date(date1,"%Y-%m-%d")
> d2=as.Date(date2,"%Y-%m-%d")
> Vect_J=Vect_M=Vect_X=Vect_A= NULL
> for(i in 1:length(d1)){
+   jours = seq(d1[i],d2[i],length=7)
+   mois = as.POSIXlt(jours)$mon+1
+   annees = as.POSIXlt(jours)$year+1900
+   donnees = rep(X[i],7)
+   Vect_J = c(Vect_J,jours)
+   Vect_M = c(Vect_M,mois)
+   Vect_A = c(Vect_A,annees)
+   Vect_X = c(Vect_X,donnees)
+ }
> base = data.frame(J = Vect_J,M = Vect_M,
+ A = Vect_A,X = Vect_X)
> base$AM = base$A*100+base$M
> Y = tapply(base$X,as.factor(base$AM),mean)
> Z = ts(as.numeric(Y[1:(146-24)]),
+ start=c(2004,1),frequency=12)
> plot(Z)

Compte tenu de l’amplitude croissante des cycles, il peut être intéressant, ici, de passer au logarithme de la série. Et comme on observe une rupture dans la tendance (linéaire au début, et relativement constante ensuite), on peut ajuste une régression linéaire avec une rupture (mais continue)

> plot(as.numeric(Z),type="l")
> X=log(as.numeric(Z))
> T=1:length(X)
> db=data.frame(X,T)
> trend=lm(X~T+I((T-80)*(T>80)),data=db)
> plot(X,type="l")
> lines(predict(trend),col="red")

C’est le résidu de cette série qu’on va chercher à modéliser,

> Y=residuals(trend)
> plot(Y,type="l")

Pour modéliser cette série, on peut commencer par regarder sa série d’autocorrélation

>  plot(acf(Y,lag=36),lwd=5)

et d’autocorrélation partielles,

> plot(pacf(Y,lag=36),lwd=5)

La série est stationnaire, mais il y a une composante cyclique forte (peut être une racine unité saisonnière ?). On peut tenter un premier modèle AR, ou ARMA (avec un AR les résidus ne sont pas un bruit blanc).

> model1 = arima(Y,order=c(12,0,12),
+ seasonal = list(order = c(0, 0, 0), period = 12))

La série des résidus est ici un bruit blanc

> E=residuals(model1)
> plot(acf(E,lag=36),lwd=5)

On peut alors utiliser ce modèle pour faire des prévisions, sur la série initiale (avant de prendre le logarithme, et d’ajuster une tendance)

> futur=length(X)+1:24
> Yp=predict(model1,n.ahead=24)$pred+
+    predict(trend,newdata=data.frame(T=futur))
> Xp=exp(as.numeric(
+   Yp+.5*predict(model1,n.ahead=24)$se^2))
> plot(as.numeric(Z),type="l",xlim=c(1,150))
> lines(futur,Xp,col="red")
> Y2=tapply(base$X,as.factor(base$AM),mean)
> obs_reel=as.numeric(Y2[(146-24)+1:24])
> lines(futur,obs_reel,col="blue")    

avec en rouge notre modèle, et en bleu les vraies observations. On peut alors calculer la somme des carrés des erreurs, sur ces 24 observations,

> sum( (obs_reel-Xp)^2 )
[1] 190.9722

Mais on peut tenter d’autres modèles, par exemple en changeant la tendance (on ne va pas le faire) ou en changeant le modèle ARIMA (en intégrant une racine unité saisonnière)

> model3=arima(Y,order=c(0,0,2),
+ seasonal = list(order = c(0, 1, 1), period = 12))
> E=residuals(model3)
> model3

Coefficients:
         ma1     ma2     sma1
      0.2246  0.3034  -0.9999
s.e.  0.0902  0.0925   0.3503

sigma^2 estimated as 0.002842:  log likelihood = 152.37,  aic = -296.75

On vérifie que les résidus sont effectivement un bruit blanc

> plot(acf(E,lag=36),lwd=5)
> Box.test(E,lag=12)

	Box-Pierce test

data:  E
X-squared = 6.326, df = 12, p-value = 0.8988

On peut alors faire une prévision sur notre série brute,

> futur=length(X)+1:24
> Yp=predict(model3,n.ahead=24)$pred+
+   predict(trend,newdata=data.frame(T=futur))
> Xp=exp(as.numeric(
+   Yp+.5*predict(model3,n.ahead=24)$se^2))
> plot(as.numeric(Z),type="l",xlim=c(1,150))
> lines(futur,as.numeric(Xp),col="red")
> Y2=tapply(base$X,as.factor(base$AM),mean)
> obs_reel=as.numeric(Y2[(146-24)+1:24])
> lines(futur,obs_reel,col="blue")

La somme des carrés des erreurs est ici un peu plus faible

> sum( (obs_reel-Xp)^2 )
[1] 173.8138

C’est à dire que ce second modèle est meilleur que le précédant, sur les deux dernières années. C’est probablement celui que l’on devrait utiliser pour faire des prévisions pour les années à venir (à moins qu’en continuant l’analyse on n’en trouve un meilleur).

R Crash Course, Data Science for Actuaries, Year 2

This Monday, we will start the second year of the Actuary: Data Science (ADS) program, supported by the (French) Institute of Actuaries. I will be there on monday morning for the opening, and we will start the R & Datamining course. The slides are now online,

In order to get nice slides, I have been using slidify. The R code is available online, as well as some pdf version of the slides.

Dynamique de la Pyramide des Ages

Très joli billet sur blog.revolutionanalytics.com avec un code de @kyle_e_walker permettant, très simplement (moyennant une inscription pour avoir une clé permettant d’utiliser l’API du census) de construire une pyramide des âges dynamiques.

> devtools::install_github('walkerke/idbr')
> library(idbr)
> library(ggplot2)
> library(animation)
> library(dplyr)
> library(ggthemes)
> idb_api_key("mykey1239F2f324zf9GGZgege32R2ii4")

On importe alors les données pour les hommes et les femmes,

> male <- idb1('FR', 2010:2050, sex = 'male') %>%
+   mutate(POP = POP * -1,
+   SEX = 'Male')
> female <- idb1('FR', 2010:2050, sex = 'female') %>% mutate(SEX = 'Female')

et on stocke le tout

> france <- rbind(male, female) %>%
+   mutate(abs_pop = abs(POP))

Ensuite, on crée l’animation,

> saveGIF({
+   
+   for (i in 2010:2050) {
+     
+     title <- as.character(i)
+     
+     year_data <- filter(france, time == i)
+     
+     g1 <- ggplot(year_data, aes(x = AGE, y = POP, fill = SEX, width = 1)) +
+       coord_fixed() + 
+       coord_flip() +
+       annotate('text', x = 98, y = -800000, 
+       label = 'Data: US Census Bureau IDB; idbr R package', size = 3) + 
+       geom_bar(data = subset(year_data, SEX == "Female"), stat = "identity") +
+       geom_bar(data = subset(year_data, SEX == "Male"), stat = "identity") +
+       scale_y_continuous(breaks = seq(-1000000, 1000000, 500000),
+       labels = paste0(as.character(c(seq(1, 0, -0.5), c(0.5, 1))), "m"), 
+       limits = c(min(france$POP), max(france$POP))) +
+       theme_economist(base_size = 14) + 
+       scale_fill_manual(values = c('#ff9896', '#d62728')) + 
+       ggtitle(paste0('Population structure of France, ', title)) + 
+       ylab('Population') + 
+       xlab('Age') + 
+       theme(legend.position = "bottom", legend.title = element_blank()) + 
+       guides(fill = guide_legend(reverse = TRUE))
+     print(g1) 
+   }
+ }, movie.name = 'france_pyramid.gif', interval = 0.1, ani.width = 700, ani.height = 600)

Et le résultat est vraiment joli, non ?

Taux d’intérêt négatifs et explosion des valeurs de rentes

Il y a quelques années, j’avais été sollicité pour rédiger les Annexes de l’ouvrage évaluation du préjudice corporel, de Max le Roy. Comme l’indiquait le descriptif du livre (à l’époque) j’ai un peu la pression car pas mal de jugements rendus sont basés sur mes calculs,

“La résolution 75-7 du comité des ministres du Conseil de l’Europe est intervenue pour faciliter l’harmonisation des législations et des jurisprudences en matière de réparation des dommages en cas de lésion corporelle ou de décès. Elle a proposé un certain nombre de principes qui, bien que non obligatoires pour les États membres, sont très largement suivis par les juridictions françaises. Ce sont ces principes et leur application en droit français qui sont exposés et commentés dans cet ouvrage qui rend compte, notamment, de la très importante réforme apportée en matière de recours subrogatoire des caisses de sécurité sociale contre les tiers par la loi n° 2006-1640 du 21 décembre 2006. Le barème de capitalisation de rentes tient compte des plus récentes tables de mortalité et prend pour base un taux d’intérêt de 5 % conforme aux données économiques et financières actuelles. Accompagné d’un barème fonctionnel indicatif des incapacités en droit commun, de tableaux de jurisprudence et de formules de jugement, l’ouvrage fait le point sur toutes les questions auxquelles sont confrontés les magistrats, avocats, experts, médecins, assureurs.”

En 2011, pour une mise à jour du livre, j’avais refait les calculs avec des tables mises à jours. Oui, à l’époque je trouvais que la priorité était d’arrêter d’utiliser les tables TD et TV qui dataient de 1988. Mais on était resté avec des taux à 5%. J’avais d’ailleurs été surpris (je peux le dire maintenant, il y a prescription) lorsque j’avais tenté de discuter le choix du taux d’intérêt, et qu’il m’avait été répondu “ah, ça change quelque chose ?“.

Oui, les taux d’actualisation impactent les valeurs des rentes. Et je n’avais pas idée à quel point. Le code utilisé pour construire les valeurs de rentes est assez simple.

> PRIX=function(annee=2011,age,sex="HOM",
+ taux=0.04, duree,C=1000){
+  file  = paste("http://freakonometrics.free.fr/",
+  sex,"-table-SPLx.csv",sep="")
+  B  = read.table(file,header=TRUE,sep=",")
+  an    = annee-age; if(an>2005){an=2005}
+  nom   = paste("X",an,sep="")
+  L     = B[,nom]
+  Q     = L[(age+1):length(L)]/L[(age+1)]
+  actualisation = (1+taux)^(0:min(duree,120-age))
+  prixsup = sum(Q[2:(min(duree,120-age)+1)]/
+  actualisation[2:(min(duree,120-age)+1)] )
+   prixinf = sum(Q[1:(min(duree,120-age))]/
+  actualisation[1:(min(duree,120-age))] )
+  return(C*c(prixsup,prixinf))}

Je renvois ici deux “prix” de rente, suivant que la rente est versée en fin ou en début d’année. Par exemple, avec un taux d’actualisation de 5% (comme dans le livre), pour un homme de 50 ans, si on considère une rente versée jusqu’à sa mort (j’ai mis ici une durée maximal de 150 années), la valeur actualisée espérée d’une rente (en tenant compte des probabilités de décès) de 1000 euros par an (encore une fois, tant que la personne est en vie) est de l’ordre de 17,000 euros.

> PRIX(age=50,sex="HOM",duree=150,taux=.05)
[1] 16435.31 17435.30

Avec un taux d’actualisation de 0%, on atteinte plus du double.

> PRIX(age=50,sex="HOM",duree=150,taux=0)
[1] 38822.48 39822.46

Et c’est encore pire pour les jeunes. Si on calcule pour plusieurs âges des rentes versées jusqu’au décès, avec différents niveaux de taux (5%, 2%, 0% et -2%, oui, je prends un taux négatif)

> vage=seq(15,65,by=5)
> vp5=Vectorize(function(a) PRIX(age=a,sex="HOM",duree=150,taux=0.05)[1])(vage)
> vp2=Vectorize(function(a) PRIX(age=a,sex="HOM",duree=150,taux=0.02)[1])(vage)
> vp0=Vectorize(function(a) PRIX(age=a,sex="HOM",duree=150,taux=0)[1])(vage)
> vpn2=Vectorize(function(a) PRIX(age=a,sex="HOM",duree=150,taux=-0.02)[1])(vage)
> plot(vage,vpn2,type="b",col="red")
> lines(vage,vp0,type="b")
> lines(vage,vp2,type="b",col="blue")
> legend("topright",c("taux -2%","taux 0%","taux 2%"),col=c("red","black","blue"))

on observe une explosion des rentes pour les jeunes (ce qui n’est pas non plus surprenant)

Pour un jeune de 20 ans, la valeur actualisée probable d’une rente est presque 10 fois plus élevée, si on passe d’un taux de 5% à -2%

> PRIX(age=15,sex="HOM",duree=150,taux=.05)
[1] 19427.94 20427.93
> PRIX(age=15,sex="HOM",duree=150,taux=-.02)
[1] 200778.3 201770.3

Ce qu’on peut visualiser sur le graphique ci-dessous (avec, par âge, 100 qui correspond à la valeur obtenue avec un taux de 5%)

> plot(vage,vpn2/vp5*100,type="b",col="red")
> lines(vage,vp0/vp5*100,type="b")
> lines(vage,vp2/vp5*100,type="b",col="blue")
> abline(h=100,lty=2)
> legend("topright",c("taux -2%","taux 0%","taux 2%"),col=c("red","black","blue"),pch=1)

Passer de 5% à 2% donnait des rentes plus important, en passant de 100 à 200. En passant à 0% on passe de 100 à 400 pour les jeunes. Mais en passant à des taux négatifs, on passe de 100 à 1000 !

Dans un scénarios où les taux restent encore bas longtemps, on peut imaginer que les indemnités versées aux victimes de préjudices corporels vont exploser dans les mois à venir…

Simple Distributions for Mixtures?

The idea of GLMs is that given some covariates has a distribution in the exponential family (Gaussian, Poisson, Gamma, etc). But that does not mean that  has a similar distribution… so there is no reason to test for a Gamma model for  before running a Gamma regression, for instance. But are there cases where it might work? That the non-conditional distribution is the same (same family at least) than the conditional ones?

For instance, if  has a joint Gaussien distribution, then both marginals are Gaussian, but also . So, in that case, if the covariate is normally distributed, it is possible to have a Gaussian distribution also for . The econometric interpretation is that with a standard Gaussian linear model, if is normally distributed, not only the conditional distribution  is Gaussian but also the non-conditional distribution of .

> set.seed(1)
> n=1e3
> X=rnorm(n,10,2)
> Y=1+3*X+rnorm(n)
> plot(X,Y,xlim=c(4,20))

Indeed, here the distribution of  is also Gaussian

> library(nortest)
> ad.test(Y)

	Anderson-Darling normality test

data:  Y
A = 0.23155, p-value = 0.802

> shapiro.test(Y)

	Shapiro-Wilk normality test

data:  Y
W = 0.99892, p-value = 0.8293

(not only from a statistical point of view, the thoery of Gaussian random vectors confirms that the non-conditional distribution is Gaussian actually)

Here  is continuous. What if we consider a finite mixture here, i.e. takes only a finite number of values? Actually, Teicher (1963) proved that it is not possible to have a non-conditional Gaussian distribution for . But in practice, would we really reject the Gaussian assumption, for ? If the number of classes is to small, yes. But with a large number of classes (a sufficiently large number of mixture components), it is possible,

> pv=function(k=2){
+ n=1e4
+ X=rnorm(n,10,2)
+ Q=quantile(X,(0:k)/k)
+ Q[1]=0
+ Xc=cut(X,Q,labels=1:k)
+ XcN=tapply(X,Xc,mean)
+ Xn=XcN[as.numeric(Xc)]
+ Y=1+3*Xn+rnorm(n)
+ ad.test(Y)$p.value}
 
> plot(2:100,Vectorize(pv)(2:100),type="l")
> abline(h=.05,col="red")

So here, it could be possible to have also a Gaussian distribution, for . As least to accept that assumption, statistically.

In the context of a Poisson regression, it is well know that it’s not possible to have at the same time  that is Poisson distributed (that’s a Poisson regression) and also  that is Poisson distributed. That simply comes from the fact that

while

and because of the conditional Poisson distribution, then

Thus,

So  cannot be Poisson distribution. But again, it could be possible, if heterogeneity is not too large, to accept the null assumption of a Poisson distribution for .

More generally, it is very difficult to have a distribution family for   that is also the distribution of the non-conditional variable . In the context of a finite mixture ( takes a finite number of values),Teicher (1963) proved that it was not not possible, neither for the Gaussian distribution nor the Gamma distribution. An to go further, check Monfrini (2002) (thanks Romuald for point out the reference).

Hence, as a keep saying, before running a regression model on with some given family, it is never a good idea to check if the non-conditional distribution  has the same distribution. Because there is no reason, usually, to remain in the same family.

Heuristics on Correspondance Analysis

This week, in the course on non-supervised techniques for data science, we’ve been using a dataset, with candidate for the presidential elections in 2002 (per row) and newpapers (per column). In order to visualize that dataset, consider three candidates, and three newspapers

> base=read.table(
"http://freakonometrics.free.fr/election2002.txt",header=TRUE)
> sb=base[,c(2,3,4)]
> sb=sb[c(4,12,7),]
> (N=sb)
       LeFigaro Liberation LeMonde
Jospin        7         41      26
Chirac       35          9      18
Mamere        1         10       7

The first part is based on a description of rows. Consider here rows are conditional probabilities, in the set of newspapers,

> (L=N/apply(N,1,sum))
         LeFigaro Liberation   LeMonde
Jospin 0.09459459  0.5540541 0.3513514
Chirac 0.56451613  0.1451613 0.2903226
Mamere 0.05555556  0.5555556 0.3888889

The “average row” is the marginal distribution of newspapers

> (Lbar=apply(N,2,sum)/sum(N))
  LeFigaro Liberation    LeMonde 
 0.2792208  0.3896104  0.3311688

If we visualize those individuals, in the set of newpapers (in the simplexe in the newspapers space), we have

Here it is,

But actually, we will not stay in the simplexe. A PCA is considered, with weights on individuals, that take into account the importance of the different candidates, and weights for the scalar product (in order to have a distance related to the chi-square distance, and not a standard Euclidean distance)

> matL0=t(t(L)-Lbar)
> library(FactoMineR)
> acpL=PCA(matL0,scale.unit=FALSE,
+   row.w=(apply(N,1,sum)),
+   col.w=1/(apply(N,2,sum)))
> plot.PCA(acpL,choix="ind",ylim=c(-.02,.02))

 

The second part is based on a description of columns. Here Columns are conditional probabilities, in the set of candidates,

> (C=t(t(N)/apply(N,2,sum)))
         LeFigaro Liberation   LeMonde
Jospin 0.16279070  0.6833333 0.5098039
Chirac 0.81395349  0.1500000 0.3529412
Mamere 0.02325581  0.1666667 0.1372549

Here again, we can compute the “average column”

> (Cbar=apply(N,1,sum)/sum(N))
   Jospin    Chirac    Mamere 
0.4805195 0.4025974 0.1168831

In the simplex, points are

i.e.

But here again, we won’t use that simplexe. We consider a PCA, with two vectors of weights, some to take into account the weights of the newspapers, and some to get a chi-square distance

> Cbar=apply(N,1,sum)/sum(N)
> matC0=C-Cbar
> acpC=PCA(t(matC0),scale.unit=FALSE,
+          row.w=(apply(N,2,sum)),
+          col.w=1/(apply(N,1,sum)))

 

Now, we can almost overlap the two projections. Almost because we might, sometime switch right and left, top and bottom. Because if  is a (unit) eigenvector, so is . Here, for instance, we should swich them

> CA(N)

Décomposition(s) de Séries Temporelles

La semaine dernière, pour le TP du cours de série temporelle, on avait parlé de décomposition de séries temporelles. On part d’une série temporelle , et on va considérer une décomposition de la forme

par exemple une tendance linéaire, et un cycle annuel,

Considérons la série suivante

> autoroute=read.table(
+ "http://freakonometrics.free.fr/autoroute.csv",
+ header=TRUE,sep=";")
>  a7=autoroute$a007
>  X=ts(a7,start = c(1989, 9), frequency = 12)

correspondant à du trafic sur l’autoroute (A7)

>  plot(X,xlim=c(1989,2000))

Pour estimer la tendance, on va faire une régression linéaire, sur le temps, à partir de la base suivante

>  T=time(X)
>  base=data.frame(Y=a7,X1=as.numeric(T))

Le modèle est ici

>  reg1=lm(Y~X1,data=base)

ce qui permet de faire une prévision sur les données passées, mais aussi futures,

>  tendance1=predict(reg1)
>  T=as.numeric(T)
>  lines(T,tendance1,col="red",lwd=3)
>  futur=seq(max(T)+1/12,length=36,by=1/12)
>  tendance2=predict(reg1,
+  newdata=data.frame(X1=futur))
>  lines(futur,tendance2,col="red")

Voilà pour la tendance. Pour le cycle, on va ajuste un modèle de la forme suivante

sur la série des résidus

>  base$Y2=residuals(reg1)

Cette fois, on va définir le mois de la date

> base$mois=round(base$X1-t
+ trunc(base$X1),digit=4)

Et on régresse le résidu sur le mois

>  reg2=lm(Y2~0+as.factor(mois),data=base)

Là encore, on peut faire une régression sur les données passées

>  cycle1=predict(reg2)
>  lines(T,tendance1+cycle1,col="blue",lwd=3)

mais aussi sur les données futures,

>  moisfutur=round(futur-trunc(futur),4)
>  cycle2=predict(reg2,newdata=
+  data.frame(mois=moisfutur))
>  lines(futur,tendance2+cycle2,col="blue")

Cela dit, pour les données futures, on peut aussi tenter de rajouter une région de confiance, en tenant compte de l’erreur d’ajustement,

>  E=residuals(reg2)
>  hist(E)
>  1.96*sqrt(var(E))
[1] 5637.897

On peut alors facilement ajouter notre région de confiance avec

> polygon(c(futur,rev(futur)),
+ c(tendance2+cycle2-1.96*sqrt(var(E)),
+ rev(tendance2+cycle2+1.96*sqrt(var(E)))),
+ col="yellow",border=NA)

Et voilà…. On peut quand même vérifier que le bruit est effectivement non-autocorrélé, et c’est le cas ici

>  plot(acf(E))

Comme on l’a vu en TP, ajuster une droite de régression c’est bien ici, mais peut être qu’on peut envisager un ajustement local. Par exemple prendre la moyenne autour de la date qui nous intéresse, +/- 6 mois (techniquement, si on rajoute 6 mois avant et après, on aura un soucis, alors on fait une petite correction au bord),

ce qui correspond à un lissage par moyenne mobile.

>  n=length(X)
>  F=rep(NA,n)
>  for(t in 7:(n-7)) F[t]=1/12*(sum(X[(t-5):(t+5)])+ (X[t-6]+X[t+6])/2)
>  lines(T,F,lwd=3,col="purple")

On voit ici – par notre ajustement non-paramétrique – que l’ajustement d’une tendance linéaire n’était pas si mauvais que ça

Par contre, pour des séries où la tendance n’est clairement pas linéaire, le lissage par moyenne mobile permet d’avoir une bonne estimation de la tendance de fond

> sncf=read.table(
+ "http://freakonometrics.free.fr/sncf.csv",
+ header=TRUE,sep=";")
> train=as.vector(t(as.matrix(sncf[,2:13])))
> X=ts(train,start = c(1963, 1), frequency = 12)
> plot(X)  
> n=length(X)
> F=rep(NA,n)
> for(t in 7:(n-7)) F[t]=1/12*(sum(X[(t-5):(t+5)])+(X[t-6]+X[t+6])/2)
> lines(as.numeric(time(X)),
+ F,lwd=3,col="purple")

On continuera en cours cette semaine autour du lissage, par moyenne mobile, et avec du lissage exponentiel ensuite. A suivre donc.

Collectionner les Figurines Lego avec ses Ami(e)s

Dans mon précédant billet, je regardais combien de figurines Lego je devais acheter pour avoir toute la série, avec ma fille. Pour la série de 16, il fallait, en moyenne, acheter 54 sachets, à 3 euros pièces. Dans les commentaires, @Guillaume et @Gaelle me faisaient noter que les échanges, ça pouvait aider.

Bon, tout d’abord j’aime pas qu’on donne des conseils à mes filles pour avoir raison contre moi ! Parce que oui, c’est sûr qu’en s’y mettant à plusieurs, le coût individuel sera plus faible… Ensuite, parce que les maths me semblent plus compliqués…. Cela dit, en simulant des parties, ça tombe assez vite…

Pour commencer, je fais une petite fonction (histoire d’alléger mes codes) pour incrémenter mes comptages de figurines, à chaque fois que j’en achète une

> f=function(mat,i){
+   mat[i]=mat[i]+1
+   return(mat)
+ }

Ensuite, on peut avoir une petite fonction, correspondant à une simulation, qui me renvoie le nombre de figurine de chaque type que j’ai du acheter pour avoir les 16 une fois. Ou plus. En fait, je veux avoir en tout k fois toutes les figurines (ce qui permet de partager parmi k ami(e)s)

> tirage=function(k=1){
+ test=FALSE
+ cpte=0
+ M=rep(0,16)
+ while(!test){
+   no=sample(1:16,size=1)
+   M=f(M,no)
+   cpte=cpte+1
+   if(min(M)==k) test=TRUE
+ }
+ return(list(compte=M,
+             nbre=cpte))
+ }

Maintenant on peut faire des simulations. Par exemple, pour retrouver le fait qu’il faut, en moyenne, acheter 54 sachet pour que ma fille (seule) ait toutes les figurines

> N=unlist(lapply(1:10000,function(x) tirage(1)$nbre))
> mean(N)
[1] 54.1854

Si maintenant on le fait avec mes deux filles,

> N=unlist(lapply(1:10000,function(x) tirage(2)$nbre))
> mean(N)
[1] 82.7961

ce qui est (beaucoup) moins que le double. Si au lieux de faire ça entre mes deux filles, mais que ma fille collectionne les figurines avec une amie à elle (et que les papas partagent les frais), on a en moyenne 41 sachets à acheter, chacun,

> mean(N)/2
[1] 41.39805

et pour trois, on passe à 36 sachets

> N=unlist(lapply(1:10000,function(x) tirage(3)$nbre))
> mean(N)/3
[1] 36.04363

etc

> V=unlist(lapply(1:10,function(k) mean(unlist(lapply(1:10000,function(x) tirage(k)$nbre)))))
> plot(1:10,V/1:10,type="b",pch=19)

On peut aller plus loin, en regardant les quantiles. Avec 4 ami(e)s, si on achète tous 45 sachets, on a 90% de chances que tout le monde ait les 16 figurines

D’ailleurs, si on regarde l’évolution du quantile (à 90%) sur la moyenne, on voit qu’il baisse vite avec la taille…. Avec 2 ami(e)s, il faut 35% de sachets en plus pour s’assurer d’avoir toutes les figurines dans 90% de cas (par rapport au nombre moyen) alors qu’il en faut juste 20% de plus avec 8 ami(e)s.

Maintenant, si quelqu’un a le courage (et le temps) de faire les maths, je suis preneur !

TP, Séries Temporelles

Deux bases pour illustrer le TP de séries temporelles. La première est du trafic sur autoroute, en France

> autoroute=read.table(
+ "http://freakonometrics.free.fr/autoroute.csv",
+ header=TRUE,sep=";")
> a7=autoroute$a007
> X=ts(a7,start = c(1989, 9), frequency = 12)
> T=time(X)

et on utilisera aussi du traffic sur le réseau de la SNCF

> sncf=read.table(
+   "http://freakonometrics.free.fr/sncf.csv",
+   header=TRUE,sep=";")
> train=as.vector(t(as.matrix(sncf[,2:13])))
> X=ts(train,start = c(1963, 1), frequency = 12)

 

Manipuler des Séries Chronologiques

Ce matin en cours, on a vu un peu comment manipuler des séries temporelles, et en particulier comme jouer avec l’échelle de temps (passer de données hebdomadaire à de données mensuelles, par exemple).

Pour commencer, travaillons un peu sur les données extraites de google.fr/trends/ par exemple sur le mot clé fièvre,

report = read.csv(
"http://freakonometrics.free.fr/report-fievre.csv",
  skip=6,header=FALSE,nrows=626)
 X=report$V2
 plot(X,type="l")

Au lieu d’avoir un vecteur, on peut créer un format de série temporelle (hebdomadaire )

 X_h=ts(X,start=c(2004,3),frequency=52)
 plot(X_h)

On va essayer d’agréger les données pour les rendre mensuelles

 date1=substr(as.character(report$V1),1,10)
 date2=substr(as.character(report$V1),14,23) 
 d1=as.Date(date1,"%Y-%m-%d")
 d2=as.Date(date2,"%Y-%m-%d")
 d1[2]-d1[1]
 Vect_J=Vect_M=Vect_X=Vect_A= NULL
 for(i in 1:length(d1)){
   jours = seq(d1[i],d2[i],length=7)
   mois = as.POSIXlt(jours)$mon+1
   annees = as.POSIXlt(jours)$year+1900
   donnees = rep(X[i],7)
   Vect_J = c(Vect_J,jours)
   Vect_M = c(Vect_M,mois)
   Vect_A = c(Vect_A,annees)
   Vect_X = c(Vect_X,donnees)
 }
 base=data.frame(J=Vect_J,M=Vect_M,
                 A=Vect_A,X=Vect_X)
 head(base)
 base$AM = base$A*100+base$M
 head(base)
 Y=tapply(base$X,as.factor(base$AM),mean)
 Z=ts(as.numeric(Y[1:144]),
 start=c(2004,1),frequency=12)
 plot(Z)

On peut superposer les deux d’ailleurs (il y a peut être un léger décalage sur la série hebdomadaire)

plot(X_h,col="blue")
lines(as.numeric(time(Z)),as.numeric(Z),
col="red",lwd=2)

Continue reading Manipuler des Séries Chronologiques