Bout de code : procédure de Shorrocks et Wan

Besoin de données micro de revenus ? Oui mais pas de chance car vous n'avez que quelques points de la courbe de Lorenz. La procédure de Shorrocks et Wan (2008) est faite pour vous (papier ici). L'idée est de retoucher les données obtenues par l'ajustement d'une loi de distribution connue (la lognormale par exemple) de manière à retrouver la courbe de Lorenz initiale. Ci-suivent deux fonctions pour procéder à l'ajustement:

D'abord la fonction mu.L permet de retrouver les revenus moyens pour chaque intervalle de population défini en abscisse de la courbe de Lorenz:

Code:

mu.L   <-   function(L, p)   {   
      a   <- length(p)
      (L[-1]-L[-a])/(p[-1]-p[-a])   }

Attention, les valeurs retournées correspondent à un revenu moyen normalisé à l'unité.

Ensuite la fonction d'ajustement proprement dite:

Code:

ungroup   <-   function(y, p, mu.vrai, mu.gen)   {
      mu.group <-   function(x)   {
                  truc   <-   sapply(p[-1], quantile, x=x)
                  zob   <-   length(truc)
                  machin   <-   function(t) mean(x[x>truc[t-1] & x<truc[t]])
                  c(mean(x[x<truc[1]]), sapply(2:zob, machin))   }
      step2   <-   function(x){
                  t   <-   which(borne==max(borne[borne<x]))
                  ifelse((mu.vrai[t]>mu.step1[t] & t<m)==TRUE, (borne[t+1]-(borne[t+1]-mu.vrai[t])/(borne[t+1]-mu.step1[t])*(borne[t+1]-x)), (borne[t]+(mu.vrai[t]-borne[t])/(mu.step1[t]-borne[t])*(x-borne[t])))   }

      mu   <-   mu.group(y)
      m   <-   length(mu)
      group   <-   colSums(matrix(rep.int(y,m),nrow=m,byrow=TRUE)>mu)

      y.step1   <-   rep.int(NA,length(y))
      y.step1[y<mu[1]]   <-   y[y<mu[1]]*mu.vrai[1]/mu[1]
      y.step1[y>=mu[m]]   <-   y[y>=mu[m]]*mu.vrai[m]/mu[m]
      a   <-   y>=mu[1] & y<mu[m]
      y.step1[a]   <-   mu.vrai[group[a]]+(mu.vrai[group[a]+1]-mu.vrai[group[a]])/(mu[group[a]+1]-mu[group[a]])*(y[a]-mu[group[a]])
      mu.step1   <-   mu.group(y.step1)

      truc   <-   sapply(p[-c(1,length(p))], quantile, x=y.step1)
      b.inf   <-   function(a) max(y.step1[y.step1<a])
      b.sup   <-   function(a) min(y.step1[y.step1>a])
      borne   <-   c(0, .5*sapply(truc,b.inf)+.5*sapply(truc,b.sup))
      sapply(y.step1, step2)*mu.gen   }

où y est la série à ajuster, p le vecteurs de quantiles de population utilisé pour la courbe de Lorenz, mu.gen est le revenu moyen de la distribution initiale et mu.vrai les moyennes par groupe de population (obtenus avec la fonction mu.L). Exemple d'utilisation avec en premier étape estimation de la Lorenz avec une lognormale:

Code:


X<-   as.data.frame(cbind(0:10/10,c(0,.01,.03,.06,.11,.17,.25,.35,.5,.7,1)))
colnames(X)   <-   c("p","L")
mu.gen   <-   1500
n   <-   1000

f   <-  function(sigma) sum((X$L-pnorm(qnorm(X$p)-sigma))^2)
a   <-   nrow(X)
sig.ini   <-   mean(qnorm(X$p[-c(1,a)])-qnorm(X$L[-c(1,a)]))
sig   <-   optim(sig.ini, f, method="BFGS")$par
y.synth   <-   qlnorm((1:n)/(n+1),-sig^2/2,sig) #distrib moy égale 1
      
mu.x   <-   mu.L(X$L,X$p)
y.fin   <-   ungroup(y.synth, X$p, mu.x, mu.gen)

# Pour voir le résultat
library(ineq)
matplot(cbind(X$p,Lc(y.fin)$p,Lc(y.fin)$p),cbind(X$L,Lc(y.synth)$L,Lc(y.fin)$L),type="l")
legend("topleft",legend=c("original","lognorm", "adjusted"),lty=1:3,col=1:3)