Apply micro-agregation

Author

INSEE, Department of Statistical Methods

La micro-agrégation consiste à regrouper les individus d’un jeu de données individuelles selon une mesure de proximité calculée sur des variables d’iintérêt. Une fois ces groupes constitués, la valeur des individus dans chaque groupe homogène sur la variable d’intérêt est remplacée par une même valeur, par exemple la moyenne ou la médiane.

Cette méthode est particulièrement adaptée pour atteindre un objectif fixé à l’avance en termes de \(k\)-anonymat, dès lors que des variables continues (ou des variables catégorielles ordinales) sont présentes dans la liste des variables quasi-identifiantes.

La façon de procéder à l’agrégation dépend principalement de trois éléments:

comment est mesurée l’homogénéité des groupes ?
quel algorithme permet de les constituer ?
comment est réalisée l’agrégation une fois les groupes ocnstitués ?

Les packages


Attaching package: 'dplyr'

The following objects are masked from 'package:stats':

    filter, lag

The following objects are masked from 'package:base':

    intersect, setdiff, setequal, union

Les données

Code

source("../R/fun_import_data.R")
lfs_2023 <- import_lfs()

Code

head(lfs_2023)

      REG    DEP    ARR   SEXE   AGE   AGE6  ACTEU   DIP7  PCS1Q ANCCHOM  HHID
   <fctr> <fctr> <fctr> <fctr> <int> <fctr> <fctr> <fctr> <fctr>  <fctr> <int>
1:     28     76    761      1    53     50      1      4     30      99  3558
2:     28     76    761      2    43     25      1      7     52      99  3558
3:     28     76    761      2    17     15      3      5     99      99  3558
4:     28     76    761      1    17     15      3      4     99      99  3558
5:     11     92    922      1    42     25      1      7     62      99  5973
6:     11     92    922      2    54     50      1      7     62      99  5973
   HH_TAILLE HH_AGE HH_DIP HH_PCS IS_CHOM
      <fctr> <fctr> <fctr> <fctr>   <int>
1:         4     53      4     30       0
2:         4     53      4     30       0
3:         4     53      4     30       0
4:         4     53      4     30       0
5:         2     54      7     62       0
6:         2     54      7     62       0

Pour plus d’informations sur les données, on pourra se reporter à la fiche “Présentation des données”.

Mesurons les risques du fichier

Nous choisirons les variables quasi-identifiantes suivantes:

Code

key_vars <- c("AGE","SEXE","DEP","DIP7")

Code

lfs_sdc <- sdcMicro::createSdcObj(
  lfs_2023 |> mutate(AGE = as.double(AGE)),
  keyVars = key_vars,
  numVars = "AGE"
)

Le tableau ci-dessous présente le nombre et la part d’individus du fichier ne répondant pas au critère du \(k\)-anonymat, en fonction de la valeur de \(k\).

Code

ks <- 2:10
data.frame(
  k = ks,
  nb_ind_risk = sapply(ks, \(k) sum(lfs_sdc@risk$individual[,"fk"] < k))
) |>
  mutate(part_ind_risk = nb_ind_risk / nrow(lfs_2023) * 100) |>
  knitr::kable(digits=1)

k	nb_ind_risk	part_ind_risk
2	6687	19.6
3	13587	39.9
4	19362	56.9
5	23550	69.2
6	26875	78.9
7	29347	86.2
8	30985	91.0
9	32241	94.7
10	32970	96.8

En choisissant de diffuser l’âge détaillé, la part d’individus à risque de ré-identification est très élevée (19,6% pour k=2 et 69,2% pour k=5, par exemple).

Voyons si l’application d’un algorithme de micro-agrégation permettrait de réduire ces risques.

La micro-agrégation

Code

lfs_sdc <- microaggregation(
  lfs_sdc,
  variables = 'AGE',
  aggr = 1000,
  method = "mdav",
  clustermethod = "clara",
  measure = "median"
)

Code

pert <- lfs_2023 |> 
  bind_cols(AGE_ma = lfs_sdc@manipNumVars |> pull(AGE))

Code

table(pert$AGE_ma != pert$AGE)


FALSE  TRUE 
16093 17960

Code

head(pert |> select(DEP, SEXE, DIP7, AGE, AGE_ma))

      DEP   SEXE   DIP7   AGE AGE_ma
   <fctr> <fctr> <fctr> <int>  <num>
1:     76      1      4    53     53
2:     76      2      7    43     42
3:     76      2      5    17     16
4:     76      1      4    17     16
5:     92      1      7    42     42
6:     92      2      7    54     53

Code

pert_sdc <- sdcMicro::createSdcObj(
  pert,
  keyVars = c("DEP","SEXE","AGE_ma","DIP7")
)

data.frame(
  k = ks,
  nb_ind_risk = sapply(ks, \(k) sum(pert_sdc@risk$individual[,"fk"] < k))
) |>
  mutate(part_ind_risk = nb_ind_risk / nrow(lfs_2023) * 100) |>
  knitr::kable(digits=1)

k	nb_ind_risk	part_ind_risk
2	2730	8.0
3	6220	18.3
4	9907	29.1
5	13455	39.5
6	16725	49.1
7	19521	57.3
8	21936	64.4
9	24176	71.0
10	25967	76.3