Régionalisation avec GTclust des résultats aux élections européennes de 2024

GTclust

• https://github.com/comeetie/gtclust
• https://link.springer.com/article/10.1007/s11222-023-10376-3

Echelle des circonscriptions

Chargement des données et des styles

library(sf)
library(ineq)
library(gtclust)
library(adespatial)
library(ggplot2)
library(dplyr)
library(mapsf)
library(cartogramR)
library(smoothr)
library(units)
library(ggrepel)
library(ggh4x)
# métadonnées
listes<-readRDS("data/net/don_listes.RDS")

# Votes par circo
don<-readRDS("data/net/don_circ.RDS")
mat<-as.matrix(don[,12:49])
listes$pct <-100*apply(mat,2,sum)/sum(mat)
listes$gini<-apply(mat,2,Gini)

tab<-cbind(log(listes$pct), listes$gini)
w<-kmeans(tab,centers = 2,iter.max = 1000)
listes$type<-as.factor(w$cluster)
levels(listes$type)
#> [1] "1" "2"

map<-readRDS("data/net/map_circ.RDS")

mapdon<-left_join(map,don)
# ! les probas nulles ne sont pas acceptés pour le moment lissage bayesien   
matdon<-as.matrix(st_drop_geometry(mapdon[,12:49])+1)
matdon<-matdon/apply(matdon,1,sum)
rownames(matdon)<-mapdon$circ
colnames(matdon)<-listes$tete_nom

# Données % de votes + geometrie
Xgeo=bind_cols(data.frame(matdon),data.frame(geometry=st_geometry(mapdon))) |> 
  st_as_sf()

# Cartogramme
mapdon_forcarto = mapdon |> mutate(geometry=densify(geometry,150))
mapdon_cartogr = cartogramR(mapdon_forcarto,count="vot",options = )$cartogram |> 
  st_as_sf() |> 
  st_make_valid()

default_background_color = "#ffffff"
default_font_color = "#444444"
default_font_family <- "Ubuntu Regular"
default_caption <- paste0("Map CC-BY-SA; ",
                          "\nAuthors: Etienne Côme",
                          " (@comeetie)",
                          "\nGeometries: IGN;",
                          " Data: Ministère de l'intérieur, traitement Claude Gralland.")
theme_map <- function(...) {
  theme_minimal() +
  theme(
    text = element_text(family = default_font_family,
                        color = default_font_color),
    # remove all axes
    axis.line = element_blank(),
    axis.text.x = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks = element_blank(),
    # background colors
    plot.background = element_rect(fill = default_background_color,
                                   color = NA),
    panel.background = element_rect(fill = default_background_color,
                                    color = NA),
    legend.background = element_rect(fill = default_background_color,
                                     color = NA),
    # borders and margins
    plot.margin = unit(c(.5, .5, .2, .5), "cm"),
    panel.border = element_blank(),
    panel.spacing = unit(c(-.1, 0.2, .2, 0.2), "cm"),
    # grid      
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    # titles
    legend.title = element_text(size = 11),
    legend.text = element_text(size = 9, hjust = 0,
                               color = default_font_color),
    legend.position="bottom",
    legend.box = "vertical",
    plot.title = element_text(size = 15,
                              color = default_font_color),
    plot.subtitle = element_text(size = 10,
                                 color = default_font_color,
                                 debug = F),
    # captions
    plot.caption = element_text(size = 7,
                                hjust = .5,
                                margin = margin(t = 0.2,
                                                b = 0,
                                                unit = "cm"),
                                color = "#939184"),
    ...
  )
}

Régionalisation avec gtclust

Régionalisaion avec distribution de Dirichlet pour analyser des pourcentages et affichage du dendrogramme.

# regionalisation avec une distribution adaptée au données compositionel (dirichlet)
# paramètre du prior (valeur par défaut)
lambda_est= rep(0.01,38)
regions_tree=gtclust_poly(Xgeo,method=gtclust::gtmethod_bayes_dirichlet(lambda=lambda_est))
# plot du dendogramme selection automatique d'un nombre de cluster "pertinent"
plot(regions_tree)

Sélection automatique du nombre de région et affichage des régions :

Ksel = regions_tree$Kunif
# plot de la partition
regions = geocutree(regions_tree,Ksel)
plot(st_geometry(regions))

Cartes finalisées

mapdon_cartogr$region = cutree(regions_tree,regions_tree$Kunif)
regions_cartogr = mapdon_cartogr|>st_make_valid()|>group_by(region)|>summarise()

