Comment modéliser des réseaux sociaux ?

Tabea Rebafka

Définition d’un graphe

Un graphe \(G=(V,E)\) est composé

d’un ensemble \(V=\{1,\dots,n\}\) de noeuds ou sommets (vertices) qui représentent les individus ou entités qui interagissent entre eux, et
d’un ensemble \(E\) d’ arêtes (edges) qui indiquent la présence d’une interaction ou connexion entre deux noeuds: \(\{i,j\}\in E\) s’il y a une arête entre les noeuds \(i\) et \(j\) dans \(G\).

Représentations équivalentes d’un graphe

Graphe visualisé

Ensemble de noeuds et d’arêtes

\(G=(V,E)\) avec ensemble de noeuds \(V=\{1,\dots,5\}\) et ensemble d’arêtes \(E=\{(1,3), (2,3), (2,4),(3,4)\}\).

Matrice d’adjacence

\[A=\begin{pmatrix} 0 & 0 & 1 & 0 & 0\\ 0 & 0 & 1 & 1 & 0\\ 1 & 1 & 0 & 1 & 0\\ 0 & 1 & 1 & 0 & 0\\ 0 & 0 & 0 & 0 & 0\\ \end{pmatrix} \]

Modèle d’Erdös-Rényi ou \(G(n,p)\)

Définition

Choisir un nombre de noeuds \(n\) et une probabilité de connexion \(p\)
Les arêtes du graphes sont tirées au hasard et indépendamment avec probabilité \(p\):

Les entrées \(A_{i,j}\) de la matrice d’adjacence sont des variables aléatoires indépendantes de loi de Bernoulli de paramètre \(p\): \[ A_{i,j}\sim\text{Bernoulli}(p), \quad \text{pour tout } i>j \] et on pose \(A_{i,j}=A_{j,i}\) pour tout \(i<j\).

En pratique

Choisir un nombre de noeuds :

n <- 5 
n

## [1] 5

Choisir une probabilité de connexion :

p <- 0.5 
p

## [1] 0.5

Créer une matrice d’adjacence “vide” :

A <- matrix(0, n, n) 
A

##      [,1] [,2] [,3] [,4] [,5]
## [1,]    0    0    0    0    0
## [2,]    0    0    0    0    0
## [3,]    0    0    0    0    0
## [4,]    0    0    0    0    0
## [5,]    0    0    0    0    0

Nombre de toutes les paires de noeuds :

N <- n*(n-1)/2
N

## [1] 10

Tier N réalisations d’une loi de Bernoulli de paramètre p (= jouer N fois à pile/face avec probabilité p) :

connexions <- rbinom(N, 1, p) 
connexions

##  [1] 1 0 0 1 1 0 0 1 1 0

Remplir la matrice d’adjacence :

A[lower.tri(A)] <- connexions 
A

##      [,1] [,2] [,3] [,4] [,5]
## [1,]    0    0    0    0    0
## [2,]    1    0    0    0    0
## [3,]    0    1    0    0    0
## [4,]    0    0    1    0    0
## [5,]    1    0    1    0    0

… et la symétriser :

A <- A + t(A) 
A

##      [,1] [,2] [,3] [,4] [,5]
## [1,]    0    1    0    0    1
## [2,]    1    0    1    0    0
## [3,]    0    1    0    1    1
## [4,]    0    0    1    0    0
## [5,]    1    0    1    0    0

rgraphER <- function(n, p){
  A <- matrix(0, n, n) # matrice d'adjacence à remplir
  N <- n*(n-1)/2 # nb de paires de noeuds 
  connexions <- rbinom(N, 1, p) # jouer N fois à pile/face avec proba p 
  A[lower.tri(A)] <- connexions # remplir la matrice d'adjacence
  A <- A + t(A) # symétriser la matrice
  
  return(A)
}

rgraphER(10, .1)

