IND6212 Projet: Analyse et Segmentation des Logements sociaux et communautaires dans l’agglomération de Montréal

Introduction

L’objectif de ce projet est de pratiquer les médthodes de segmentation, explorer les données avec des transformations nécessaires, et faire les cartes avec les données spatiales.

Le data set: les données publice (donnesouvertes_logsoc_20181231.csv) de la ville de Montréal obtenue du leur portaile de données public.

Ce rapport est aussi mis en ligne, voir http://rpubs.com/jz8/LogsocCluster.

Chager les librairies

library(stats)
library(cluster)
library(ggplot2)
library(ggthemes)
library(dplyr)
library(factoextra)
library(viridis)
library(tidyr)
library(ggmap)
library(maps)

Chager les données

Liste des projets et/ou bâtiments associés aux logements sociaux. Données utilisées pour mieux connaître la desserte en logements sociaux et communautaires sur le territoire de Montréal.

logsoc_mtl <- read.csv('donnesouvertes_logsoc_20181231.csv')
dim(logsoc_mtl)

[1] 2741   20

2741 projets(ou bâtiments) 20 variables.

Préparation des données

Nom des variables dans le data set.

names(logsoc_mtl)

 [1] "numero"       "nom_projet"   "nom_rue"      "nb_log"       "hlm_familles"
 [6] "hlm_pa"       "hlm_autres"   "projettype"   "type_prog"    "an_orig"     
[11] "an_effect"    "arrond"       "villelie"     "qr"           "localisation"
[16] "aired_id"     "longitude"    "latitude"     "xnad83"       "ynad83"      

Les détails des prémieres 5 projets.

head(logsoc_mtl,5)

Dans ce data set, on intéressé notamment aux variables:projettype, arrond.

unique(logsoc_mtl$projettype)

[1] HLM  OMHM SHDM OBNL Coop
Levels: Coop HLM OBNL OMHM SHDM

unique(logsoc_mtl$arrond)

 [1] Ahuntsic-Cartierville                      
 [2] Lachine                                    
 [3] Le Sud-Ouest                               
 [4] Montréal-Nord                             
 [5] Rosemont–La Petite-Patrie                
 [6] Saint-Laurent                              
 [7] Villeray–Saint-Michel–Parc-Extension   
 [8] Ville-Marie                                
 [9] Mercier–Hochelaga-Maisonneuve            
[10]                                            
[11] Le Plateau-Mont-Royal                      
[12] LaSalle                                    
[13] Rivière-des-Prairies–Pointe-aux-Trembles
[14] Verdun                                     
[15] Côte-des-Neiges–Notre-Dame-de-Grâce    
[16] Outremont                                  
[17] Anjou                                      
[18] Saint-Léonard                             
[19] L'Île-Bizard–Sainte-Geneviève          
[20] Pierrefonds-Roxboro                        
20 Levels:  Ahuntsic-Cartierville ... Villerayâ\200“Saint-Michelâ\200“Parc-Extension