Préparations des labels / données pour la cartographie

reg = CARTElette::charger_carte(nivsupra = "REG") 
#> Reading layer `REG_2024_CARTElette' from data source 
#>   `/tmp/RtmppdxZlq/REG_2024_CARTElette.shp' using driver `ESRI Shapefile'
#> Simple feature collection with 18 features and 2 fields
#> Geometry type: MULTIPOLYGON
#> Dimension:     XY
#> Bounding box:  xmin: -5.141277 ymin: 40.26848 xmax: 9.560094 ymax: 51.08899
#> Geodetic CRS:  WGS 84
aav = CARTElette::charger_carte(nivsupra = "AAV2020")
#> Reading layer `AAV2020_2024_CARTElette' from data source 
#>   `/tmp/RtmppdxZlq/AAV2020_2024_CARTElette.shp' using driver `ESRI Shapefile'
#> Simple feature collection with 700 features and 2 fields
#> Geometry type: MULTIPOLYGON
#> Dimension:     XY
#> Bounding box:  xmin: -5.141277 ymin: 40.26848 xmax: 9.560094 ymax: 51.08899
#> Geodetic CRS:  WGS 84

regions_reg_labels = regions |> select(cl)|> 
  st_intersection(reg|>mutate(nom_reg=nom)|>st_transform(2154)) |>
  mutate(area=st_area(geometry)) |>
  group_by(cl) |> 
  top_n(1,area) |> 
  st_drop_geometry() |> 
  ungroup() |> select(cl,nom_reg,area_reg= area)

regions_aav_labels = regions |> select(cl)|> 
  st_intersection(aav|>mutate(nom_aav=nom)|>st_transform(2154)) |>
  mutate(area=st_area(geometry)) |>
  group_by(cl) |> 
  top_n(1,area) |> 
  st_drop_geometry() |> 
  ungroup() |> select(cl,nom_aav,area_aav=area)


regions_label = regions |> 
  left_join(regions_reg_labels) |> 
  left_join(regions_aav_labels) |> 
  mutate(area=st_area(geometry)) |> 
  arrange(desc(area)) |> 
  mutate(label = if_else(area>as_units(5*10^9,"m2"),nom_reg,nom_aav)) |>
  mutate(label=gsub("\\(partie française\\)","",label)) |>
  arrange(cl) |> mutate(vainq = case_when(
    AUBRY == pmax(AUBRY, BARDELLA, BELLAMY, GLUCKSMANN,HAYER) ~ "AUBRY",
    BARDELLA == pmax(AUBRY, BARDELLA, BELLAMY, GLUCKSMANN,HAYER) ~ "BARDELLA",
    BELLAMY == pmax(AUBRY, BARDELLA, BELLAMY, GLUCKSMANN,HAYER) ~ "BELLAMY",
    GLUCKSMANN == pmax(AUBRY, BARDELLA, BELLAMY, GLUCKSMANN,HAYER) ~ "GLUCKSMANN",
    HAYER == pmax(AUBRY, BARDELLA, BELLAMY, GLUCKSMANN,HAYER) ~ "HAYER"
),
vscore=pmax(AUBRY, BARDELLA, BELLAMY, GLUCKSMANN,HAYER))

regions_cartogr$label=regions_label |> pull(label)
regions_cartogr$vainq=regions_label |> pull(vainq)
regions_cartogr$vscore=regions_label |> pull(vscore)

labels =regions_cartogr |> filter(!duplicated(label))

Cartogramme

ggplot(regions_cartogr) + 
  geom_sf(aes(fill=vainq,alpha=vscore)) + 
  geom_text_repel(data=labels,aes(label=label,geometry=geometry),stat = "sf_coordinates",size=4.5,family=default_font_family,color=default_font_color,bg.color="white") + 
  scale_fill_brewer("Vainqueur :",palette="Set1")+
  scale_alpha_continuous("Score du Vainqueur :")+
  labs(x = NULL,
         y = NULL,
         title = "Élections européennes 2024",
         subtitle = "entre effets régionaux et métropolitains",
         caption = default_caption)+
  guides(fill = guide_legend(order=1),
         alpha = guide_legend(override.aes = list(fill="#000000"),order=2))+
  theme_map()

Géographique

