ACP + HCPC — Typologie communes logement

Dynamiques de marché 2016-2024 · Communes >20k hab · DVF + SITADEL + RP

1. Données — Pool communes >20k

Source unique dbcln-kpi-commarm.csv (PTB, 409 colonnes). Critères d’inclusion : population ≥20 000 hab. (RP 2022), données DVF complètes sur les trois périodes (TCAM prix 16-22, 22-24, transactions 22-24), et au moins 50 mutations DVF en 2024 pour garantir la fiabilité des médianes.

comm <- read.csv(file.path(PROJECT_ROOT, "data/ptb-output/dbcln-kpi-commarm.csv"),
  stringsAsFactors = FALSE, fileEncoding = "UTF-8-BOM")

SEUIL_POP <- 20000
SEUIL_TRANS <- 50

df <- comm %>%
  filter(P22_POP >= SEUIL_POP,
         !is.na(logd_px2_glb_vtcam_1622),
         !is.na(logd_px2_glb_vtcam_2224),
         !is.na(logd_trans_tx1klog_2224),
         logd_trans_24 >= SEUIL_TRANS)

cat(sprintf("Pool : %d communes (>%dk, DVF complet)\n", nrow(df), SEUIL_POP/1000))

Pool : 479 communes (>20k, DVF complet)

log_step("POOL", n = nrow(df), seuil_pop = SEUIL_POP, n_total = nrow(comm))

2. Variables — 5 sets testés

Question centrale : quels profils de dynamique du marché du logement distinguent les communes françaises depuis 2016 ? On cherche à identifier des trajectoires-types croisant l’évolution des prix, l’effort de construction, la liquidité du marché (transactions) et l’attractivité résidentielle (démographie, vacance). Cinq combinaisons de variables sont testées, du noyau structurel (7 variables marché pur) au set enrichi (13 variables incluant revenus et rotation du parc).

# SET A — Core 11 vars (spec originale prix + marché + parc + démo)
SET_A <- c(
  "logd_px2q2_glb_24",           # Prix niveau
  "logd_px2_glb_vtcam_1622",     # TCAM prix boom
  "logd_px2_glb_vtcam_2224",     # TCAM prix correction
  "logs_logaut_tx1klog16_1622",   # Construction boom
  "logs_logaut_tx1klog22_2225",   # Construction correction
  "logd_trans_tx1klog_1621",      # Transactions boom
  "logd_trans_tx1klog_2224",      # Transactions correction
  "log_vac_pct_22",               # Vacance
  "log_vac_vdifp_1622",           # Vacance évol
  "log_ressec_pct_22",            # Rés secondaires
  "dm_pop_vtcam_1622"             # Démo
)

# SET B — Dynamique pure 9 vars (sans niveaux, focus trajectoires)
SET_B <- c(
  "logd_px2_glb_vtcam_1622", "logd_px2_glb_vtcam_2224",
  "logs_logaut_tx1klog16_1622", "logs_logaut_tx1klog22_2225",
  "logd_trans_tx1klog_1621", "logd_trans_tx1klog_2224",
  "log_vac_vdifp_1622", "dm_pop_vtcam_1622",
  "log_emmenrec_vdifp_1622"
)

# SET C — Enrichi 13 vars (core + revenus + rotation parc)
SET_C <- c(SET_A, "rev_med_21", "log_emmenrec_pct_22")

# SET D — Attractivité 8 vars (prix + démo + revenus + transactions)
SET_D <- c(
  "logd_px2q2_glb_24", "logd_px2_glb_vtcam_2224",
  "dm_pop_vtcam_1622", "dm_sma_vtcam_1622",
  "rev_med_21", "logd_trans_tx1klog_2224",
  "log_vac_pct_22", "log_ressec_pct_22"
)

# SET E — Marché pur 7 vars (prix + construction + transactions, pas de parc)
SET_E <- c(
  "logd_px2q2_glb_24",
  "logd_px2_glb_vtcam_1622", "logd_px2_glb_vtcam_2224",
  "logs_logaut_tx1klog16_1622", "logs_logaut_tx1klog22_2225",
  "logd_trans_tx1klog_1621", "logd_trans_tx1klog_2224"
)

sets <- list(A = SET_A, B = SET_B, C = SET_C, D = SET_D, E = SET_E)
cat(paste(sprintf("SET %s: %d vars", names(sets), sapply(sets, length)), collapse = " | "), "\n")

SET A: 11 vars | SET B: 9 vars | SET C: 13 vars | SET D: 8 vars | SET E: 7 vars 

3. Corrélations

Seuil de retrait : si une paire dépasse |r| > 0.80, la variable la moins interprétable est candidate à l’exclusion. Paires à surveiller : transactions boom × transactions correction (inertie), prix niveau × TCAM prix (niveau vs dynamique).