summary(logsoc_mtl)

     numero     
 Min.   :    3  
 1st Qu.:  888  
 Median : 1646  
 Mean   :18475  
 3rd Qu.:64121  
 Max.   :64913  
                
                                                                              nom_projet  
 Projet impliquant des groupes vulnérables de la population - Données obfusquées: 233  
 C.h. Village Cloverdale                                                           :  46  
 Inter-loge Centre-Sud                                                             :  38  
 Hab. de la SHAPEM                                                                 :  31  
 Hab. com. SOCAM                                                                   :  20  
 Hab. Loge accès                                                                  :  15  
 (Other)                                                                           :2358  
            nom_rue         nb_log        hlm_familles         hlm_pa       
                : 233   Min.   :  0.00   Min.   :  0.000   Min.   :  0.000  
 Barclay        :  33   1st Qu.:  6.00   1st Qu.:  0.000   1st Qu.:  0.000  
 Jeanne-Mance   :  32   Median : 10.00   Median :  0.000   Median :  0.000  
 Notre-Dame     :  29   Mean   : 22.68   Mean   :  3.598   Mean   :  3.935  
 Saint-Dominique:  28   3rd Qu.: 24.00   3rd Qu.:  0.000   3rd Qu.:  0.000  
 La Fontaine    :  26   Max.   :782.00   Max.   :210.000   Max.   :398.000  
 (Other)        :2360                                                       
   hlm_autres      projettype   type_prog       an_orig       an_effect   
 Min.   : 0.0000   Coop:1092         : 652   Min.   :1959   Min.   :1979  
 1st Qu.: 0.0000   HLM : 645   ACL   : 546   1st Qu.:1982   1st Qu.:1988  
 Median : 0.0000   OBNL: 624   Aucun :  79   Median :1988   Median :2002  
 Mean   : 0.3462   OMHM:  39   Autres:1393   Mean   :1990   Mean   :1999  
 3rd Qu.: 0.0000   SHDM: 341   LAQ   :  71   3rd Qu.:1996   3rd Qu.:2007  
 Max.   :58.0000                             Max.   :2018   Max.   :2017  
                                             NA's   :2      NA's   :2479  
                                     arrond                   villelie   
 Le Sud-Ouest                           :593                      :2699  
 Ville-Marie                            :420   Montréal-Est      :  10  
 Mercier–Hochelaga-Maisonneuve        :399   Côte-Saint-Luc    :   9  
 Le Plateau-Mont-Royal                  :208   Dollard-Des-Ormeaux:   5  
 Côte-des-Neiges–Notre-Dame-de-Grâce:194   Westmount          :   5  
 Rosemont–La Petite-Patrie            :194   Dorval             :   3  
 (Other)                                :733   (Other)            :  10  
       qr                             localisation     aired_id       
 30     : 275   Aire de diffusion           :2508   Min.   :24660011  
 47     : 238   Arrondissement / Ville liée: 233   1st Qu.:24661130  
        : 234                                       Median :24661781  
 50     : 161                                       Mean   :24661753  
 51     : 119                                       3rd Qu.:24662131  
 28     : 111                                       Max.   :24663453  
 (Other):1603                                       NA's   :233       
   longitude         latitude         xnad83           ynad83       
 Min.   :-73.95   Min.   :45.41   Min.   :269256   Min.   :5029845  
 1st Qu.:-73.62   1st Qu.:45.48   1st Qu.:295764   1st Qu.:5038128  
 Median :-73.58   Median :45.52   Median :298894   Median :5042504  
 Mean   :-73.59   Mean   :45.52   Mean   :297725   Mean   :5042540  
 3rd Qu.:-73.56   3rd Qu.:45.55   3rd Qu.:300341   3rd Qu.:5045396  
 Max.   :-73.49   Max.   :45.69   Max.   :305647   Max.   :5061670  
                                                                    

Exploration des données:

Logments Sociaux et Communautaires depuis 1960`s

library(dplyr) library(ggplot2)

year_group <- group_by(logsoc_mtl, an_orig)
logsoc_mtl_by_year <- summarise(year_group,
                          n = n())
logsoc_mtl_by_year <- logsoc_mtl_by_year[complete.cases(logsoc_mtl_by_year), ]

ggplot(data = logsoc_mtl_by_year, aes(x = an_orig, y = n))+
  geom_line(color = "#00AFBB", size = 2)+
  ylab('Nombre de logment') +
  xlab("Année ")+
  ggtitle('Logments Sociaux et Communautaires depuis 1960`s') +
  theme_bw()+ 
  geom_point(size = 1)+
  theme(plot.title = element_text(size = 14),
        axis.title = element_text(size = 12, face = "bold"))

Logments Sociaux et Communautaires selon les types

type_group <- group_by(logsoc_mtl, projettype)
logsoc_mtl_by_type <- summarise(type_group,
                          n = n())