##       [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
##  [1,]    0    0    0    0    0    0    1    0    0     0
##  [2,]    0    0    0    0    0    0    0    0    0     0
##  [3,]    0    0    0    0    0    0    0    0    0     0
##  [4,]    0    0    0    0    0    0    0    0    0     0
##  [5,]    0    0    0    0    0    0    0    0    0     0
##  [6,]    0    0    0    0    0    0    0    1    0     0
##  [7,]    1    0    0    0    0    0    0    1    0     0
##  [8,]    0    0    0    0    0    1    1    0    0     0
##  [9,]    0    0    0    0    0    0    0    0    0     1
## [10,]    0    0    0    0    0    0    0    0    1     0

Exemple d’un réseau social

Charger un jeu de données contenant les connexions d’élèves d’une école primaire durant 2 jours :

load('PrimarySchoolNetwork.RData')

La matrice d’adjacence s’appelle primary

Taille de la matrice d’adjacence :

dim(primary)

## [1] 242 242

Visualiser le réseau :

library(igraph)

## 
## Attaching package: 'igraph'

## The following objects are masked from 'package:stats':
## 
##     decompose, spectrum

## The following object is masked from 'package:base':
## 
##     union

primaryIgraph <- graph_from_adjacency_matrix(primary, mode = "undirected")
plot(primaryIgraph)

Degrés de noeuds

Le degré du noeud \(i\) est le nombre de ses connexions :

\[ d_i = \sum_{j=1}^n A_{i,j} \]

degresPrimary <- rowSums(primary)
degresPrimary

##   [1]  83  47  82  64  37  71  94  39  95  76  32  96  53  77  57 111  98  63
##  [19]  48  61  84  53  46  98  44  95  81  49  65  76  83  59 106  82  76  73
##  [37]  93  33  39  56  41  72  40  71  23  47  49  92  96  26  46  55  59  79
##  [55]  70 134 123  68 101 100  58  97  78  86  51 106  63  71 122  44  79  70
##  [73]  97  39  32  56  54  20 111  38  72  34 104 111  63  47  35  58  53  36
##  [91]  70  54  54  46  82  33  55  85 123 110  49  57 124  75 104  50  43  40
## [109] 103  63  43  86 103  79 116  99 121  58  95  68  33  68 118  59  46  86
## [127]  56  32  82  22  58  90  84  95  68  80 108  58  73  38  47  52  35  60
## [145]  72  49  56  51  77  92  21  72  78  38 112  79  30 128  91  77 118  68
## [163]  85  96  31  65  53  70  62  44 129  70  72  80  69  90  70  89  66  64
## [181]  75  33  36  74  72  24  29  29  65  54  34  49  54  83 113  36  39 117
## [199]  78  40  96  90  92  89 111  61  47  89  88  51  88  80  30  29  97  35
## [217]  35  45  35  81  89  33  87 120  30  81  30  71  98  40  87  62  97  21
## [235]  97 111  53 109  34  44  71  64

plot(table(degresPrimary), xlab='degré', ylab='fréquence', main='Primary school dataset')

Densité d’arêtes

La densité d’arêtes d’un graphe est définie par