# SET A (le plus riche)
df_a <- df %>% select(all_of(SET_A)) %>% na.omit()
rownames(df_a) <- df$libelle[complete.cases(df[, SET_A])]

cor_a <- cor(df_a, use = "pairwise.complete.obs")
corrplot(cor_a, method = "color", type = "upper", tl.cex = 0.6,
         addCoef.col = "black", number.cex = 0.5,
         title = "Matrice corrélation — SET A (11 vars)", mar = c(0,0,2,0))

high <- which(abs(cor_a) > 0.7 & upper.tri(cor_a), arr.ind = TRUE)
if (nrow(high) > 0) {
  cat("Paires corrélées >0.7 :\n")
  for (i in seq_len(nrow(high)))
    cat(sprintf("  %s × %s = %.2f\n", SET_A[high[i,1]], SET_A[high[i,2]],
        cor_a[high[i,1], high[i,2]]))
} else cat("✅ Aucune paire > 0.7\n")

Paires corrélées >0.7 :
  logd_trans_tx1klog_1621 × logd_trans_tx1klog_2224 = 0.74

4. ACP — 5 sets

# Préparer data + PCA pour chaque set
prep_set <- function(vars, label) {
  d <- df %>% select(all_of(vars)) %>% na.omit()
  rownames(d) <- df$libelle[complete.cases(df[, vars])]
  pca <- PCA(d, scale.unit = TRUE, ncp = 5, graph = FALSE)
  eig <- pca$eig
  cat(sprintf("SET %s : %d ind × %d vars, var 1-3=%.1f%%, Kaiser=%d\n",
      label, nrow(d), length(vars), sum(eig[1:3,2]), sum(eig[,1]>1)))
  # Log ACP auto
  log_acp_results(pca)
  list(df = d, pca = pca)
}

res <- list()
for (nm in names(sets)) {
  res[[nm]] <- prep_set(sets[[nm]], nm)
}

SET A : 436 ind × 11 vars, var 1-3=56.1%, Kaiser=4

SET B : 436 ind × 9 vars, var 1-3=61.0%, Kaiser=4

SET C : 436 ind × 13 vars, var 1-3=53.7%, Kaiser=5

SET D : 479 ind × 8 vars, var 1-3=72.7%, Kaiser=3

SET E : 436 ind × 7 vars, var 1-3=70.7%, Kaiser=3

Screeplot + cercle par set

plot_screeplot(res$A$pca) + plot_var_circle(res$A$pca) + plot_layout(ncol = 2)

plot_screeplot(res$B$pca) + plot_var_circle(res$B$pca) + plot_layout(ncol = 2)

plot_screeplot(res$D$pca) + plot_var_circle(res$D$pca) + plot_layout(ncol = 2)

plot_screeplot(res$E$pca) + plot_var_circle(res$E$pca) + plot_layout(ncol = 2)

Outliers cos2 (SET A)

plot_var_circle(res$A$pca, axes = c(1, 3)) + plot_ind_cos2(res$A$pca) + plot_layout(ncol = 2)

5. Grille HCPC — 5 sets × 4 k

Pour chaque set de variables, quatre valeurs de k sont testées : choix automatique (critère du saut d’inertie), k=3, k=4, k=5. La silhouette moyenne et la taille du plus petit cluster sont les deux critères de sélection. Seuil silhouette ≥0.25 = structure raisonnable. Pas de cluster <15 villes (sinon artefact).

run_hcpc_grid <- function(pca, df_acp, label, k_test = c(-1, 3, 4, 5)) {
  d <- dist(scale(df_acp))
  rows <- list()
  for (k in k_test) {
    hcpc_k <- HCPC(pca, nb.clust = k, graph = FALSE)
    k_real <- nlevels(hcpc_k$data.clust$clust)
    sil <- mean(silhouette(as.integer(hcpc_k$data.clust$clust), d)[, 3])
    sizes <- table(hcpc_k$data.clust$clust)
    rows[[length(rows) + 1]] <- data.frame(
      set = label, k_demande = k, k_reel = k_real,
      silhouette = round(sil, 3),
      n_ind = nrow(df_acp), n_vars = ncol(df_acp),
      min_cluster = min(sizes),
      sizes = paste(sizes, collapse = "/"),
      stringsAsFactors = FALSE
    )
  }
  do.call(rbind, rows)
}

grids <- list()
for (nm in names(res)) {
  grids[[nm]] <- run_hcpc_grid(res[[nm]]$pca, res[[nm]]$df, sprintf("%s (%d vars)", nm, ncol(res[[nm]]$df)))
}

grid_all <- do.call(rbind, grids) %>% arrange(desc(silhouette))