logsoc_mtl_by_type <- logsoc_mtl_by_type[complete.cases(logsoc_mtl_by_type), ]
logsoc_mtl_by_type <- logsoc_mtl_by_type[order(logsoc_mtl_by_type$n, decreasing = TRUE), ]
logsoc_mtl_by_type

ggplot(aes(x = reorder(projettype, n), y = n), data = logsoc_mtl_by_type) +
  geom_bar(stat = 'identity', width = 0.5, fill = "#00AFBB") +
  geom_text(aes(label = n), stat = 'identity', data = logsoc_mtl_by_type, hjust = +0.5, size = 3.5) +
  xlab('Types de Projet') +
  ylab("Nombre de logments ") +
  ggtitle('Projet ou bâtiment selon le type de propriétaire et dencadrement général') +
  theme_bw() +
  theme(plot.title = element_text(size = 14),
        axis.title = element_text(size = 12, face = "bold"))

year_type_group <- group_by(logsoc_mtl, an_orig, projettype)
year_type <- summarise(year_type_group, n=n())
year_type <- year_type[complete.cases(year_type), ]

ggplot(aes(x=an_orig, y=n, color=projettype), data = year_type) + 
  geom_line(size=1.2) + 
  ggtitle("Logments Sociaux et Communautaires selon les types depuis 1960's") +
  ylab("Nombre d'occurrences ") +
  xlab('Année') +
  theme_bw() +
  theme(plot.title = element_text(size = 14),
        axis.title = element_text(size = 12, face = "bold"))

Logments Sociaux et Communautaires selon les Arrondissements

arrond_group <- group_by(logsoc_mtl, arrond)
logsoc_mtl_by_arrond <- summarise(arrond_group,
                          n = n())
logsoc_mtl_by_arrond <- logsoc_mtl_by_arrond[complete.cases(logsoc_mtl_by_arrond), ]
logsoc_mtl_by_arrond <- logsoc_mtl_by_arrond[order(logsoc_mtl_by_arrond$n, decreasing = TRUE), ]
logsoc_mtl_by_arrond

NA

ggplot(aes(x = reorder(arrond, n), y = n), data = logsoc_mtl_by_arrond) +
  geom_bar(stat = 'identity', width = 0.5, fill = "#FF6666") +
  geom_text(aes(label = n), stat = 'identity', data = logsoc_mtl_by_arrond, hjust = -0.1, size = 3.5) +
  coord_flip() +
  xlab('Arrondissements') +
  ylab("Nombre de logments ") +
  ggtitle('Logments Sociaux et Communautaires selon les Arrondissements') +
  theme_bw() +
  theme(plot.title = element_text(size = 14),
        axis.title = element_text(size = 12, face = "bold"))

K-Mean Clustering

Principe de segmentation: Maximiser l’homogénéité à l’intérieur de chaque groupe, maximiser l’hétérogénéité entre les groupes.

On va rechercher une meilleure façon de segmenter les arrondissements en utilsant la variable projettype.

library(tidyr)

by_groups <- group_by(logsoc_mtl, projettype, arrond)
groups <- summarise(by_groups, n=n())
groups <- groups[c("arrond", "projettype", "n")]
groups_wide <- spread(groups, key = projettype, value = n)
groups

groups_wide[is.na(groups_wide)] = 0
groups_wide

z <- groups_wide[, -c(1,1)]
z

Standardiser les donées à l’échelle pour la comparaison.

m <- apply(z, 2, mean)
s <- apply(z, 2, sd)
z <- scale(z, m, s)
z

             Coop         HLM        OBNL        OMHM        SHDM
 [1,] -0.74477086 -0.52222997 -0.25118096  0.02069108 -0.55534916
 [2,] -0.41619548 -0.02933876  0.08576911 -0.39313051 -0.03420039
 [3,] -0.79171019 -0.66305603 -0.92508110 -0.80695210 -0.55534916
 [4,] -0.16585233  0.08801629  0.72903742  0.02069108  1.30124335
 [5,] -0.85429598 -0.73346906 -0.95571293 -0.80695210 -0.55534916
 [6,] -0.52572060 -0.40487492 -0.61876286  0.02069108 -0.55534916
 [7,] -0.79171019 -0.52222997 -0.86381745 -0.80695210 -0.55534916
 [8,]  0.66340933  0.48702346  0.20829641 -0.39313051  0.06351501
 [9,]  2.35322556  3.13924758  2.26062865  2.50362063  2.99497687