\(\alpha= \frac{\text{nb d'arêtes}}{\text{nb de paires de noeuds}}= \frac2{n(n-1)}\sum_{i<j}A_{i,j}\)

Densité d’un graphe d’Erdös-Rényi

Simuler un graphe :

A <- rgraphER(500, 0.4)

Calculer sa densité :

mean(A[lower.tri(A)])

## [1] 0.4027976

Dans un graphe Erdös-Rényi \(\alpha\approx\) p.

Plus n est grand, plus \(\alpha\) est proche de p.

D’après la loi des grands nombres, on a même :

\[ \alpha_n \stackrel{p.s.}{\longrightarrow} p \quad \text{ lorsque } n\to\infty. \]

Densité du réseau social

Densité du graphe social :

densPrim <- mean(primary[lower.tri(primary)])
densPrim

## [1] 0.2852097

Simuler un graphe d’Erdös-Rényi de même densité :

primER <- rgraphER(242, densPrim)

Calculons les degrés \(d_i\) de noeuds pour ce graphe :

degresPrimER <- rowSums(primER)
plot(table(degresPrimER), xlab='degré', ylab='fréquence', main='Erdös-Rényi graphe')

Comparons-les au réseau social :

v1 <- tabulate(degresPrimary)
v2 <- tabulate(degresPrimER)
m <- max(c(length(v1), length(v2)))
deg <- matrix(0, 2, m)
deg[1, 1:length(v1)] <- v1
deg[2, 1:length(v2)] <- v2
barplot(deg, beside = TRUE, col = c('blue', 'orange'), border=c('blue', 'orange'), main = 'Distribution des degrés des noeuds')
legend(300, 14, legend=c('Primary School', 'Erdös-Rényi'), col = c('blue', 'orange'), pch=16)

Conclusion : il est très peu probable que ce réseau social a été généré par un modèle Erdös-Rényi.

Nombre de triangles

Pour chaque noeud, nombre de triangles auxquel appartient le noeud :

count_triangles(primaryIgraph)

##   [1] 1804  620 1794 1046  456 1267 1953  540 2125 1534  421 2154  688 1517  857
##  [16] 2763 2019  992  541 1010 1625  830  573 2037  512 2018 1769  680 1140 1413
##  [31] 1785  777 2441 1550 1498 1409 1865  299  541  713  432 1307  366 1225  234
##  [46]  549  600 2041 2188  260  605  885  858 1409 1220 3528 3132 1156 2347 2071
##  [61]  898 2058 1719 1734  818 2424  952 1287 3091  614 1567 1349 2145  372  313
##  [76]  766  593  145 2479  377 1251  287 2380 2618  763  495  386  905  823  364
##  [91] 1305  642  662  469 1550  398  724 1727 3073 2597  596  709 3168 1328 2350
## [106]  629  501  496 2366  996  519 1611 2294 1477 2917 2255 3120  879 2280 1240
## [121]  369 1169 3065  934  652 1547  857  337 1704  229  911 1933 1969 2232 1317
## [136] 1495 2661  992 1393  464  793  823  381  930 1235  671  754  747 1547 1933
## [151]  210 1305 1425  360 2857 1302  267 3359 1897 1426 2866 1184 1803 2154  313
## [166] 1018  668 1140 1018  530 3633 1404 1072 1401 1111 1975 1196 2099  935 1061
## [181] 1101  352  451 1472 1152  215  260  254 1074  795  320  517  820 1432 3028
## [196]  432  389 3020 1319  412 2101 1978 2022 1650 2713  752  545 2054 1679  755
## [211] 2008 1518  306  259 1911  410  394  461  410 1386 1866  301 1784 3108  248
## [226] 1334  348 1227 2162  421 1728  909 2327  153 2242 2774  563 2703  319  504
## [241] 1262  997

Nombre moyen de triangles auxquels appartient un noeud du graphe :

mean(count_triangles(primaryIgraph))

## [1] 1286.281

Dans un graphe d’Erdös-Rényi :

primER <- rgraphER(242, densPrim)
primERIgraph <- graph_from_adjacency_matrix(primER, mode = "undirected")
mean(count_triangles(primERIgraph))

## [1] 687.4711

Modèle à blocs stochastiques ou SBM

extension du modèle d’Erdös-Rényi
garder la simplicité des variables Bernoulli indépendantes
mais varier les probabilités de connexion
en fonction de la “personnalité” des noeuds qui interagissent

Définition

Introduire pour chaque noeud \(i\) une étiquette \(Z_i\) à valeur dans \(\{1,…,K\}\) :

\(Z_i\), \(i=1,…,n\) i.i.d. avec \(\mathbb P(Z_i=k)=\pi_k\) pour \(k=1,\dots,K\)
\(\pi_1,…,\pi_K\) sont les proportions des blocs
Conditionnellement aux \(Z_1,…,Z_n\), les arêtes \(A_{i,j}, i<j\) sont indépendantes de loi Bernoulli :

Si \(Z_i=k, Z_j=l\) alors \(A_{i,j} \sim\text{Bernoulli}(p_{k,l})\)
Les \(p_{k,l}\) sont les probabilités de connexions entre les différents blocs

En pratique

Fitter un modèle SBM aux données primary (pour cela il faut utiliser un algorithme sophisitiqué) :

library(blockmodels)
fittedSBM <- BM_bernoulli("SBM_sym", primary)
fittedSBM$estimate()

Nombre de blocs \(K\) choisi par l’algorithme :

which.max(fittedSBM$ICL)

## [1] 17

Répartition des élèves dans les blocs :

blocs <- apply(fittedSBM$memberships[[17]]$Z, 1, which.max)
table(blocs)

## blocs
##  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 
## 15 10  9 14 13 16  8 29 19 12 20 12  5 17 19 15  9

Comparer le clustering à la répartition des élèves dans les 10 classes :

classes <- read.table("metadata_primaryschool.txt")
table(classes$V2, blocs)

##           blocs
##             1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17
##   1A        0  0  0  0  0  0  0  0 19  0  0  0  4  0  0  0  0
##   1B        0  0  0 14  0  0  0  0  0 11  0  0  0  0  0  0  0
##   2A        0  0  9  0  0  0  0  0  0  0  0  0  0  0  0 14  0
##   2B       14  0  0  0  0  0  0  0  0  0  0 12  0  0  0  0  0
##   3A        0  2  0  0  0  0  0  0  0  0  6  0  0 15  0  0  0
##   3B        0  8  0  0  0  0  0  0  0  0 12  0  0  2  0  0  0
##   4A        0  0  0  0 13  0  0  0  0  0  0  0  0  0  0  0  8
##   4B        0  0  0  0  0 15  8  0  0  0  0  0  0  0  0  0  0
##   5A        0  0  0  0  0  0  0 12  0  0  0  0  0  0 10  0  0
##   5B        0  0  0  0  0  0  0 17  0  0  0  0  0  0  7  0  0
##   Teachers  1  0  0  0  0  1  0  0  0  1  2  0  1  0  2  1  1

Simuler un SBM avec les mêmes paramètres

rsbm <- function(n, param){
  K <- length(param$pi)
  Z <- sample(1:K, n, replace=TRUE, prob=param$pi)
  # adjacency matrix
  A <- matrix(0, n, n)
  for (i in 1:(n-1)){
    A[i, (i+1):n] <- A[(i+1):n, i] <- rbinom(n-i, 1, param$gamma[Z[i],Z[(i+1):n]])
  }
  return(list(adj=A, Z=Z))
}

param <- list(pi = colMeans(fittedSBM$memberships[[17]]$Z), 
              gamma = fittedSBM$model_parameters[[17]]$pi
              )

primSBM <- rsbm(242, param)

degresPrimSBM <- rowSums(primSBM$adj)

v3 <- tabulate(degresPrimSBM)
m <- max(c(length(v1), length(v3)))
deg <- matrix(0, 2, m)
deg[1, 1:length(v1)] <- v1
deg[2, 1:length(v3)] <- v3
barplot(deg, beside = TRUE, col = c('blue', 'orange'), border=c('blue', 'orange'), main = 'Distribution des degrés des noeuds')
legend(300, 7, legend=c('Primary School', 'SBM'), col = c('blue', 'orange'), pch=16)

MathsClub

2024-02-26

Comment modéliser des réseaux sociaux ?

Tabea Rebafka

Définition d’un graphe

Représentations équivalentes d’un graphe

Graphe visualisé

Ensemble de noeuds et d’arêtes

Matrice d’adjacence

Modèle d’Erdös-Rényi ou \(G(n,p)\)

Définition

En pratique

Densité d’arêtes

Densité d’un graphe d’Erdös-Rényi

Nombre de triangles

Modèle à blocs stochastiques ou SBM

Définition

En pratique

Simuler un SBM avec les mêmes paramètres