rt_table(grid_all,
  cols = list(
    set = colDef(name = "Set", minWidth = 110, align = "left",
      style = list(fontWeight = 600)),
    k_demande = colDef(name = "k dem.", width = 55),
    k_reel = colDef(name = "k", width = 40),
    silhouette = colDef(name = "Sil.", minWidth = 70,
      style = function(value) {
        bg <- if (value >= 0.25) col_green_light
              else if (value >= 0.15) col_yellow_light
              else col_red_light
        list(background = bg, fontWeight = 600)
      }),
    n_ind = colDef(name = "N", width = 50),
    n_vars = colDef(name = "Vars", width = 45),
    min_cluster = colDef(name = "Min", width = 45,
      style = function(value) list(color = if (value < 10) col_red else "#333", fontWeight = 600)),
    sizes = colDef(name = "Tailles clusters", minWidth = 130)
  ),
  searchable = FALSE, height = "auto", page_size = 25,
  title = "Grille HCPC — 5 sets × 4 valeurs de k (trié par silhouette)",
  subtitle = "Vert ≥0.25, jaune ≥0.15, rouge <0.15. Min = plus petit cluster."
)
log_result("grid_all", grid_all)

Table 1

Grille HCPC — 5 sets × 4 valeurs de k (trié par silhouette)

Vert ≥0.25, jaune ≥0.15, rouge <0.15. Min = plus petit cluster.

6. Meilleur résultat — Diagnostic complet

Le meilleur compromis silhouette × min_cluster est retenu et diagnostiqué en détail : biplot (flèches variables + individus colorés par cluster), carte factorielle axes 1-2 et 1-3, dendrogramme (hauteur de coupe), silhouette par cluster (individus mal classés).

# Meilleure silhouette avec min_cluster >= 15
valid <- grid_all %>% filter(min_cluster >= 15) %>% slice_max(silhouette, n = 1)
best_set <- sub(" .*", "", valid$set[1])
best_k <- valid$k_reel[1]
cat(sprintf(">>> Retenu : SET %s, k=%d, sil=%.3f\n", best_set, best_k, valid$silhouette[1]))

>>> Retenu : SET D, k=3, sil=0.304

pca_best <- res[[best_set]]$pca
df_best <- res[[best_set]]$df
hcpc_best <- HCPC(pca_best, nb.clust = best_k, graph = FALSE)

# Log HCPC auto
log_hcpc_results(hcpc_best, pca_best)
log_result("best_config", list(set = best_set, k = best_k, sil = valid$silhouette[1]))

6.1 Biplot clusters (axes 1-2)

plot_biplot(pca_best, quali = hcpc_best$data.clust$clust)

6.2 Carte factorielle colorée

plot_ind_cluster(pca_best, hcpc_best)

plot_ind_cluster(pca_best, hcpc_best, axes = c(1, 3))

6.3 Dendrogramme

plot(hcpc_best, choice = "tree")

6.4 Silhouette

d_best <- dist(scale(df_best))
sil_obj <- silhouette(as.integer(hcpc_best$data.clust$clust), d_best)
fviz_silhouette(sil_obj) +
  labs(title = sprintf("Silhouette — k=%d, moyenne=%.3f", best_k, mean(sil_obj[,3])))

  cluster size ave.sil.width
1       1   65          0.24
2       2  372          0.34
3       3   42          0.13

7. Qualification clusters

Extraction des résultats via les helpers jcn-hcpc-typo.R. Le profil moyen (typo_profil_rt) montre les écarts par cluster vs la moyenne globale. Les v.test (typo_desc) identifient les variables significativement sur- ou sous-représentées dans chaque cluster (seuil p < 0.05). Les parangons sont les individus les plus proches du centroïde de leur cluster.

7.1 Profil moyen (reactable)

typo_profil_rt(hcpc_best)

Table 2

7.2 Variables significatives (v.test)

desc <- typo_desc(hcpc_best, proba = 0.05)
desc %>%
  group_by(cluster) %>%
  slice_head(n = 7) %>%
  select(cluster, variable, v.test, mean_clust, mean_global) %>%
  knitr::kable(digits = 2, caption = "Top 7 variables caractéristiques par cluster (p < 0.05)")

Table 3: Top 7 variables caractéristiques par cluster (p < 0.05)