[10,]  2.46275068  1.09726971  1.24977844  2.50362063  0.35666119
[11,] -0.38490258 -0.68652704  0.36145553  0.84833426 -0.55534916
[12,] -0.83864953 -0.70999805 -0.95571293 -0.80695210 -0.55534916
[13,] -0.02503431 -0.73346906 -0.25118096 -0.80695210 -0.55534916
[14,] -0.24408457 -0.38140391 -0.52686738  0.43451267 -0.55534916
[15,]  0.50694487  0.20537134  0.57587830  0.84833426 -0.16448758
[16,] -0.82300309 -0.66305603 -0.92508110 -0.80695210 -0.55534916
[17,] -0.77606375 -0.63958502 -0.71065833 -0.39313051 -0.55534916
[18,]  0.02190503 -0.63958502 -0.77192198 -0.39313051 -0.55534916
[19,]  1.21103496  1.59016092  2.26062865 -0.39313051  2.11553831
[20,]  0.16272304  0.72173356  0.02450546 -0.39313051  0.03094321
attr(,"scaled:center")
         Coop           HLM          OBNL          OMHM          SHDM 
 5.906869e-18  3.979022e-18  8.322353e-18 -1.459607e-17  6.422797e-18 
attr(,"scaled:scale")
Coop  HLM OBNL OMHM SHDM 
   1    1    1    1    1 

Déterminer le nombre de clusters k

Visualisation la matrice de distance

# 
fviz_dist(get_dist(z), gradient = list(low = "#00AFBB", mid = "#FFFFFF", high = "#FF6666"))

Calculer K en utilisant le sommes squares dans les groupes

wss <- (nrow(z)-1) * sum(apply(z, 2, var))
for (i in 2:10) wss[i] <- sum(kmeans(z, centers=i)$withiness)
plot(1:10, wss, type='b', xlab='Nombre de Clusters', ylab='Within groups sum of squares')

Le graphique indique le meilleur clustering: k=2.

Calculer K en utilisant le méthode Elbow

# 
fviz_nbclust(z, kmeans, method = "wss") +
    geom_vline(xintercept = 4, linetype = 2)+
  labs(subtitle = "Elbow method")

Le graphique indique le meilleur clustering: k=2,3,4.

Calculer K en utilisant le méthode Silhouette

fviz_nbclust(z, kmeans, method = "silhouette")+
  labs(subtitle = "Silhouette method")

Le graphique indique le meilleur clustering: k=2.

Calculer K en utilisant le méthode Gap statistic

# nboot = 50 to keep the function speedy. 
# recommended value: nboot= 500 for your analysis.
# Use verbose = FALSE to hide computing progression.
set.seed(123)
fviz_nbclust(z, kmeans, nstart = 25,  method = "gap_stat", nboot = 50)+
  labs(subtitle = "Gap statistic method")

Clustering k = 1,2,..., K.max (= 10): .. done
Bootstrapping, b = 1,2,..., B (= 50)  [one "." per sample]:
.................................................. 50 

Le graphique indique le meilleur clustering: k=1. On n’a pas besoin de segmentation.

Donc, selon les graphiques au-dessus, On choit k=2.

Calculer K-means clustering

set.seed(123)
km.res <- kmeans(z, 2, iter.max = 100, nstart = 25)
print(km.res)

K-means clustering with 2 clusters of sizes 17, 3

Cluster means:
        Coop        HLM       OBNL       OMHM       SHDM