ggplot(regions_label ) + 
  geom_sf(aes(fill=vainq,alpha=vscore)) + 
  geom_text_repel(data=regions_label|>filter(!duplicated(label)),
                  aes(label=label,geometry=geometry),
                  stat = "sf_coordinates",size=4.5,
                  family=default_font_family,
                  color=default_font_color,bg.color="white") + 
  scale_fill_brewer("Vainqueur :",palette="Set1")+
  scale_alpha_continuous("Score du Vainqueur :")+
  labs(x = NULL,
       y = NULL,
       title = "Élections européennes 2024",
       subtitle = "entre effets régionaux et métropolitains",
       caption = default_caption)+
  guides(fill = guide_legend(order=1),
         alpha = guide_legend(override.aes = list(fill="#000000"),order=2))+
  theme_map()

Zoom sur la région Parisienne

ggplot(regions_label |> filter(label=="Paris")) + 
  geom_sf(aes(fill=vainq,alpha=vscore)) + 
  scale_fill_brewer("Vainqueur :",palette="Set1")+
  scale_alpha_continuous("Score du Vainqueur :")+
  labs(x = NULL,
         y = NULL,
         title = "Élections européennes 2024",
         subtitle = "La région Parisienne une dynamique à part",
         caption = default_caption)+
  guides(fill = guide_legend(order=1),
         alpha = guide_legend(override.aes = list(fill="#000000"),order=2))+
  theme_map()

Analyse des régions

nb=lapply(1:Ksel, \(k){setdiff(1:Ksel,k)})
Xcenters = regions_label |> st_drop_geometry() 
cah = gtclust_graph(nb,Xcenters[,3:40],gtclust::gtmethod_bayes_dirichlet())

ordered_labels = data.frame(key=paste(Xcenters$label[cah$order],Xcenters$cl[cah$order]),clf=cutree(cah,cah$Kunif)[cah$order]) 

sel_liste= c("AUBRY","BARDELLA","GLUCKSMANN","HAYER","BELLAMY")

reg_temp = regions_label |> mutate(key=paste(label,cl)) |> left_join(ordered_labels,by="key")
regions_profs = reg_temp[,c("cl","label","clf",sel_liste)] |> 
  arrange(clf) |>
  group_by(label) |> mutate(ilab =1:n(),nblab=n()) |> 
  ungroup() |> 
  mutate(flab = if_else(nblab>1,paste(label,ilab),label)) |> 
  select(flab,clf,AUBRY:BELLAMY) |> 
  st_drop_geometry()

res_long = regions_profs |> 
  tidyr::pivot_longer(AUBRY:BELLAMY,names_to="liste",values_to = "pct") |>
  mutate(liste=factor(liste,levels=sel_liste))

levels_ord = regions_profs |> 
  arrange(clf) |> 
  pull(flab) 

res_long$flab = factor(res_long$flab,levels=levels_ord)


profiles = res_long |> 
  group_by(liste) |> 
  summarise(pct_nat=mean(pct))


ggplot(res_long|> left_join(profiles,by="liste"))+
  geom_col(aes(x=flab,y=(pct-pct_nat)*100 ,fill=liste),position="stack")+  
  theme_bw()+
  scale_fill_brewer("Candidats :",palette="Set1")+
  scale_x_discrete(drop=TRUE)+
  scale_y_continuous(limits=c(-30,30))+
  coord_flip()+
  facet_grid(clf~.,scales="free_y")+
  force_panelsizes(rows = table(cutree(cah,cah$Kunif))/37) +
  xlab("Régions :")+
  ylab("Ecart à la moyenne (%)")+
  ggtitle("Profils des 37 régions électorales")

Echelle départementale

map<-readRDS("data/net/map_dept.RDS")
don<-readRDS("data/net/don_dept.RDS")
mapdon<-left_join(map,don)
# ! les valeures nulles ne sont pas tolérées 
matdon<-as.matrix(st_drop_geometry(mapdon[,12:49])+1)
rownames(matdon)<-mapdon$dept
colnames(matdon)<-listes$tete_nom
matdon<-matdon/apply(matdon,1,sum)
# Données % de votes + geometrie
Xgeo=bind_cols(data.frame(matdon),data.frame(geometry=st_geometry(mapdon))) |> 
  st_as_sf()

# regionalisation avec une distribution adaptée au données compositionel (dirichlet)
regions_tree=gtclust_poly(Xgeo,method=gtclust::gtmethod_bayes_dirichlet())
# plot du dendogramme selection automatique d'un nombre de cluster "pertinent"
plot(regions_tree)

plot(geocutree(regions_tree,regions_tree$Kunif) |> st_geometry())