cluster	variable	v.test	mean_clust	mean_global
1	logd_px2q2_glb_24	16.0	7377.80	3595.35
1	rev_med_21	15.1	31927.23	23245.09
1	dm_sma_vtcam_1622	-7.6	-0.83	-0.04
1	logd_px2_glb_vtcam_2224	-6.7	-5.85	-3.23
1	dm_pop_vtcam_1622	-6.7	-0.22	0.42
1	log_ressec_pct_22	2.6	6.48	4.37
1	log_vac_pct_22	2.3	8.31	7.49
2	logd_px2q2_glb_24	-14.5	2866.27	3595.35
2	rev_med_21	-12.6	21705.38	23245.09
2	log_ressec_pct_22	-11.7	2.33	4.37
2	logd_trans_tx1klog_2224	-3.6	23.06	23.49
3	log_ressec_pct_22	14.1	19.15	4.37
3	dm_sma_vtcam_1622	11.0	1.44	-0.04
3	logd_px2_glb_vtcam_2224	7.3	0.40	-3.23
3	logd_trans_tx1klog_2224	7.1	28.67	23.49
3	dm_pop_vtcam_1622	7.0	1.28	0.42
3	log_vac_pct_22	-4.7	5.41	7.49
3	logd_px2q2_glb_24	2.0	4199.22	3595.35

7.3 Parangons (5 par cluster)

parangons <- typo_parangons(hcpc_best, n = 5)
parangons %>% filter(type == "paragon") %>%
  knitr::kable(digits = 2, caption = "Individus les plus typiques par cluster")

Table 4: Individus les plus typiques par cluster

cluster	individu	distance	type
1	Versailles	0.19	paragon
1	Courbevoie	0.55	paragon
1	Issy-les-Moulineaux	0.56	paragon
1	Puteaux	0.60	paragon
1	Suresnes	0.74	paragon
2	Lille	0.34	paragon
2	Muret	0.58	paragon
2	Loos	0.61	paragon
2	Marseille 13e Arrondissement	0.62	paragon
2	Sotteville-lès-Rouen	0.65	paragon
3	Cagnes-sur-Mer	0.68	paragon
3	La Ciotat	0.80	paragon
3	Frontignan	0.99	paragon
3	Aix-les-Bains	1.22	paragon
3	Vallauris	1.29	paragon

7.4 Qualité classification

knitr::kable(typo_inertia(hcpc_best), digits = 3, caption = "Métriques qualité HCPC")

Table 5: Métriques qualité HCPC

nb_clusters	n_individus	inertie_inter_avant	inertie_inter_apres	gain_consol_pct
3	479	2.2	2.3	5.6

8. Tableau détail individus

typo_data_rt(hcpc_best)

Table 6

9. Stabilité ARI entre sets

L’Adjusted Rand Index (ARI) mesure la concordance entre deux partitions. ARI=1 signifie que les deux classifications sont identiques, ARI≈0 signifie une concordance aléatoire. Si les clusters sont stables entre sets de variables différents (ARI > 0.65), la structure identifiée est robuste. Si instable (ARI < 0.4), le résultat dépend fortement du choix de variables.

# Individus communs aux 5 sets
all_rownames <- lapply(res, function(r) rownames(r$df))
common_ind <- Reduce(intersect, all_rownames)
cat(sprintf("Individus communs aux 5 sets : %d\n", length(common_ind)))

Individus communs aux 5 sets : 436

# Re-run HCPC pour chaque set, extraire clusters sur individus communs
get_cl <- function(r, k, common) {
  hc <- tryCatch(HCPC(r$pca, nb.clust = k, graph = FALSE), error = function(e) NULL)
  if (is.null(hc)) return(NULL)
  cl <- as.character(hc$data.clust$clust)
  names(cl) <- rownames(hc$data.clust)
  cl[intersect(names(cl), common)]
}

cls <- lapply(res, get_cl, k = best_k, common = common_ind)

# Matrice ARI
set_names <- names(cls)
ari_mat <- matrix(NA, length(set_names), length(set_names),
                  dimnames = list(set_names, set_names))
for (i in seq_along(set_names)) {
  for (j in seq_along(set_names)) {
    if (i <= j && !is.null(cls[[i]]) && !is.null(cls[[j]])) {
      ari_mat[i, j] <- round(adjustedRandIndex(cls[[i]], cls[[j]]), 3)
      ari_mat[j, i] <- ari_mat[i, j]
    }
  }
}

cat(sprintf("\nMatrice ARI (k=%d) :\n", best_k))

Matrice ARI (k=3) :

print(ari_mat)

     A     B     C     D     E
A 1.00 0.115 0.802 0.168 0.160
B 0.12 1.000 0.081 0.018 0.439
C 0.80 0.081 1.000 0.164 0.139
D 0.17 0.018 0.164 1.000 0.003
E 0.16 0.439 0.139 0.003 1.000

cat("\nInterprétation : >0.65 stable, 0.4-0.65 modéré, <0.4 instable\n")

Interprétation : >0.65 stable, 0.4-0.65 modéré, <0.4 instable

log_result("ari_matrix", as.data.frame(ari_mat),
  interpret = sprintf("ARI k=%d, %d individus communs. Paires stables: %s",
    best_k, length(common_ind),
    paste(which(ari_mat > 0.65 & upper.tri(ari_mat), arr.ind = TRUE)[,1:2], collapse = ",")))

10. Sauvegarde