1 -0.3545301 -0.3427458 -0.3394727 -0.2714183 -0.3215986
2  2.0090037  1.9422261  1.9236786  1.5380369  1.8223921

Clustering vector:
 [1] 1 1 1 1 1 1 1 1 2 2 1 1 1 1 1 1 1 1 2 1

Within cluster sum of squares by cluster:
[1] 21.19336 13.11647
 (between_SS / total_SS =  63.9 %)

Available components:

[1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
[6] "betweenss"    "size"         "iter"         "ifault"      

Le deuxième groupe comprend 3 arrodissements:Le Sud-Ouest,Mercier–Hochelaga-Maisonneuve,Ville-Marie. Le premier groupe compte les autres 16 arrodissements et une groupe de projets qui n’indque pas l’arrondissement.

Le graphique suivant indique les 2 clusters en utilisant le libraire(factoextra).

head(km.res$cluster,10)

 [1] 1 1 1 1 1 1 1 1 2 2

fviz_cluster(km.res, data = z, geom = "point",
             stand = FALSE) + theme_bw()

Le graphique suivant indique les 2 clusters en utilisant le libraire(cluster).

z1 <- data.frame(z, km.res$cluster)
clusplot(z1, km.res$cluster, color=TRUE, shade=F, labels=0, lines=0, main='Analyse de cluster k-Means')

PAM (k-methoid) Clustering avec le libaire(stat)

PAM(Partitioning Around Medoids).

pam.res <- pam(z,2)
print(pam.res)

Medoids:
     ID       Coop        HLM       OBNL       OMHM       SHDM
[1,] 17 -0.7760637 -0.6395850 -0.7106583 -0.3931305 -0.5553492
[2,] 15  0.5069449  0.2053713  0.5758783  0.8483343 -0.1644876
Clustering vector:
 [1] 1 1 1 2 1 1 1 2 2 2 2 1 1 1 2 1 1 1 2 2
Objective function:
   build     swap 
1.269655 1.256545 

Available components:
 [1] "medoids"    "id.med"     "clustering" "objective"  "isolation"  "clusinfo"  
 [7] "silinfo"    "diss"       "call"       "data"      

Le deuxième groupe comprend 8 arrodissements: Côte-des-Neiges–Notre-Dame-de-Grâce, Le Plateau-Mont-Royal, Le Sud-Ouest, Mercier–Hochelaga-Maisonneuve, Montréal-Nord, Rosemont–La Petite-Patrie, Ville-Marie, Villeray–Saint-Michel–Parc-Extensio; Le premier groupe compte les autres 11 arrodissements et une groupe de projets qui n’indque pas l’arrondissement.

Le résultat est différent que le sien du K-means parce que PAM utilise un élément (medoid) pour pésenter son groupe, pas le vraie means du groupe.

clusplot(z, pam.res$cluster, color=TRUE, shade=F, labels=0, lines=0, main='Analyse de cluster PAM')

Clara Clustering avec le libaire(stat)

CLARA (Clustering LARge Applications):Tire des échantillons successifs de la base et applique PAM à chaque échantillon, retourne le meilleur partitionnement obtenu.

clara.res <- clara(z, 2, metric = "euclidean", samples=50)
print(clara.res)

Call:    clara(x = z, k = 2, metric = "euclidean", samples = 50) 
Medoids:
           Coop        HLM       OBNL       OMHM       SHDM
[1,] -0.7760637 -0.6395850 -0.7106583 -0.3931305 -0.5553492
[2,]  0.5069449  0.2053713  0.5758783  0.8483343 -0.1644876
Objective function:  1.256545
Clustering vector:   int [1:20] 1 1 1 2 1 1 1 2 2 2 2 1 1 1 2 1 1 1 ...
Cluster sizes:           12 8 
Best sample:
 [1]  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20

Available components:
 [1] "sample"     "medoids"    "i.med"      "clustering" "objective"  "clusinfo"  
 [7] "diss"       "call"       "silinfo"    "data"      

clusplot(z, clara.res$cluster, color=TRUE, shade=F, labels=0, lines=0, main='Analyse de cluster Clara')

Le résultat du Clara est même que le sien du PAM parce que Clara utilise PAM pour trouver le meilleur clustering.

Hierarchical Clustering avec le libaire(stat)

z_df <- data.frame(z)

hc <- hclust(dist(z_df))
hc

Call:
hclust(d = dist(z_df))

Cluster method   : complete 
Distance         : euclidean 
Number of objects: 20 

plot(hc, labels = groups_wide$arrond, main='Cluster Dendrogram', cex=0.65)

counts = sapply(2:5,function(ncl)table(cutree(hc,ncl)))
names(counts) = 2:5
counts

$`2`

 1  2 
17  3 

$`3`

 1  2  3 
17  2  1 

$`4`

 1  2  3  4 
17  1  1  1 

$`5`

 1  2  3  4  5 
12  5  1  1  1 

Le counts indique le meilleur clustering, 2 groupes, le résultat est le même que le sien du K-means.

member <- cutree(hc, 2)
aggregate(z, list(member), mean)

Dans le groupe 1 (16 arrondissements + un groupe sans nom), tous les type de projet sont négatifs; dans le groupe 2 (3 arrondissements), tous les types de projet sont positifs.

plot(silhouette(cutree(hc, 2), dist(z_df)))

Le graphique de la silhouette indique que nous n’avons vraiment pas besoin du troisième groupe.

Faire une carte des Logments Sociaux et Communautaires de Montréal

On va utiliser ggmap pour produire une carte qui contient les logments sociaux et communautaires de Montréal.

lat <- logsoc_mtl$latitude
lon <- logsoc_mtl$longitude
projet_type <- logsoc_mtl$projettype
to_map <- data.frame(projet_type, lat, lon)
colnames(to_map) <- c('projet_type', 'lat', 'lon')
sbbox <- make_bbox(lon = logsoc_mtl$longitude, lat = logsoc_mtl$latitude, f = 0.01)
my_map <- get_map(location = sbbox, maptype = "roadmap", scale = 2, color="bw", zoom = 10)

ggmap(my_map) +
  geom_point(data=to_map, aes(x = lon, y = lat, color = "#FF6666"), 
             size = 1, alpha = 0.5) +
  xlab('Longitude') +
  ylab('Latitude') +
  ggtitle('Logments Sociaux et Communautaires de Montréal ') +
  guides(color=FALSE)

Dans cette carte on voit une grande concentration dans les arrondissements: ville-marie, Sud-Ouest et Mercier- Hochelata-Maisonneuve.

ggmap(my_map) +
  geom_point(data=to_map, aes(x = lon, y = lat, color = "#FF6666"), 
             size = 1, alpha = 0.5) +
  xlab('Longitude') +
  ylab('Latitude') +
  ggtitle('Type de projet des Logments Sociaux et Communautaires de Montréal ') +
  guides(color=FALSE) +
  facet_wrap(~ projet_type, nrow = 2)

Dans ces cartes on voit les concentrationa dans les arrondissements: ville-marie, Sud-Ouest et Mercier- Hochelata-Maisonneuve. Le nombre de OMHM est le minimum et le sien de Coop est le maximum.

Conclusion

Dans ce projet on a analysé les données des logments sociaux et communitaires de Montréal et on a segementé les arrondissements de Montréal selon les types de projets. On a calculé le meuiller K = 2 en utilisant des méthodes Elbow, Silhouette, Gap statistic etc. Et puis, on a utilisé les algorithems K-means, PAM, Clara, et CHA pour segmenter les arrodissements dans 2 groups: Groupe 2(ville-marie, Sud-Ouest et Mercier- Hochelata-Maisonneuve) et Groupe 1(les autres arrondissements). En fin, on a fait des cartes pour montrer les logements sociaux et communitaires de Montréal en utilisant les données spatiales dans le data set.