1. Das Projekt

Das Projekt zielt darauf ab, die Entwicklung von Freundschaftssubnetzwerken zu untersuchen, welche von Studierenden, die Soft Drugs konsumieren, gebildet wurden. Die Daten für die Untersuchung wurden in den Jahren 1996 und 1997 durch die Befragung der Studienanfänger zu fünf unterschiedlichen Zeitpunkten erhoben. Abgefragt wurden die persönlichen Merkmale, Interessen und Aktivitäten sowie die Art der Beziehungen der Studierenden, die zum jeweiligen Befragungszeitpunkt bestanden. Diese Daten befinden sich auf der Siena Webpage der University of Oxford.

In dem Projekt wurde insbesondere den folgenden Fragestellungen nachgegangen:

Wie verändert sich die Fragmentierung der Subnetzwerke sowie die Anzahl und die Art der Beziehungen innerhalb der Subnetzwerke im Laufe der Zeit?
Spielen die Personen, deren Soft Drugs Konsum eher höher ist, eine besondere Rolle innerhalb der Subnetzwerke?
Wie entwickeln sich die wichtigen Centralization-Parameter der Subnetzwerke?
Bilden die Akteure der Subnetzwerke abgesonderte Cliquen innerhalb der Gesamtnetzwerke der Studierenden?
Handelt es sich bei diesen Subnetzwerken um Smallworlds?
Haben die gleichen oder unterschiedliche Faktoren die Entwicklung und Veränderung der Gesamtnetwerke und der Subnetzwerke von Studinenanfängern beeinflusst?

2. Ladung der Pakete

library(igraph)
library(dplyr)
library(ggplot2)
library(writexl)
library(gridExtra)
library(cowplot)
library(grid)
library(lemon)
library(qgraph)

3. Datenbearbeitung

Die Daten liegen in Form von 7 DAT-Dateien vor. Fünf von sieben Dateien beinhalten Soziomatrizen, die die Beziehungen zwischen den Studierenden zu den Zeitpunkten t = 1 (Beginn des Studienjahres), t = 2 (3 Wochen später), t = 3 (6 Wochen später), t = 4 (13 Wochen später) und t = 5 (35 Wochen später) beschreiben. Insgesamt wurden 38 Studierende befragt. Die Anzahl der abgegebenen Fragebögen pro Messzeitpunkt war 38, 25, 28, 18 und 18.

Die zwei weiteren Dateien beinhalten die Listen der individuellen Informationen über die Studierenden (Attribute), die zwei mal zu den Zeitpunkten t = 1 und t = 4 abgefragt wurden. In dem Zeitpunkt t = 1 haben alle 38 Studierenden ihre Fragebögen abgegeben, in dem Zeitpunkt t = 4 nur 27. Aufgrund der fehlenden Werte wurde die letzgenannte Liste aus dieser Untersuchnung ausgeschlossen. Die erstgenannte Liste aus dem Zeitpunkt t = 1 enthält 21 Attribut-Variablen wie z. B. Gender, Program, Smoking, Soft Drugs, Doing sport oder Religious involvement.

3.1 Ladung der Attribute

Ladung der Attributen-Liste zum Zeitpunkt t = 1:

attr <- read.table("cov1.dat") # Laden der Daten
class(attr)

## [1] "data.frame"

head(attr)

##   V1 V2 V3 V4 V5 V6 V7 V8 V9 V10 V11 V12 V13 V14 V15 V16 V17 V18 V19 V20 V21
## 1  1  1  1  2  1 21 29 34 13   8  25  42  42  42  42  42  42  34   4   2   3
## 2  2  1  1  0  2 24 28 36  7   2  22   2  29  36  36  23  32  28   4   2   2
## 3  3  1  1  0  1 24 21 13 42  34  21  21  29  25  21  29  21  29   4   3   3
## 4  4  1  2  0  2 30  6 21  0  32  21  21  38  36  17  21  21  35   4   3   3
## 5  5  1  1  0  1 38 17 29 40  29  34   1  21   4  21  38   0  25   5   4   3
## 6  6  1  2  0  1 18  4 21 10  26   5   0  38  14  10   5   2  32   3   2   2

Auswahl und Benennung der Attribute:

Für das Projekt wurden neben den Personen-ids und der Attribut-Variable Soft Drugs noch die Variablen Gender, Program und Smoking ausgewählt. Die Variable Program gibt an, welches Studium-Programm (das reguläre vierjährige oder das spezielle zweijährige) die Studenten an der Universität durchlaufen. Das verkürzte Programm wurde von Studierenden gewählt, die bereits eine höhere Berufsausbildung abgeschlossen haben. Diese Studierenden besuchen z. T. andere Veranstaltungen als die regulären Studierenden. Außerdem sind sie älter (Durchschnittsalter 22 Jahre) als die regulären Studierenden (Durchschnittsalter 18 Jahre). Der Auswahl der Variablen erfolgte im Einklang mit Forschungsergebnissen, die eine hohe Signifikanz der ausgewählten Variablen für das gesamte Netzwerk zeigten¹.

df.attr <- attr[, c("V1", "V2", "V3", "V4","V5")] # Auswahl der Attribute
names(df.attr) <- c("id", "Gender", "Program", "Smoking", "Drugs") # Benennung der Attribute
head(df.attr)

##   id Gender Program Smoking Drugs
## 1  1      1       1       2     1
## 2  2      1       1       0     2
## 3  3      1       1       0     1
## 4  4      1       2       0     2
## 5  5      1       1       0     1
## 6  6      1       2       0     1

Umkodierung:

Die Variablen Smoking und Soft Drugs wurden umkodiert, weil die ursprüngliche Kodierung sehr ausdifferenziert war. Die Personen, die entweder nicht oder nur auf Parties rauchen, wurden als Nichtraucher kodiert. Alle regelmäßig rauchenden Studierenden wurden als Raucher kodiert, unabhängig davon, wie viel Zigaretten pro Tag sie rauchen.

df.attr$Smoking[df.attr$Smoking < 3] <- 1 # Nichtraucher
df.attr$Smoking[df.attr$Smoking >= 3] <- 2 # Raucher

Die Variable Soft Drugs wurde zwei mal umkodiert. Die neue Varialbe Drug_dif beschreibt die Personen, die Soft Drugs nicht, relativ wenig (bis zu 3 mal pro Monat) oder relativ viel (1 mal pro Woche oder mehr) konsumierten. Die Variable Drugs wurde dichtonomisiert und beschreibt die Personen, die Soft Drugs entweder konsumieren oder nicht. Die Konsummengen wurden hier nicht berücksichtigt.

df.attr$Drugs_dif <- df.attr$Drugs
df.attr$Drugs_dif[df.attr$Drugs_dif < 2] <- 9 # Nicht-Konsumenten
df.attr$Drugs_dif[df.attr$Drugs_dif >= 2 & df.attr$Drugs_dif < 4 ] <- 1 # Wenig-Konsumenten
df.attr$Drugs_dif[df.attr$Drugs_dif >= 4 & df.attr$Drugs_dif < 9] <- 2 # Viel-Konsumenten

df.attr$Drugs[df.attr$Drugs < 2] <- 1 # Nicht-Konsumenten
df.attr$Drugs[df.attr$Drugs >= 2] <- 2 # Konsumenten
head(df.attr)

##   id Gender Program Smoking Drugs Drugs_dif
## 1  1      1       1       1     1         9
## 2  2      1       1       1     2         1
## 3  3      1       1       1     1         9
## 4  4      1       2       1     2         1
## 5  5      1       1       1     1         9
## 6  6      1       2       1     1         9

3.2 Ladung der Soziomatrizen

Die Angaben zu der Art der Beziehung zwischen den Studierenden wurden von den Forschern in Form der kodierten Soziomatrizen abgespeichert. Die kodierten Arten von Beziehungen waren 0 = unbekannt, 1 = beste Freunde, 2 = Freunde, 3 = freundschaftliche Beziehung, 4 = neutrale Beziehung, 5 = problematische Beziehung, 6 = item non-response, 9 = actor non-response. Damit sind die Zahlen 6 und 9 fehlende Werte. Da die Studenten keine Angaben zu der Beziehung mit sich selbst machten, wurden die Diagonalen der Matrizen mit 9 besetzt. So wurden zuerst die Angaben in Diagonalen in 0 und danach die Zahlen 6 und 9 in NAs umgewandelt.

Die oben genannten Angaben zu der Art der Beziehungen zwischen den Studierenden wurden umkodiert. Die Kategorien unbekannt, neutrale Beziehungen und problematische Beziehungen wurden als 0, freundschaftliche Beziehungen als 1, Freunde und beste Freunde als 3 kodiert. Die letzten zwei Kategorien wurden zusammengefasst, weil sie beide zu klein waren. Damit wurden bei dieser Untersuchung nur Freundschaften und freundschaftliche Beziehungen berücksichtigt.

Ladung der Soziomatrizen:

stud1 <- read.table("t1.dat")
stud2 <- read.table("t2.dat")
stud3 <- read.table("t3.dat")
stud4 <- read.table("t4.dat")

Soziomatrix in t = 1:

dim(stud1)

## [1] 38 38

head(stud1)

##   V1 V2 V3 V4 V5 V6 V7 V8 V9 V10 V11 V12 V13 V14 V15 V16 V17 V18 V19 V20 V21
## 1  9  0  0  0  0  0  0  0  0   0   0   0   0   0   0   0   0   0   0   0   0
## 2  0  9  0  0  0  0  0  0  0   0   0   0   0   0   0   0   0   0   0   0   0
## 3  0  0  9  0  0  0  0  0  0   0   0   0   0   0   0   0   0   0   0   0   0
## 4  0  0  0  9  0  4  0  0  0   0   0   0   0   0   0   0   0   0   0   0   2
## 5  0  0  0  0  9  0  0  0  0   0   0   0   0   0   0   0   0   0   0   0   0
## 6  0  0  0  0  0  9  0  0  0   0   0   0   0   0   0   0   0   0   0   0   0
##   V22 V23 V24 V25 V26 V27 V28 V29 V30 V31 V32 V33 V34 V35 V36 V37 V38
## 1   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0
## 2   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0
## 3   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0
## 4   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0
## 5   2   0   0   0   0   0   4   0   0   0   0   0   0   0   0   0   0
## 6   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0

Umkodierung:

class(stud1)

## [1] "data.frame"

diag(stud1) <- 0 # Umwandlung der Angaben in Diagonalen in 0
stud1[stud1 == 9 | stud1 == 6] <- NA # Umwandlung der Werte 6 und 9 in NAs
rownames(stud1) <- colnames(stud1) <- c(1:38)

stud_neu1 <- stud1*10
stud_neu1[stud_neu1 == 10] <- 3 # beste Freunde... 
stud_neu1[stud_neu1 == 20] <- 3 # und Freunde werden zusammengefasst
stud_neu1[stud_neu1 == 30] <- 1 # freundschaftliche Beziehungen
stud_neu1[stud_neu1 == 40] <- 0 # neutrale...
stud_neu1[stud_neu1 == 50] <- 0 # und problematische Beziehungen als 0
head(stud_neu1)

##   1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
## 1 0 0 0 0 0 0 0 0 0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## 2 0 0 0 0 0 0 0 0 0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## 3 0 0 0 0 0 0 0 0 0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## 4 0 0 0 0 0 0 0 0 0  0  0  0  0  0  0  0  0  0  0  0  3  0  0  0  0  0  0  0  0
## 5 0 0 0 0 0 0 0 0 0  0  0  0  0  0  0  0  0  0  0  0  0  3  0  0  0  0  0  0  0
## 6 0 0 0 0 0 0 0 0 0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##   30 31 32 33 34 35 36 37 38
## 1  0  0  0  0  0  0  0  0  0
## 2  0  0  0  0  0  0  0  0  0
## 3  0  0  0  0  0  0  0  0  0
## 4  0  0  0  0  0  0  0  0  0
## 5  0  0  0  0  0  0  0  0  0
## 6  0  0  0  0  0  0  0  0  0

Soziomatrix in t = 2

class(stud2)

## [1] "data.frame"

diag(stud2) <- 0
stud2[stud2 == 9 | stud2 == 6] <- NA
rownames(stud2) <- colnames(stud2) <- c(1:38)

Umkodierung:

stud_neu2 <- stud2*10
stud_neu2[stud_neu2 == 10] <- 3
stud_neu2[stud_neu2 == 20] <- 3
stud_neu2[stud_neu2 == 30] <- 1
stud_neu2[stud_neu2 == 40] <- 0
stud_neu2[stud_neu2 == 50] <- 0
head(stud_neu2)

##   1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
## 1 0 0 0 0 0 0 0 0 0  0  0  0  0  3  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## 2 1 0 0 0 0 0 0 0 0  0  0  0  0  0  0  0  0  0  1  0  0  0  0  1  0  0  0  0  0
## 3 1 0 0 1 1 1 0 0 0  0  0  0  0  1  0  0  0  0  0  1  1  1  0  0  1  0  0  1  0
## 4 0 0 0 0 0 3 0 0 0  0  0  0  0  0  0  0  0  0  0  0  1  0  0  0  0  0  0  0  0
## 5 1 0 1 0 0 0 0 0 0  0  0  0  0  1  0  0  0  0  0  0  0  3  0  0  0  0  0  3  0
## 6 0 0 1 3 0 0 3 1 0  0  0  3  3  1  0  1  1  1  0  0  3  0  0  0  0  1  0  0  0
##   30 31 32 33 34 35 36 37 38
## 1  0  0  0  0  0  0  0  0  0
## 2  0  0  0  0  0  0  0  1  0
## 3  0  0  0  0  0  0  0  0  0
## 4  0  0  0  0  0  0  0  0  0
## 5  0  0  0  0  0  0  0  0  0
## 6  0  0  0  0  0  0  0  0  0

Soziomatrix in t = 3:

class(stud3)

## [1] "data.frame"

diag(stud3) <- 0
stud3[stud3 == 9 | stud3 == 6] <- NA
rownames(stud3) <- colnames(stud3) <- c(1:38)

Umkodierung:

stud_neu3 <- stud3*10
stud_neu3[stud_neu3 == 10] <- 3
stud_neu3[stud_neu3 == 20] <- 3
stud_neu3[stud_neu3 == 30] <- 1
stud_neu3[stud_neu3 == 40] <- 0
stud_neu3[stud_neu3 == 50] <- 0
head(stud_neu3)

##    1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
## 1  0  1  1  0  0  0  0  0  0  0  0  0  0  3  0  0  0  0  0  0  1  1  0  0  1  0
## 2  1  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  3  0  0  0 NA  3  0  0
## 3 NA NA  0 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA
## 4 NA NA NA  0 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA
## 5  1  0  1  0  0  0  0  0  0  0  0  0  0  1  0  0  0  0  0  0  0  3  0  0  0  0
## 6 NA NA NA  3 NA  0 NA NA NA NA NA NA NA NA NA NA NA NA NA NA  0 NA NA NA NA NA
##   27 28 29 30 31 32 33 34 35 36 37 38
## 1  0  1  0  0  0  0  0  0  0  0  0  0
## 2  0  0  0  0  0  0  0  0  0  0  3  0
## 3 NA NA NA NA NA NA NA NA NA NA NA NA
## 4 NA NA NA NA NA NA NA NA NA NA NA NA
## 5  0  3  0  0  0  0  0  0  0  0  0  0
## 6 NA NA NA NA NA NA NA NA NA NA NA NA

Soziomatrix in t = 4:

class(stud4)

## [1] "data.frame"

diag(stud4) <- 0
stud4[stud4 == 9 | stud4 == 6] <- NA
rownames(stud4) <- colnames(stud4) <- c(1:38)

Umkodierung:

stud_neu4 <- stud4*10
stud_neu4[stud_neu4 == 10] <- 3
stud_neu4[stud_neu4 == 20] <- 3
stud_neu4[stud_neu4 == 30] <- 1
stud_neu4[stud_neu4 == 40] <- 0
stud_neu4[stud_neu4 == 50] <- 0
head(stud_neu4)

##    1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
## 1  0  1  0  0  1  1  0  0  0  1  0  0  0  3  0  0  0  0  0  0  1  0 NA  1  1  0
## 2  1  0  0  0  0  0  0  0  0  0  0  0  0  0  1  0  0  0  3  0  0  0 NA  3  0  0
## 3 NA NA  0 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA
## 4 NA NA NA  0 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA
## 5 NA NA NA NA  0 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA
## 6 NA NA NA NA NA  0 NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA
##   27 28 29 30 31 32 33 34 35 36 37 38
## 1  0  1  0  0  0  0  0  0  0  0  0  0
## 2  0  0  0  0  0  0  0  0  0  0  3  0
## 3 NA NA NA NA NA NA NA NA NA NA NA NA
## 4 NA NA NA NA NA NA NA NA NA NA NA NA
## 5 NA NA NA NA NA NA NA NA NA NA NA NA
## 6 NA NA NA NA NA NA NA NA NA NA NA NA

Wie man sieht, enthalten die Soziomatrizen für die Zeitpunkte t = 2, t = 3 und t = 4 relativ viele NAs, weil zu diesen Zeitpunkten nur jeweils 25, 28 und 18 Studierende ihre Fragebögen abgegeben haben.

4. Umwandlung der Matrizen in Graphen

4.1 Erstellung der Graphen für Gesamtnetzwerke

Als nächster Schritt wurden die Soziomatrizen, die als Data Frames abgespeichert waren, in Graphen umgewandelt. Die NAs (falls vorhanden) wurden entfernt. Der Zwischenschritt der Umwandlung der Graphen stud_g in Data Frames df_stud war eingentlich unnötig, schaffte aber eine bessere Übersichtichkeit und damit auch leichtere Kontrolle der Daten. Als Ergebnis bekommt man vier gerichtete und gewichtete Netzwerk-Graphen mit den Knoten-Attributen Name, Gender, Program, Smoking, Drugs und Drugs_dif sowie mit dem Kanten-Attribut Weight. Die Anzahl der Knoten (also Studierenden) liegt in jedem der vier Graphen bei 38, auch wenn relativ viele Studierenden in Zeitpunkten t = 2 bis t = 4 ihre Fragebögen nicht abgegeben haben. Das liegt daran, dass die anderen Studierenden in ihren Fragebögen die Angaben über die Art der Beziehungen mit diesen Studierenden machten. Die fehlenden Fragebögen beeinflussen aber stark die Anzahl der Kanten. Die Anzahl der Kanten (Beziehungen) liegt in dem Graph net1 bei 19, im net2 bei 121, im net3 bei 147 und im net4 bei 129. Der Rückgang der Anzahl der Beziehungen im Zeitpunkt t = 4 hängt wahrscheinlich mit den vielen nicht abgegebenen Fragebögen (insg. 20) zusammen. In den früheren Zeitpunkten t = 2 und t = 3 wurden jeweils 13 und 10 Fragebögen nicht abgegeben. In dem Zeitpunkt t = 1 haben alle Studierenden ihre Fragebögen abgegeben. Zum Schluss wurde den Graphen noch ein zusätzliches Knoten-Attribut color angehängt. Dieser wird für die leichtere Visualisierung der Soft Drugs-Konsumenten verwendet.

Netzwerk in t = 1:

class(stud_neu1)

## [1] "data.frame"

stud_mat1 <- as.matrix(stud_neu1) # df zu Matrix
stud_g1 <- graph.adjacency(stud_mat1,weighted=TRUE) # Matrix zu Graph
df_stud1 <- get.data.frame(stud_g1) # Graph zu df
colnames(df_stud1) <- c("Source", "Target", "Weight")
head(df_stud1)

##   Source Target Weight
## 1      4     21      3
## 2      5     22      3
## 3     16     17      3
## 4     16     26      3
## 5     17     16      3
## 6     21      4      3

net1 <- graph_from_data_frame(d = df_stud1, vertices=df.attr, directed = T) # df zu Graph mit Attributen 
colrs <- c("gold", "tomato") 
V(net1)$color <- colrs[V(net1)$Drugs] # zusätzlicher Attribut 
length(V(net1))

## [1] 38

length(E(net1))

## [1] 19

net1

## IGRAPH f17e15b DN-- 38 19 -- 
## + attr: name (v/c), Gender (v/n), Program (v/n), Smoking (v/n), Drugs
## | (v/n), Drugs_dif (v/n), color (v/c), Weight (e/n)
## + edges from f17e15b (vertex names):
##  [1] 4 ->21 5 ->22 16->17 16->26 17->16 21->4  21->6  21->20 22->5  26->16
## [11] 28->1  28->5  28->22 30->9  30->11 30->15 30->27 32->36 36->32

Netzwerk in t = 2:

class(stud_neu2)

## [1] "data.frame"

stud_mat2 <- as.matrix(stud_neu2)
stud_g2 <- graph.adjacency(stud_mat2,weighted=TRUE)
df_stud2 <- get.data.frame(stud_g2)
colnames(df_stud2) <- c("Source", "Target", "Weight")
df_cleaned2 <- na.omit(df_stud2)
net2 <- graph_from_data_frame(d = df_cleaned2, vertices=df.attr, directed = T)
colrs <- c("gold", "tomato")
V(net2)$color <- colrs[V(net2)$Drugs]
length(V(net2))

## [1] 38

length(E(net2))

## [1] 121

net2

## IGRAPH f1938c1 DN-- 38 121 -- 
## + attr: name (v/c), Gender (v/n), Program (v/n), Smoking (v/n), Drugs
## | (v/n), Drugs_dif (v/n), color (v/c), Weight (e/n)
## + edges from f1938c1 (vertex names):
##  [1] 1 ->14 2 ->1  2 ->19 2 ->24 2 ->37 3 ->1  3 ->4  3 ->5  3 ->6  3 ->14
## [11] 3 ->20 3 ->21 3 ->22 3 ->25 3 ->28 4 ->6  4 ->21 5 ->1  5 ->3  5 ->14
## [21] 5 ->22 5 ->28 6 ->3  6 ->4  6 ->7  6 ->8  6 ->12 6 ->13 6 ->14 6 ->16
## [31] 6 ->17 6 ->18 6 ->21 6 ->26 7 ->12 7 ->13 7 ->18 9 ->10 9 ->11 9 ->15
## [41] 9 ->20 9 ->23 11->1  11->15 12->4  12->6  12->7  12->13 12->18 13->4 
## [51] 13->5  13->6  13->7  13->12 13->16 13->17 13->18 15->11 15->21 15->36
## [61] 16->13 16->17 16->18 16->26 17->4  17->6  17->13 17->14 17->16 17->18
## + ... omitted several edges

Netzwerk in t = 3:

class(stud_neu3)

## [1] "data.frame"

stud_mat3 <- as.matrix(stud_neu3)
stud_g3 <- graph.adjacency(stud_mat3,weighted=TRUE)
df_stud3 <- get.data.frame(stud_g3)
colnames(df_stud3) <- c("Source", "Target", "Weight")
df_cleaned3 <- na.omit(df_stud3)
net3 <- graph_from_data_frame(d = df_cleaned3, vertices = df.attr, directed = T)
colrs <- c("gold", "tomato")
V(net3)$color <- colrs[V(net3)$Drugs]
length(V(net3))

## [1] 38

length(E(net3))

## [1] 147

net3

## IGRAPH f1a8b1b DN-- 38 147 -- 
## + attr: name (v/c), Gender (v/n), Program (v/n), Smoking (v/n), Drugs
## | (v/n), Drugs_dif (v/n), color (v/c), Weight (e/n)
## + edges from f1a8b1b (vertex names):
##  [1] 1 ->2  1 ->3  1 ->14 1 ->21 1 ->22 1 ->25 1 ->28 2 ->1  2 ->19 2 ->24
## [11] 2 ->37 5 ->1  5 ->3  5 ->14 5 ->22 5 ->28 6 ->4  7 ->12 7 ->13 7 ->18
## [21] 9 ->10 9 ->11 9 ->15 9 ->20 10->8  10->9  10->15 10->36 11->9  12->4 
## [31] 12->6  12->7  12->13 12->18 13->4  13->6  13->7  13->12 13->16 13->17
## [41] 13->18 13->26 14->1  14->2  14->3  14->4  14->5  14->6  14->8  14->9 
## [51] 14->11 14->15 14->16 14->17 14->19 14->21 14->22 14->24 14->25 14->26
## [61] 14->28 14->37 14->38 15->9  15->10 15->11 15->36 16->13 16->17 16->18
## + ... omitted several edges

Netzwerk in t = 4:

class(stud_neu4)

## [1] "data.frame"

stud_mat4 <- as.matrix(stud_neu4)
stud_g4 <- graph.adjacency(stud_mat4,weighted=TRUE)
df_stud4 <- get.data.frame(stud_g4)
colnames(df_stud4) <- c("Source", "Target", "Weight")
df_cleaned4 <- na.omit(df_stud4)
net4 <- graph_from_data_frame(d = df_cleaned4, vertices = df.attr, directed = T)
colrs <- c("gold", "tomato")
V(net4)$color <- colrs[V(net4)$Drugs]
length(V(net4))

## [1] 38

length(E(net4))

## [1] 129

net4

## IGRAPH f1bc2cb DN-- 38 129 -- 
## + attr: name (v/c), Gender (v/n), Program (v/n), Smoking (v/n), Drugs
## | (v/n), Drugs_dif (v/n), color (v/c), Weight (e/n)
## + edges from f1bc2cb (vertex names):
##  [1] 1 ->2  1 ->5  1 ->6  1 ->10 1 ->14 1 ->21 1 ->24 1 ->25 1 ->28 2 ->1 
## [11] 2 ->15 2 ->19 2 ->24 2 ->37 7 ->4  7 ->6  7 ->12 7 ->13 7 ->16 7 ->17
## [21] 7 ->18 9 ->10 9 ->11 9 ->15 9 ->20 9 ->29 9 ->36 9 ->38 10->9  10->11
## [31] 10->15 10->26 10->30 10->36 10->38 11->2  11->9  11->10 11->15 11->32
## [41] 11->36 11->38 12->4  12->6  12->7  12->13 12->18 14->1  14->3  14->4 
## [51] 14->5  14->6  14->9  14->11 14->13 14->15 14->16 14->17 14->21 14->22
## [61] 14->25 14->28 14->38 15->10 15->11 15->36 15->38 16->17 16->18 16->26
## + ... omitted several edges

4.2 Erstellung der Subgraphen

Als letzter Schritt der Datenaufbereitung wurden die Subgraphen der Soft Drugs Konsumenten erstellt. Für die Erstellung der Subgraphen für Soft Drugs Konsumenten wurden aus den Netzwerken die Knoten der Nicht-Konsumenten ausgeschlossen. In den Subgraphen wurde zusäzlich das Knoten-Attribut color geändert, so dass man jetzt bei der Visualisierung der Subgraphen zwischen den viel- und wenig- Konsumierenden unterscheiden kann.

Erstellung der Subgraphen Soft Drugs:

drug_vector <- df.attr$id[df.attr$Drugs_dif < 3] # alle Konsumenten der Soft Drugs
sub1 <- induced_subgraph(net1, which(V(net1)$name %in% drug_vector) )
col <- c("steelblue", "#8E44AD")
V(sub1)$color <- col[V(sub1)$Drugs_dif] # neues Attribut color

sub2 <- induced_subgraph(net2, which(V(net2)$name %in% drug_vector) )
col <- c("steelblue", "#8E44AD")
V(sub2)$color <- col[V(sub2)$Drugs_dif]

sub3 <- induced_subgraph(net3, which(V(net3)$name %in% drug_vector) )
col <- c("steelblue", "#8E44AD")
V(sub3)$color <- col[V(sub3)$Drugs_dif]

sub4 <- induced_subgraph(net4, which(V(net4)$name %in% drug_vector) )
col <- c("steelblue", "#8E44AD")
V(sub4)$color <- col[V(sub4)$Drugs_dif]

5. Sichtung der Attribute

5.1 Visualisierung der Attributen in gesamten Netzwerken

Zunächst wurde die Verteilung der Attribut-Variablen im gesamten Netzwerk visualisiert. Der Anteil der Studentinnen liegt bei 63,16%. 60,53% der Studierenden nahmen an einem regulären Programm teil. Der Anteil der Raucher liegt bei 34,21% und der Anteil der Konsumenten der Soft Drugs bei 42,1%.

ggplot(df.attr, aes(x = as.factor(Gender), y = after_stat(count), fill = as.factor(Gender))) + geom_bar(width = 0.5)+
  scale_fill_manual(values = c("steelblue", "darkred")) +
  geom_text(stat = "count", aes(label = after_stat(count)), vjust = -0.5) +
  scale_x_discrete(labels = c("1" = "Men", "2" = "Women")) +
  theme_bw() +
  theme(legend.position = "none") +
  labs(x = "Gender", y = "Häufigkeit", caption = "Abbildung 1.") +
  ggtitle("Verteilung Geschlecht")

(24/38)*100 # Anteil der Frauen

## [1] 63.15789

ggplot(df.attr, aes(x = as.factor(Program), y = after_stat(count), fill = as.factor(Program))) +
  geom_bar(width = 0.5) + 
  scale_fill_manual(values = c("lightblue", "darkblue")) +
  geom_text(stat = "count", aes(label = ..count..), vjust = -0.5) +
  theme_bw() +
  theme(legend.position = "none") +
  labs(x = "Program", y = "Häufigkeit", caption = "Abbildung 2.") +
  scale_x_discrete(labels = c("1" = "4-year program", "2" = "2-year program")) +
  ggtitle("Verteilung Program")

(23/38)*100 # Anteil reguläres Programms

## [1] 60.52632

ggplot(df.attr, aes(x = as.factor(Smoking), y = after_stat(count), fill = as.factor(Smoking))) +
  geom_bar(width = 0.5) + 
  scale_fill_manual(values = c("yellowgreen", "gold")) +
  geom_text(stat = "count", aes(label = ..count..), vjust = -0.5) +
  theme_bw() +
  theme(legend.position = "none") +
  labs(x = "Smoking", y = "Häufigkeit", caption = "Abbildung 3.") +
  scale_x_discrete(labels = c("1" = "no", "2" = "yes")) +
  ggtitle("Verteilung Smoking")

(13/38)*100 # Anteil Raucher

## [1] 34.21053

ggplot(df.attr, aes(x = as.factor(Drugs), y = after_stat(count), fill = as.factor(Drugs))) +
  geom_bar(width = 0.5) + 
  scale_fill_manual(values = c("gold", "tomato")) +
  geom_text(stat = "count", aes(label = ..count..), vjust = -0.5) +
  theme_bw() +
  theme(legend.position = "none") +
  labs(x = "Soft Drugs", y = "Häufigkeit", caption = "Abbildung 4.") +
  scale_x_discrete(labels = c("1" = "no", "2" = "yes")) +
  ggtitle("Verteilung Soft Drugs")

(16/38)*100 # Anteil Soft Drugs-Konsumenten

## [1] 42.10526

5.2 Visualisierung der Attributen in Subnetzwerken

Als nächstes wurde die Verteilung der Attribut-Variablen in den Subnetzwerken visualisiert und mit der Verteilung der Variablen in den gesamten Netzwerken verglichen. Die Verteilungen der Variable Gender unterscheiden sich wenig. Der Anteil der Frauen in den gesamten Netwerken liegt bei 63,16% und bei 62,5% in den Subnetzwerken. Der Anteil der Studierenden des regulären Programms in den gesamten Netwerken liegt bei 60,5% und in den Subnetzwerken bei 68,75%. Das bedeutet auch, dass die Anzahl der jüngeren Personen in den Subnetzwerken etwas höher ist, als in den gesamten Netzwerken. Deutlich stärker unterscheidet sich die Verteilung der Raucher. Der Anteil der Raucher in den gesamten Netzwerken beträgt 34,21% und 50% in den Subnetzwerken. Der Anteil der Personen, die eher viel Soft Drugs konsumieren liegt bei 31,25%.

df.sub <- df.attr[df.attr$Drugs == 2, ] # die Soft Drugs-Konsumenten werden extrahiert
dim(df.sub)

## [1] 16  6

names(df.sub)

## [1] "id"        "Gender"    "Program"   "Smoking"   "Drugs"     "Drugs_dif"

ggplot(df.sub, aes(x = as.factor(Gender), y = after_stat(count), fill = as.factor(Gender))) + geom_bar(width = 0.5)+
  scale_fill_manual(values = c("steelblue", "darkred")) +
  geom_text(stat = "count", aes(label = ..count..), vjust = -0.5) +
  scale_x_discrete(labels = c("1" = "Men", "2" = "Women")) +
  theme_bw() +
  theme(legend.position = "none") +
  labs(x = "Gender", y = "Häufigkeit", caption = "Abbildung 5.") +
  ggtitle("Verteilung Gender in Subgraphen")

(10/16)*100 # Anteil der Frauen

## [1] 62.5

ggplot(df.sub, aes(x = as.factor(Program), y = after_stat(count), fill = as.factor(Program))) +
  geom_bar(width = 0.5) + 
  scale_fill_manual(values = c("lightblue", "darkblue")) +
  geom_text(stat = "count", aes(label = ..count..), vjust = -0.5) +
  theme_bw() +
  theme(legend.position = "none") +
  labs(x = "Program", y = "Häufigkeit", caption = "Abbildung 6.") +
  scale_x_discrete(labels = c("1" = "4-year program", "2" = "2-year program")) +
  ggtitle("Verteilung Program in Subgraphen")

(11/16)*100 # Anteil reguläres Programms

## [1] 68.75

ggplot(df.sub, aes(x = as.factor(Smoking), y = after_stat(count), fill = as.factor(Smoking))) +
  geom_bar(width = 0.5) + 
  scale_fill_manual(values = c("yellowgreen", "gold")) +
  geom_text(stat = "count", aes(label = ..count..), vjust = -0.5) +
  theme_bw() +
  theme(legend.position = "none") +
  labs(x = "Smoking", y = "Häufigkeit", caption = "Abbildung 7.") +
  scale_x_discrete(labels = c("1" = "no", "2" = "yes")) +
  ggtitle("Verteilung Smoking in Subgraphen")

(8/16)*100 # Anteil Raucher

## [1] 50

df.drugs <- df.attr[df.attr$Drugs_dif < 3,]
ggplot(df.drugs, aes(x = as.factor(Drugs_dif), y = after_stat(count), fill = as.factor(Drugs_dif))) +
  geom_bar(width = 0.5) + 
  scale_fill_manual(values = c("steelblue", "#8E44AD")) +
  geom_text(stat = "count", aes(label = ..count..), vjust = -0.5) +
  theme_bw() +
  theme(legend.position = "none") +
  labs(x = "Soft Drugs", y = "Häufigkeit", caption = "Abbildung 8.") +
  scale_x_discrete(labels = c("1" = "wenig", "2" = "viel")) +
  ggtitle("Verteilung Soft Drugs in Subgraphen")

(8/16)*100 # Anteil der Viel-Konsumenten

## [1] 50

6. Analyse der Netzwerke

6.1 Visualisierung der Subnetzwerke

In diesem Schritt wurden die Subnetzwerke visualisiert und die Anzahl ihrer strukturellen Komponenten miteinander verglichen.

set.seed(404)
par(mfrow=c(1,2))
degrees <- degree(sub1)
min_size <- 6
node_sizes <- pmax(degrees*5, min_size)
plot(sub1, 
     main = "Soft Drugs t = 1",
     vertex.frame.color = "grey80",
     vertex.size = node_sizes,
     edge.width = E(sub1)$Weight,
     edge.arrow.size = .2,
     sub ="Abbildung 9.")
legend(x="bottomleft", c("wenig", "viel"), pch=21,
       col="#777777", pt.bg=col, pt.cex=2, cex=.8, bty="n", ncol=1)
l <- layout_with_fr(sub2)
l <- norm_coords(l, ymin=-1, ymax=1, xmin=-1, xmax=1)
degrees <- degree(sub2)
min_size <- 6
node_sizes <- pmax(degrees*5, min_size)
plot(sub2, 
     main = "Soft Drugs t = 2",
     rescale=F, 
     layout=l*1,
     vertex.frame.color = "grey80",
     vertex.size = node_sizes,
     edge.width = E(sub2)$Weight,
     edge.arrow.size = .2,
     sub ="Abbildung 10.")
legend(x="bottomleft", c("wenig", "viel"), pch=21,
       col="#777777", pt.bg=col, pt.cex=2, cex=.8, bty="n", ncol=1)

set.seed(404)
par(mfrow=c(1,2))
l <- layout_with_fr(sub3)
l <- norm_coords(l, ymin=-1, ymax=1, xmin=-1, xmax=1)
degrees <- degree(sub3)
min_size <- 6
node_sizes <- pmax(degrees*5, min_size)
plot(sub3, 
     main = "Soft Drugs t = 3",
     vertex.frame.color = "grey80",
     vertex.size = node_sizes,
     edge.width = E(sub3)$Weight,
     edge.arrow.size = .2,
     rescale=F, 
     layout=l*0.9,
     sub ="Abbildung 11.")
legend(x="bottomleft", c("wenig", "viel"), pch=21,
       col="#777777", pt.bg=col, pt.cex=2, cex=.8, bty="n", ncol=1)
degrees <- degree(sub4)
min_size <- 6
node_sizes <- pmax(degrees*5, min_size)
plot(sub4, 
     main = "Soft Drugs t = 4",
     vertex.frame.color = "grey80",
     vertex.size = node_sizes,
     edge.width = E(sub4)$Weight,
     edge.arrow.size = .2,
     sub ="Abbildung 12.")
legend(x="bottomleft", c("wenig", "viel"), pch=21,
       col="#777777", pt.bg=col, pt.cex=2, cex=.8, bty="n", ncol=1)

Anzahl der Knoten und Kanten:

length(E(sub1)); length(V(sub1))

## [1] 3

## [1] 16

length(E(sub2)); length(V(sub2))

## [1] 24

## [1] 16

length(E(sub3)); length(V(sub3))

## [1] 24

## [1] 16

length(E(sub4)); length(V(sub4))

## [1] 20

## [1] 16

Anzahl der Komponente:

comp1 <- components(sub1, mode = c("weak"))
comp2 <- components(sub2, mode = c("weak"))
comp3 <- components(sub3, mode = c("weak"))
comp4 <- components(sub4, mode = c("weak"))

comp1$no;comp1$csize

## [1] 14

##  [1] 1 3 1 1 1 1 1 1 1 1 1 1 1 1

comp2$no;comp2$csize

## [1] 4

## [1] 10  3  2  1

comp3$no;comp3$csize

## [1] 2

## [1] 15  1

comp4$no;comp4$csize

## [1] 4

## [1] 13  1  1  1

Das Subnetzwerk zum Zeitpunkt t = 1 ist noch sehr stark fragmentiert und besteht aus 14 nicht miteinander verbundenen Komponenten. 13 davon sind die Einzelknoten. Die 14te Komponente besteht aus nur drei Knoten. Wahrscheinlich handelt es sich um Personen, die sich noch vor dem Studiumbeginn kannten. Zum Zeitpunkt t = 2 besteht das Subnetzwerk schon nur aus vier Komponenten mit der Knotenanzahl von 10, 3, 2 und 1. Zum Zeitpunkt t = 3 gibt es nur zwei Komponenten mit der Größe 15 und 1. D. h., dass zu diesem Zeitpunkt fast alle Studierenden (mit einer Ausnahme), die Soft Drugs konsumierten, sich durch Freundschaften oder freundschaftliche Beziehungen miteinander verbunden haben. Zum Teitpunkt t = 4 gibt es wieder vier Komponente. Die größte Komponente besteht aus 13 Knoten, bei drei weiteren Komponenten handelt es sich um Einzelknoten.

6.2 Ermittlung der Freundschaften

In diesem Teil wurde die Veränderung der Anzahl der Freundschaften und freundschaftlicher Beziehungen ermittelt. Zum Zeitpunkt t = 1 sind drei wahrscheinlich bereits bestandene Freundschaften die einzigen Beziehungen im Netzwerk. Zum Zeitpunkt t = 2 gibt es 20 freundschaftliche Beziehungen. Die Anzahl der Freundschaften steigt leicht von drei auf vier an. Zum Zeitpunkt t = 3 verdopplt sich die Anzahl der Freundschaften und liegt nun bei 8. Die Anzahl der freundschaftlichen Beziehungen sinkt auf 16. Zum Zeitpunkt t = 4 sinkt die Anzahl von Freundschaften auf 5 und die Anzahl der freundschaftlichen Beziehungen auf 15.

table(E(sub1)$Weight) # Freundschaft wird mit 3 gewichtet

## 
## 3 
## 3

table(E(sub2)$Weight)

## 
##  1  3 
## 20  4

table(E(sub3)$Weight)

## 
##  1  3 
## 16  8

table(E(sub4)$Weight)

## 
##  1  3 
## 15  5

6.3 Berechnung der Centrality-Parameter

In diesem Abschnitt wurden mithilfe der zentralen knotenbasierten Parameter ermittelt, welche Akteure sich besonders aktiv an der Kommunikation innerhalb der Subnetzwerke und damit auch an dem Aufbau des Netzwerkes beteiligten, sowie welche Akteure die einzelnen Cluster in Subnetzwerken verbanden und damit ebenfalls zu dem Aufbau der Subnetzwerke beitrugen. Die Frage nach der Aktivität wurde mithilfe des Parameters Degree Centrality beantwortet. Dieser gibt an, welche Akteure die meisten Beziehungen haben und gilt als Index für communication activity. Die Frage nach der Verbindung zwischen den Clustern wurde mithilfe vom Parameter Betweenness beantwortet. Betweennes gibt an, welche Akteure sich auf den kürzesten Pfaden zwischen den anderen Akteuren befanden. Obwohl die Subnetzwerke gerichtet sind, wurde auf die ausdifferenzierte Ermittlung der In- (Empfänger der Freundschaftsbeziehungen) und Outdegrees (Absender der Freundschaftsbeziehungen) verzichtet. Auch auf die Ermittlung der Degrees in t = 1 wurde verzichtet, da zu diesem Zeitpunkt das Subnetzwerk noch sehr klein war und aus Personen bestand, die sich noch vor dem Studiumbeginn kannten.

Berechnung der Degrees und Betweenness in t = 2:

df2 <- data.frame(Name = V(sub2)$name, 
                  Degree = degree(sub2,normalized = T),
                  Bet = betweenness(sub2, normalized = T),
                  Gender = V(sub2)$Gender,
                  Program = V(sub2)$Program,
                  Drugs = V(sub2)$Drugs_dif,
                  Smoking = V(sub2)$Smoking)

Geordnet nach Degrees:

df_degree2 <- df2[order(-df2$Degree),]
head(df_degree2)

##    Name    Degree         Bet Gender Program Drugs Smoking
## 24   24 0.5333333 0.021428571      1       1     2       2
## 19   19 0.4666667 0.011904762      2       1     2       2
## 2     2 0.3333333 0.000000000      1       1     1       1
## 25   25 0.3333333 0.000000000      2       1     2       2
## 37   37 0.2666667 0.000000000      2       1     1       2
## 4     4 0.2000000 0.004761905      1       2     1       1

Geordnet nach Betweenness:

df_bet2 <- df2[order(-df2$Bet),]
head(df_bet2)

##    Name    Degree         Bet Gender Program Drugs Smoking
## 24   24 0.5333333 0.021428571      1       1     2       2
## 19   19 0.4666667 0.011904762      2       1     2       2
## 4     4 0.2000000 0.004761905      1       2     1       1
## 2     2 0.3333333 0.000000000      1       1     1       1
## 8     8 0.2000000 0.000000000      2       1     2       2
## 9     9 0.2000000 0.000000000      2       1     1       1

ggplot(df2, aes(x = Degree, y = Bet, shape = factor(Drugs))) + geom_point(aes(color = factor(Drugs)), size = 3) + labs(name = "Drugs") + ggtitle("Degrees und Betweenness t = 2") +
  scale_color_manual(values = c("lightblue", "#8E44AD"), name = "Drugs", labels = c("wenig", "viel")) +
  scale_shape(name = "Drugs", labels = c("wenig", "viel")) +
  labs(x = "Degrees", y = "Betweenness", caption = "Abbildung 13.") +
  theme_bw()

Die Berechnung zeigt, dass zum Zeitpunkt t = 2 die Akteure 24 und 19 die höchsten Degree Centrality-Werte haben. Diesselben Akteure haben auch höchsten Betweenness Centrality-Werte (was nicht zwingend der Fall sein müsste). Es handelt sich um einen Mann und eine Frau, die an einem regulären Programm teilnehmen, rauchen und eher viel Soft Drugs konsumieren. Die Wichtigkeit der Akteure für Zeitpunkt t = 2, die eher viel Soft Drugs konsumierten, verdeutlicht die Abbildung 13 sowie die Abbildung 10, die das Subnetzwerk in t = 2 zeigt. Die Knotengröße hängt hier von der Anzahl der Degrees ab.

df3 <- data.frame(Name = V(sub3)$name, 
                  Degree = degree(sub3, normalized = T),
                  Bet = betweenness(sub3, normalized = T),
                  Gender = V(sub2)$Gender,
                  Program = V(sub2)$Program,
                  Drugs = V(sub3)$Drugs_dif,
                  Smoking = V(sub3)$Smoking)

df_degree3 <- df3[order(-df3$Degree),]
head(df_degree3)

##    Name    Degree         Bet Gender Program Drugs Smoking
## 20   20 0.4666667 0.076190476      2       2     1       1
## 9     9 0.4000000 0.076190476      2       1     1       1
## 37   37 0.4000000 0.009523810      2       1     1       2
## 2     2 0.2666667 0.000000000      1       1     1       1
## 8     8 0.2000000 0.000000000      2       1     2       2
## 10   10 0.2000000 0.004761905      2       1     1       1

df_bet3 <- df3[order(-df3$Bet),]
head(df_bet3)

##    Name    Degree         Bet Gender Program Drugs Smoking
## 9     9 0.4000000 0.076190476      2       1     1       1
## 20   20 0.4666667 0.076190476      2       2     1       1
## 21   21 0.2000000 0.038095238      1       2     1       2
## 37   37 0.4000000 0.009523810      2       1     1       2
## 10   10 0.2000000 0.004761905      2       1     1       1
## 2     2 0.2666667 0.000000000      1       1     1       1

ggplot(df3, aes(x = Degree, y = Bet, shape = factor(Drugs))) + geom_point(aes(color = factor(Drugs)), size = 3) + labs(name = "Drugs") + ggtitle("Degrees und Betweenness in t = 3") +
  scale_color_manual(values = c("lightblue", "#8E44AD"), name = "Drugs", labels = c("wenig", "viel")) +
  scale_shape(name = "Drugs", labels = c("wenig", "viel")) +
  labs(x = "Degrees", y = "Betweennness", caption = "Abbildung 14.") +
  theme_bw()

Zum Zeitpunkt t = 3 hatten zwei andere Personen 20 und 9 die höchsten Degree- und Betweenness-Werte. Beide Personen sind weiblich, rauchen nicht und kosumieren eher wenig Soft Drugs. Eine Frau nimmt an einem regulären Programm und die andere an einem verkürzten Programm teil. Diese Entwicklung im Hinblick auf den Konsum der Soft Drugs der wichtigen Akteure ist auf den Abbildungen 14 und 11 zu sehen.

df4 <- data.frame(Name = V(sub4)$name, 
                  Degree = degree(sub4, normalized = T),
                  Bet = betweenness(sub4, normalized = T),
                  Gender = V(sub2)$Gender,
                  Program = V(sub2)$Program,
                  Drugs = V(sub4)$Drugs_dif,
                  Smoking = V(sub4)$Smoking)

df_degree4 <- df4[order(-df4$Degree),]
head(df_degree4)

##    Name    Degree        Bet Gender Program Drugs Smoking
## 9     9 0.4666667 0.05000000      2       1     1       1
## 11   11 0.4000000 0.05238095      2       1     1       1
## 2     2 0.2666667 0.04523810      1       1     1       1
## 10   10 0.2666667 0.00000000      2       1     1       1
## 21   21 0.2666667 0.00000000      1       2     1       2
## 29   29 0.2666667 0.00952381      1       1     2       2

df_bet4 <- df4[order(-df4$Bet),]
head(df_bet4)

##    Name     Degree        Bet Gender Program Drugs Smoking
## 11   11 0.40000000 0.05238095      2       1     1       1
## 9     9 0.46666667 0.05000000      2       1     1       1
## 2     2 0.26666667 0.04523810      1       1     1       1
## 29   29 0.26666667 0.00952381      1       1     2       2
## 4     4 0.06666667 0.00000000      1       2     1       1
## 8     8 0.00000000 0.00000000      2       1     2       2

ggplot(df4, aes(x = Degree, y = Bet, shape = factor(Drugs))) + geom_point(aes(color = factor(Drugs)), size = 3) + ggtitle("Degree und Betweenness in t = 4") +
  scale_color_manual(name = "Drugs", values = c("lightblue", "#8E44AD"), labels =c("wenig", "viel")) +
  scale_shape(name = "Drugs", labels = c("wenig", "viel")) +
  labs(x = "Degrees", y = "Betweenness", caption = "Abbildung 15.") +
  theme_bw()

Im Zeitpunkt t = 4 hat wieder die Person 9 die höchsten Degree- und Betweenness-Werte. Die Person 20 mit den höchsten Werten im Zeitpunkt t = 3 wurde durch die Person 11 ersetzt. So sind die beiden Personen mit den höchsten Parameter-Werten weiblich, Teilnehmerinnen des regulären Programms, Nichtraucherinnen und konsumieren eher wenig Soft Drugs. Dies zeigen die Abbildungen 15 und 12. Zusammenfassend lässt sich sagen, dass zu allen Zeitpunkten die Frauen sowie die Personen, die an dem regulären Programm teilnahmen, besonders aktiv bei dem Aufbau der Subnetzwerke waren. Die beiden Gruppen stellen auch eine Mehrheit innerhalb der Subnetzwerke dar. In der früheren Phase der Netzwerkbildung waren besonders Raucher und die viel-Konsumenten der Soft Drugs aktiv. Die Raucher stellen 50% und die viel-Konsumenten 31,25% der Netzwerk-Akteure dar. In der späteren Phase übernahmen wenig-Konsumenten und Nichtraucher die aktive Rolle. Die aktive Rolle der Raucher in der frühen Phase lässt sich vermutlich dadurch erklären, dass die rauchenden Personen sich relativ früh in den Raucherbereichen kennengelernt haben. Die Berechnung mit der Kreuztabelle zeigte, dass alle viel-Konsumenten der Soft Drugs auch Raucher waren.

kreuztabelle <- xtabs(~Drugs_dif + Smoking, data = df.attr)
colnames(kreuztabelle) <- c("no", "yes")
rownames(kreuztabelle) <- c("less", "much", "no")
kreuztabelle

##          Smoking
## Drugs_dif no yes
##      less  8   3
##      much  0   5
##      no   17   5

6.4 Berechnung der zentralen Parameter (Centralization)

In diesem Abschnitt wurden die zentralen Parameter ermittelt, die nicht individuelle Knoten, sondern die gesamten Netzwerke beschreiben. Ermittelt wurde Density, Degree Centralization und Betweenness Centralization. Density beschreibt wie viele von allen möglichen Beziehungen innerhalb der Netzwerke tatsächlich realisiert worden sind. Im Vergleich zu bereits in der Arbeit berechneten Degree Centrality, die eine normalisierte Anzahl der Beziehungen eines Knotens beschreibt, gibt die Degree Centralization die Summe der Differenzen zwischen dem höchsten Degree Centrality-Wert und allen anderen Degree Centrality-Werten an. Dasselbe gilt für die Betweenness Centralization, welche die Summe der Differenzen zwischen dem höchsten Betweenness Centrality-Wert und allen anderen Betweenness Centrality-Werten angibt. Die beiden letzgenannten Parameter beschreiben also die Tendenz zur Zentralisierung des Netzwerkes im Hinblick auf die jeweiligen Parameter Degree und Betweenness.

  cal_centralization <- function(dataset) {
  data(list= dataset)
  assign("g",get(dataset))
  dens <- edge_density(g)
  deg <- centralization.degree(g)$centralization
  bet <- centralization.betweenness(g)$centralization
  df <- data.frame(dens = dens, cent.deg = deg, cent.bet = bet, network = dataset)
  return(df)
}

liste <- data(sub1, sub2, sub3, sub4)
output.liste<-lapply(liste, cal_centralization)
class(output.liste)

## [1] "list"

ergebnis <- do.call(rbind, output.liste)
head(ergebnis)

##         dens   cent.deg    cent.bet network
## 1 0.01250000 0.09333333 0.004761905    sub1
## 2 0.10000000 0.17777778 0.020317460    sub2
## 3 0.10000000 0.14222222 0.067619048    sub3
## 4 0.08333333 0.16000000 0.045396825    sub4

ggplot(ergebnis, aes(x = network, y = dens)) +
  geom_point(color = "darkred", size = 2.5) +
  labs(x = "Networks", y = "Density", caption = "Abbildung 16.") +
  ggtitle("Density") +
  theme_bw()

Die Dichte der Subnetzwerke bleibt zu allen Zeitpunkten bei einem größtmöglichen Wert von 1 relativ gering. Sie steigt aber merkbar zum Zeitpunkt t = 2 von 0,0125 auf 0,1, veränderte sich nicht zum Zeitpunkt t = 3, weil in dieser Periode sowohl die Antahl von Knoten als auch von Kanten gleich blieb, und sank dann leicht zum Zeitpunkt t = 4 auf 0,0833. Diese Entwicklung zeigt die Abbildung 16.

ggplot(ergebnis, aes(x = cent.bet, y = cent.deg, color = factor(network))) + geom_point(size = 3) + labs(x = "Betweenness", y = "Degrees", caption = "Abbildung 17.") + ggtitle("Degree Centralization und Betweennes Centralization") +
  scale_color_manual(values = c("lightblue", "steelblue", "darkblue", "#8E44AD"), name = "Networks", labels = c("sub1", "sub2", "sub3", "sub4")) +
  theme_bw()

Der Degree Centralization-Wert verhält sich schwankend. Er steigt wie erwartet zum Zeitpunkt t = 2 von 0,093 auf 0,178, sinkt zum Zeitpunkt t = 3 auf 0,142 und steigt wieder zum Zeitpunkt t = 4 auf 0,16. Der Betweenness Centralization-Wert steigt kontinuierlich von 0.0048 in t =1 bis 0,068 in t = 3. Zum Zeitpunkt t = 4 sinkt er leicht auf 0,045. Diese Entwicklungen zeigt die Abbildung 17.

6.5 Communities

6.5.1 Communities der Gesamtnetzwerke

Im nächsten Schritt wurden die gesamten Netzwerke in Communities bzw. Cliquen zerlegt, um rauszufinden, ob die Akteure der Subnetzwerke ihre eigenen Cliquen innerhalb der gesamten Netzwerke bilden. Die Communities wurden mit dem Modularity-Ansatz ermittlet. Bei diesem Ansatz werden die Communties als Gruppen der Knoten verstanden, die relativ dicht untereinander verbunden sind, aber relativ wenig Beziehungen mit anderen Knoten bzw. Knotengruppen haben. Die Ermittlung der Communities erfolgt durch die Identifikation der Knoten mit hohen Betweenness-Werten, welche zwischen den Communities liegen und diese Communities damit verbinden. Für die Ermittlung der Communities in dieser Arbeit wurden unterschiedliche Algorithmen ausprobiert. Die besten Ergebnisse wurden mit dem Louvain-Algorithmus erzielt.

set.seed(123)
G2 <- as.undirected(net2) # Louvain funktioniert nicht mit gerichteten Beziehungen
louv <- cluster_louvain(G2)
louv

## IGRAPH clustering multi level, groups: 7, mod: 0.51
## + groups:
##   $`1`
##   [1] "1"  "3"  "5"  "14" "21" "22" "28"
##   
##   $`2`
##   [1] "2"  "8"  "19" "20" "24" "25" "37"
##   
##   $`3`
##    [1] "4"  "6"  "7"  "12" "13" "16" "17" "18" "26" "33"
##   
##   $`4`
##   + ... omitted several groups/vertices

coord <- layout.fruchterman.reingold(G2)
par(mfrow=c (1,2))
plot.igraph(G2, 
            main = "Gruppen in t =2\nGesamtes Netzwerk",
            layout = coord,
            vertex.color = louv$membership,
            sub ="Abbildung 18.")
plot.igraph(G2, 
            main = "Soft Drugs in t =2\nGesamtes Netzwerk",
            layout = coord,
            sub ="Abbildung 19.")
legend(x="bottomleft", c("no Soft Drugs", "Soft Drugs"), pch=21,
       col="#777777", pt.bg=colrs, pt.cex=2, cex=.8, bty="n", ncol=1)

Wie man auf der Abbildung 18 sehen kann, wurde das gesamte Netzwerk im Zeitpunkt t = 2 in vier (wenn man drei nicht verbundene Einzelknoten nicht berücksichtigt) Cliquen aufgeteilt. Die Cliquen sind farblich gekennzeichnet. Die Abbildung 19 zeigt den gleichen Graphen. Farblich gekennzeichnet sind hier jedoch nicht die Cliquen, sondern die Konsumenten und Nicht-Konsumenten der Soft Drugs. Der Vergleich der beiden Abbildungen zeigte, dass die blaue Clique (group 2, 7 Personen) allein aus Konsumenten der Soft Drugs besteht. Die relativ große, sichtbar locker verbundene gelbe Clique (group 4, 11 Personen) besteht fast zur Hälfte aus der Konsumenten der Soft Drugs. In zwei weiteren Cliquen (group 1, 7 Personen und group 3, 10 Personen) stellen die Konsumenten der Soft Drugs eine Minderheit dar (jeweils 1 und 2 Personen).

G3 <- as.undirected(net3)
louv <- cluster_louvain(G3)
louv

## IGRAPH clustering multi level, groups: 4, mod: 0.45
## + groups:
##   $`1`
##    [1] "1"  "2"  "3"  "5"  "8"  "14" "19" "22" "24" "25" "28" "37"
##   
##   $`2`
##    [1] "4"  "6"  "7"  "12" "13" "16" "17" "18" "21" "26" "33" "35"
##   
##   $`3`
##    [1] "9"  "10" "11" "15" "20" "23" "27" "29" "30" "31" "32" "36" "38"
##   
##   $`4`
##   + ... omitted several groups/vertices

coord <- layout.fruchterman.reingold(G3)
par(mfrow=c (1,2))
plot.igraph(G3, 
            main = "Gruppen in t =3\nGesamtes Netzwerk",
            layout = coord,
            vertex.color = louv$membership,
            sub ="Abbildung 20.")
plot.igraph(G3,
            main = "Soft Drugs in t =3\nGesamtes Netzwerk",
            layout = coord,
            sub ="Abbildung 21.")
legend(x="bottomleft", c("no Soft Drugs", "Soft Drugs"), pch=21,
       col="#777777", pt.bg=colrs, pt.cex=2, cex=.8, bty="n", ncol=1)

Zum Zeitpunkt t = 3 reduziert sich die Anzahl der Cliquen von vier auf drei, was die Abbildung 20 zeigt. Die Clique, die allein aus den Konsumenten der Soft Drugs besteht gibt es nicht mehr, sie verteilen sich nun innerhalb der “gemischten” Cliquen. Die orangene Clique (group 1, 11 Personen) enthält 5 Konsumenten, die blaue Clique (group 2, 12 Personen) enthält 3 Konsumenten und die grüne Clique (group 3, 12 Personen) enthält 7 Konsumenten der Soft Drugs.

G4 <- as.undirected(net4)
louv <- cluster_louvain(G4)
louv

## IGRAPH clustering multi level, groups: 6, mod: 0.43
## + groups:
##   $`1`
##    [1] "1"  "2"  "3"  "5"  "14" "22" "24" "25" "28" "37"
##   
##   $`2`
##    [1] "4"  "6"  "7"  "12" "13" "16" "17" "18" "20" "21" "26" "33" "34"
##   
##   $`3`
##    [1] "8"  "9"  "10" "11" "15" "19" "27" "29" "30" "32" "36" "38"
##   
##   $`4`
##   + ... omitted several groups/vertices

coord <- layout.fruchterman.reingold(G4)
par(mfrow=c (1,2))
plot.igraph(G4, 
            main = "Gruppen in t =4\nGesamtes Netzwerk",
            layout = coord,
            vertex.color = louv$membership,
            sub ="Abbildung 22.")
plot.igraph(G4,
            main = "Soft Drugs in t =4\nGesamtes Netzwerk",
            layout = coord,
            sub ="Abbildung 23.")
legend(x="bottomleft", c("no Soft Drugs", "Soft Drugs"), pch=21,
       col="#777777", pt.bg=colrs, pt.cex=2, cex=.8, bty="n", ncol=1)

Zum Zeitpunkt t = 4 liegt die Anzahl der Cliquen weiterhin bei drei. Die orangene Clique (group 1, 10 Personen) enthält 4 Konsumenten der Soft Drugs, die blaue Clique (group 2, 13 Personen) enthält 5 Konsumenten und die grüne Clique (group 3, 12 Personen) 7 Konsumenten der Soft Drugs.

6.5.2 Communities der Subnetzwerke

Als nächstes wurden die Subnetzwerke in Cliquen zerlegt, um rauszufinden, ob die Personen, die eher viel Soft Drugs konsumieren, ihre eigenen Cliquen bilden.

GD2 <- as.undirected(sub2)
louv <- cluster_louvain(GD2)
louv

## IGRAPH clustering multi level, groups: 5, mod: 0.42
## + groups:
##   $`1`
##   [1] "2"  "8"  "19" "24" "25" "37"
##   
##   $`2`
##   [1] "4"  "13" "21"
##   
##   $`3`
##   [1] "9"  "10" "11" "20"
##   
##   $`4`
##   + ... omitted several groups/vertices

coord <- layout.fruchterman.reingold(GD2)
par(mfrow=c (1,2))
plot.igraph(GD2,
            main = "Gruppen in t =2\nSubnetzwerk",
            layout = coord,
            vertex.color = louv$membership,
            sub ="Abbildung 24.")
plot.igraph(GD2, 
            main = "Soft Drugs in t =2\nSubnetzwerk",
            layout = coord,
            sub ="Abbildung 25.")
legend(x="bottomleft", c("wenig", "viel"), pch=21,
       col="#777777", pt.bg=col, pt.cex=2, cex=.8, bty="n", ncol=1)

Zum Zeitpunkt t = 2 besteht das Subnetzwerk aus vier ungleich großen Komponenten. Nur die größte Komponente (10 Personen), welche aus zwei Cliquen besteht, wurde ausgewertet. Die Knoten in der orangenen Clique (group 1, 6 Personen) sind relativ eng untereinander verbunden. Die Knoten der grünen Clique (group 3, 4 Personen) sind dagegen relativ schwach untereinander verbunden. Damit kann die orangene Clique als ein “aktives” und die grüne Clique als ein “passives” Teil des Netzwerkes verstanden werden. Die orangene Clique besteht zum größten Teil aus Personen, die eher viel Soft Drugs konsumieren. Dies steht im Einklang mit Ergebnissen der Berechnung der zentralen Parameter (Centrality) der Subnetzwerke. Die Ergebnisse zeigten, dass zum Zeitpunkt t = 2 die Personen, die eher viel Soft Drugs konsumierten, für das Subnetzwerk im Hinblick auf Degrees und Betweenness besonders wichtig sind.

GD3 <- as.undirected(sub3)
louv <- cluster_louvain(GD3)
louv

## IGRAPH clustering multi level, groups: 4, mod: 0.44
## + groups:
##   $`1`
##   [1] "2"  "19" "24" "37"
##   
##   $`2`
##   [1] "4"  "13" "21" "29" "32"
##   
##   $`3`
##   [1] "8"  "9"  "10" "11" "20" "25"
##   
##   $`4`
##   + ... omitted several groups/vertices

coord <- layout.fruchterman.reingold(GD3)
par(mfrow=c (1,2))
plot.igraph(GD3,
            main = "Gruppen in t =3\nSubnetzwerk",
            layout = coord,
            vertex.color = louv$membership,
            sub ="Abbildung 26.")
plot.igraph(GD3, 
            main = "Soft Drugs in t =3\nSubnetzwerk",
            layout = coord,
            sub ="Abbildung 27.")
legend(x="bottomleft", c("wenig", "viel"), pch=21,
       col="#777777", pt.bg=col, pt.cex=2, cex=.8, bty="n", ncol=1)

Zum Zeitpunkt t = 3 verändert sich das Bild. Das gesamte Subnetzwerk besteht jetzt nicht aus vier, sondern nur aus zwei Komponeten und die kleine Komponente besteht aus nur einem nicht verbundenen Knoten. Auch die Anzahl der Cliquen ist gestiegen. Die größte Komponente wurde jetzt in drei Cliquen aufgeteilt. Der “aktive” Teil des Netzwerkes ist größer geworden und enthält jetzt sowohl “akive” als auch “passive” Personen aus t =2. Die Verbindungen zwischen den Knoten in diesem neuen “aktiven” Teil haben sich jetzt merkbar aufgelockert. Der “passive” Teil in t = 3 wurde aus den kleineren Komponenten aus t = 2 gebildet. Die Personen, die eher viel Soft Drugs konsumieren, befinden sich nach wie vor zum größten Teil (4 Peronen aus insg. 5) in dem “aktiven” Teil des Netzwerkes. Sie wurden aber in zwei verschiedene Cliquen aufgeteilt und sind nicht mehr so eng untereinander verbunden.

GD4 <- as.undirected(sub4)
louv <- cluster_louvain(GD4)
louv

## IGRAPH clustering multi level, groups: 6, mod: 0.38
## + groups:
##   $`1`
##   [1] "2"  "19" "24" "37"
##   
##   $`2`
##   [1] "4"  "20" "21" "25"
##   
##   $`3`
##   [1] "8"
##   
##   $`4`
##   + ... omitted several groups/vertices

coord <- layout.fruchterman.reingold(GD4)
par(mfrow=c (1,2))
plot.igraph(GD4, 
            main = "Gruppen in t =4\nSubnetzwerk",
            layout = coord,
            vertex.color = louv$membership,
           sub ="Abbildung 28.") 
plot.igraph(GD4, 
            main = "Soft Drugs in t =4\nSubnetzwerk",
            layout = coord,
            sub ="Abbildung 29.")
legend(x="bottomleft", c("wenig", "viel"), pch=21,
       col="#777777", pt.bg=col, pt.cex=2, cex=.8, bty="n", ncol=1)

Zum Zeitpunkt t = 4 besteht das Subnetzwerk wieder aus vier Komponenten. Die drei kleinen Komponenten sind Einzelknoten. Die große Komponente wurde in vier Cliquen zerlegt. Die vier Personen, die eher viel Soft Drugs konsumieren, befinden sich jetzt in drei verschiedenen Cliquen und sind (mit einer Ausnahme) nicht miteinander verbunden. Der “aktive” Teil des Netzwerkes hat sich z. T. aufgelöst, das Netzwerk sieht jetzt deutlich gleichmäßiger aus.

6.6 Small Worlds

Zuletzt wurde ermittelt, ob es sich bei den Subnetzwerken um Small Worlds handelt. Als Small Worlds werden die Netzwerke bezeichnet, die einen relativ hohen Clustering-Koeffizient (Transitivity) bei relativ niedriger Pfadlänge haben. Solche Netzwerke weisen z.B. eine hohe Informationsübertragungsgeschwindigkeit sowie Synchronität auf. Der Clustering-Koeffizient gibt an, wie hoch die Wahrscheinlichkeit ist, dass zwei Knoten (also Personen), die jeweils eine Kante (Beziehung) zu einem dritten Knoten haben, auch untereinander verbunden sind. Um aussagen zu können, ob eine Small World vorliegt, müssen die durchschnittlichen Pfadlängen und Clustering-Koeffizienten des empirischen Netzwerkes mit denselben Werten eines Random-Netzwerkes, das die gleiche Anzahl von Knoten und Kanten besitzt wie das empirische Netzwerk, verglichen werden. Wenn bei ungefähr gleicher Pfadlänge der Clustering-Koeffizient des empirischen Netzwerkes deutlich höher ist, als der Clustering-Koeffizient des Random-Netzwerkes, dann handelt es sich um ein Small World-Netzwerk. Die Random-Netzwerke wurden mit der erdos.renyi.game-Funktion berechnet. Da die Ergebnisse der Berechnungen stets abweichend waren, wurden zunächst 1000 Random-Netzwerke und deren Pfadlängen sowie die Clustering-Koeffizienten berechnet. Die Mittelwerte der Pfadlängen und Clustering-Koeffizienten wurden dann mit den entsprechenden Werten der Subnetzwerke verglichen. Die Berechnungen wurden sowohl für die gesamten Subnetzwerke als auch für deren größten Komponenten durchgeführt.

Erstellung der Graphen für größten Komponenten:

connected_components2 <- components(sub2, mode = c("weak"))$membership
largest_component2 <- which.max(table(connected_components2))
small_sub2 <- induced_subgraph(sub2, which(connected_components2 == largest_component2))
connected_components3 <- components(sub3, mode = c("weak"))$membership
largest_component3 <- which.max(table(connected_components3))
small_sub3 <- induced_subgraph(sub3, which(connected_components3 == largest_component3))
connected_components4 <- components(sub4, mode = c("weak"))$membership
largest_component4 <- which.max(table(connected_components4))
small_sub4 <- induced_subgraph(sub4, which(connected_components4 == largest_component4))

Berechung der transitivity und mean_distance:

cal_transitivity <- function(dataset) {
  data(list= dataset)
  assign("g",get(dataset))
  C_g <- transitivity(g)
  L_g <- mean_distance(g)
  C_r=vector() 
  L_r=vector()
  for (i in 1:1000){ # Berechnung der 1000 Random-Netzwerke
    r=erdos.renyi.game(length(V(g)), length(E(g)),type="gnm", directed = TRUE) 
    C_r[i] = transitivity(r)
    L_r[i] = mean_distance(r)
    }
  C_rm <- mean(C_r)
  L_rm <- mean(L_r)
  df <- data.frame( C_g, C_rm, L_g, L_rm, network = dataset)
  return(df)
 }
liste <- data(sub2, sub3, sub4)
liste_small <- data(small_sub2, small_sub3, small_sub4)
output.liste <- lapply(liste, cal_transitivity)
output.liste_small <- lapply(liste_small, cal_transitivity)
ergebnis <- do.call(rbind, output.liste)
ergebnis_small <- do.call(rbind, output.liste_small)
ergebnis$C_rel <- ergebnis$C_g / ergebnis$C_rm
ergebnis$L_rel <- ergebnis$L_g / ergebnis$L_rm
ergebnis_small$C_rel <- ergebnis_small$C_g / ergebnis_small$C_rm
ergebnis_small$L_rel <- ergebnis_small$L_g / ergebnis_small$L_rm
head(ergebnis)

##          C_g      C_rm      L_g     L_rm network     C_rel     L_rel
## 1 0.61111111 0.1698172 1.250000 2.645091    sub2 3.5986415 0.4725736
## 2 0.19565217 0.1741749 1.860000 2.646934    sub3 1.1233086 0.7026997
## 3 0.09090909 0.1416961 1.767442 2.430123    sub4 0.6415778 0.7273054

Die Berechnung zeigt, dass bei ungefähr gleicher Pfadlänge das Netzwerk Sub2 einen Clustering-Koeffizient hat, welcher 3,5 mal höher ist, als ein Clustering-Koeffizient des Random-Netzwerkes. Es liegt also zum Zeitpunkt t = 2 eine Small World vor. Es fällt auch auf, dass im Laufe der Zeit der Clustering-Koeffizient (Wahrscheinlichkeit der Triadenbildung) stark abnimmt. Zum Zeitpunk t = 3 liegt er bei 0,196 und zum Zeitpunkt t = 4 bei 0,091. Der letztere ist sogar niedriger als der Clustering-Koeffizient eines Random-Netzerkes. Also liegt bei Sub4 keine Small World vor. Auch bei Sub3 handelt es sich nicht um eine Small World, weil der Clustering-Koeffizient dieses Subnetzwerkes nur 1,12 mal höher ist, als Clustering-Koeffizient des Random-Netwerkes.

head(ergebnis_small)

##          C_g      C_rm      L_g     L_rm    network     C_rel     L_rel
## 1 0.62264151 0.3689197 1.259259 2.186575 small_sub2 1.6877427 0.5759049
## 2 0.19565217 0.1970492 1.860000 2.618410 small_sub3 0.9929105 0.7103547
## 3 0.09090909 0.2208611 1.767442 2.413641 small_sub4 0.4116120 0.7322719

Die Ergebnisse der Untersuchung der größten Komponente der Subnetzwerke zeigen das gleiche Bild. Der Clustering-Koeffizient im Zeitpunkt t = 2 ist hier sogar höher als im gesamten Subnetzwerk, aber auch der Clustering-Koeffizient des Random-Netzwerkes stieg stark an. Trotzdem ist das Verhältnis der beiden Werte nicht gering und liegt bei 1,7. Damit handelt es sich hier bei dem Netzwerk im Zeitpunkt t = 2 ebenfalls um eine Small World. In den Zeitpunkten t = 3 und t = 4 liegen nach wie vor keine Small Worlds vor, da bei ungefähr gleicher Pfadlänge die Clustering-Koeffizienten der empirischen Netzwerke hier sogar kleiner sind als die Koeffizienten der Random-Netwerke.

7. Temporal Exponential Random Graph Models

Zuletzt wurde die Analyse der Netzwerke mit Temporal Exponential Random Graph Models durchgeführt. Die Exponential Models sind eine Klasse der statistischen Modelle, die in der Lage sind, die Einflussfaktoren für die Wahrscheinlichkeit des Zustandekommens bzw. Nichtzustandekommens oder Auflösung der Beziehungen in einem Netzwerk zu ermitteln. Diese Wahrscheinlichkeit kann u.a. von Knoten-Attributen beeinflusst sein. So handelt es sich bei Exponential Models um eine Art der Regressionsanalysen für die Netzwerke. Die Ermittlung der Wahrscheinlichkeiten erfolgt durch die Simulation einer großen Zahl von Random-Netzwerken, die genau so groß (im Hinblick auf die Anzahl der Knoten und Kanten) sind wie die empirischen Netzwerke. Danach werden die aus den Random-Netzwerken ermittelten statistischen Werte mit den Werten der empirischen Netzwerke verglichen. Durch den Vergleich wird ermittelt, ob und mit welcher Wahrscheinlichkeit es sich bei den Messergebnissen nicht um einen Zufall handelt. Temporal Exponential Models eignen sich speziell für Ermittlungen der Wahrscheinlichkeiten bei Längsschnittdaten, welche die dynamischen Netzwerke beschreiben.

Die Analyse der Netzwerke mit TERGM in diesem Projekt zielt darauf ab, aussagen zu können, inwiefern die Beziehungen in den Netzwerken von der Homophilie beeinfusst sind. Gemäß der Aussage der Forscher, beeinflussten vor allem die Variablen Program und Gender das Zustandekommen der Freundschaften und freundschaftlichen Beziehungen. Der Einfuss der Variablen Smoking und Soft Drugs war dagegen relativ gering. In diesem Projekt wurde geprüft, ob dieselben Faktoren in gleichem Ausmaß auch die Beziehungen in den Subnetzwerken beeinflussen. Dafür wurde zuerst die Analyse der gesamten Netzwerke und dann die Analyse der Subnetzwerke mit TERGM durchgeführt. Die Ergebnisse der beiden Analysen wurden miteinander verglichen. Für die Untersuchung der gesamten Netzwerke wurde das Modell Net mit den Variablen Gender, Program, Smoking und Soft Drugs erstellt. Die Erwartungen bezüglich des Einflusses der Variablen entsprechen den oben genanten Forschungsergebnissen. Für die Untersuchung der Subnetzwerke wurde das Modell Sub mit den Variablen Gender, Program, Smoking und Drugs_dif erstellt. Es wurde erwartet, dass auch hier die Variablen Gender und Program einen starken Einfluss haben. Es wurde auch erwartet, dass der Einfuss der Variable Smoking sich merkbar verändert, da der Anteil der Raucher in den Subnetzwerken höher ist als in den gesamten Netzwerken. Im Hinblick auf die Untersuchungen der Subnetzwerke in diesem Projekt wurde auch der geringe Einfluss der Variable Drugs_dif erwartet.

In diesem Projekt wurden unterschiedliche Modelle getestet. Ausgewählt wurden aber nur zwei relativ “schmale” finale Modelle (z. B. ohne ausdifferenzierte Darstellung der Variablen), weil diese sowohl aussagekräftige Ergebnisse als auch zufriedenstellende Modellgüte lieferten.

7.1 BTERGM für die gesamten Netzwerke

Für die Modellierung mit BTERGM wurden zuerst die Listen mit den gesamten Netzwerken erstellt. Danach wurde das Null-Modell erstellt, weil man dessen edges-Werte für die Ermittlung der Wahrscheinlichkeiten benötigt. Dann wurde die Modellgüte mit der Goodness of Fit-Methode geprüft. Zum Schluss wurden die Wahrscheinlichkeiten für das Zustandekommen der Beziehungen ermittelt. Die Ergebnisse wurden visualisiert.

Erstellung der Listen:

library(statnet)
library(intergraph)
set.seed(0)
Net1 <- asNetwork(net1) # von igraph- zu statnet-Objekt
Net2 <- asNetwork(net2)
Net3 <- asNetwork(net3)
Net4 <- asNetwork(net4)
Net <- list(Net1, Net2, Net3, Net4) # Liste der Graphen für btergm
Net

## [[1]]
##  Network attributes:
##   vertices = 38 
##   directed = TRUE 
##   hyper = FALSE 
##   loops = FALSE 
##   multiple = FALSE 
##   bipartite = FALSE 
##   total edges= 19 
##     missing edges= 0 
##     non-missing edges= 19 
## 
##  Vertex attribute names: 
##     color Drugs Drugs_dif Gender Program Smoking vertex.names 
## 
##  Edge attribute names: 
##     Weight 
## 
## [[2]]
##  Network attributes:
##   vertices = 38 
##   directed = TRUE 
##   hyper = FALSE 
##   loops = FALSE 
##   multiple = FALSE 
##   bipartite = FALSE 
##   total edges= 121 
##     missing edges= 0 
##     non-missing edges= 121 
## 
##  Vertex attribute names: 
##     color Drugs Drugs_dif Gender Program Smoking vertex.names 
## 
##  Edge attribute names: 
##     Weight 
## 
## [[3]]
##  Network attributes:
##   vertices = 38 
##   directed = TRUE 
##   hyper = FALSE 
##   loops = FALSE 
##   multiple = FALSE 
##   bipartite = FALSE 
##   total edges= 147 
##     missing edges= 0 
##     non-missing edges= 147 
## 
##  Vertex attribute names: 
##     color Drugs Drugs_dif Gender Program Smoking vertex.names 
## 
##  Edge attribute names: 
##     Weight 
## 
## [[4]]
##  Network attributes:
##   vertices = 38 
##   directed = TRUE 
##   hyper = FALSE 
##   loops = FALSE 
##   multiple = FALSE 
##   bipartite = FALSE 
##   total edges= 129 
##     missing edges= 0 
##     non-missing edges= 129 
## 
##  Vertex attribute names: 
##     color Drugs Drugs_dif Gender Program Smoking vertex.names 
## 
##  Edge attribute names: 
##     Weight

Null-Modell:

library(btergm)
set.seed(10)

Net_Null <- btergm(Net ~ edges + gwesp(0.1, fixed = T) + memory(type = "stability"))

##              t=2 t=3 t=4
## Net (row)     38  38  38
## Net (col)     38  38  38
## memory (row)  38  38  38
## memory (col)  38  38  38

##              t=2 t=3 t=4
## Net (row)     38  38  38
## Net (col)     38  38  38
## memory (row)  38  38  38
## memory (col)  38  38  38

summary(Net_Null)

##                     Estimate Boot mean    2.5%   97.5%
## edges                -2.5524   -2.5073 -2.7282 -1.6068
## gwesp.OTP.fixed.0.1   1.5316    1.5359  1.4289  1.7525
## edgecov.memory[[i]]   1.3636    1.4232  1.2862  2.2311

Model_Net:

model_Net <- btergm(Net ~ edges + gwesp(0.1, fixed = T) + memory(type = "stability") + nodematch("Drugs") + nodematch("Gender") + nodematch("Program") + nodematch("Smoking"))

##              t=2 t=3 t=4
## Net (row)     38  38  38
## Net (col)     38  38  38
## memory (row)  38  38  38
## memory (col)  38  38  38

##              t=2 t=3 t=4
## Net (row)     38  38  38
## Net (col)     38  38  38
## memory (row)  38  38  38
## memory (col)  38  38  38

Bewertung der Modellgüte mit Goodness of Fit:

gof.Net1 <- gof(model_Net, statistics = c(esp, geodesic))

##              t=2 t=3 t=4
## Net (row)     38  38  38
## Net (col)     38  38  38
## memory (row)  38  38  38
## memory (col)  38  38  38

##              t=2 t=3 t=4
## Net (row)     38  38  38
## Net (col)     38  38  38
## memory (row)  38  38  38
## memory (col)  38  38  38

gof.Net2 <- gof(model_Net, statistics = c(ideg, odeg))

##              t=2 t=3 t=4
## Net (row)     38  38  38
## Net (col)     38  38  38
## memory (row)  38  38  38
## memory (col)  38  38  38

##              t=2 t=3 t=4
## Net (row)     38  38  38
## Net (col)     38  38  38
## memory (row)  38  38  38
## memory (col)  38  38  38

plot(gof.Net1)

plot(gof.Net2)

Nach der Erstellung der Modelle wurde ihre Güte mit der Goodness of Fit-Methode überprüft. Für die Überprüfung wurden die ausgewählten Parameter edge-wise shared partners, geodesic distance sowie in- und outdegree distribution der simulierten Netzwerke mit den Parametern der empirischen Netzwerke verglichen. Die Visualisierungen der Überprüfungsergebnisse (siehe oben) zeigen die Werte der simulierten Netzwerke (graue Boxplots) sowie die Werte der empirischen Netzwerke (schwarze Linie). Je näher die Mediane der Box-Plots an der schwarzen Linie liegen, desto höher ist die Modellgüte. Wenn die Linie außerhalb der grauen Intervalle der Boxplots liegt, dann ist die Modellgüte gering. Auf den Abbildungen oben kann man sehen, dass die Modellierungsergebnisse nicht hervorragend, aber akzeptabel sind. Die schwarze Linie liegt nicht immer nah an den Medianen der Box-Plots, bleibt aber (mit kleiner Ausnahme bei den Outdegrees) innerhalb der Intervalle.

Ergebnisse der Modellierung:

summary(model_Net)

##                     Estimate Boot mean    2.5%   97.5%
## edges               -4.09272  -4.05914 -4.4240 -3.7305
## gwesp.OTP.fixed.0.1  1.43747   1.44390  1.3273  1.7258
## edgecov.memory[[i]]  1.17549   1.23118  1.0905  2.0381
## nodematch.Drugs      0.24249   0.23759  0.1622  0.3152
## nodematch.Gender     0.47068   0.46259  0.0611  0.9390
## nodematch.Program    1.16776   1.16718  0.9960  1.4649
## nodematch.Smoking    0.46363   0.45942  0.3341  0.6362

Nach der Überprüfung der Modellgüte wurden die Ergebnisse der Modelierung ausgewertet. Wie man sehen kann, sind alle Variablen Gender, Program, Smoking und Drugs signifikant, da 0 außerhalb aller Konfidenzintervalle liegt. Deswegen wurden die estimate-Werte aller Variablen in Wahrscheinlichkeiten umgerechnet. Für die Berechnung der Wahrscheinlichkeiten wurde der edges-Wert (-2.5524) aus dem Null-Modell verwendet.

Ermittlung der Wahrscheinlichkeiten:

e <- (-2.5524 + (0.47068)) # Gender
1 - 1 / (1+exp(e))

## [1] 0.1108863

e <- (-2.5524 + (1.16776)) # Program
1 - 1 / (1+exp(e))

## [1] 0.2002648

e <- (-2.5524 + (0.46363)) # Smoking
1 - 1 / (1+exp(e))

## [1] 0.1101931

e <- (-2.5524 + (0.24249)) # Drugs
1 - 1 / (1+exp(e))

## [1] 0.09030554

Visualisierung der Ergebnisse:

e <- exp(cbind(OR = coef(model_Net), confint(model_Net)))
e <- data.frame(e)
e <- e[4:nrow(e),]
names(e) <- c('or', 'esti','lcl', 'ucl')

ggplot(e, aes(x = or, y = rownames(e))) + geom_vline(aes(xintercept = 1), size = .6, linetype = "dashed") +
  geom_errorbarh(aes(xmax = ucl, xmin = lcl), size = .5, height = 0.1, color = "darkred") +
  geom_point(size = 2.5, color = "darkred") +
  labs(x = 'Odds ratio & 95% CI', y = "", caption = "Abbildung 30.") + scale_y_discrete(limits = rownames(e)) + 
  ggtitle("Odd's Ratios") + theme(plot.title = element_text(hjust = 0.5)) +
  theme(panel.background = element_rect(fill = "#D1EEEE", colour = NA), panel.border = element_rect(fill = NA, colour = "black", size = 0.6))

7.2 BTERGM für die Subnetzwerke

Die Modellierung für Subnetzwerke erfolgte nach dem bereits beschriebenen Muster. Nach der Erstellung des Sub_Null und model_Sub wurde die Modellgüte geprüft, die Wahrscheinlichkeiten ermittelt und die Ergebnisse visualisiert.

Erstellung der Listen:

Sub1 <- asNetwork(sub1)
Sub2 <- asNetwork(sub2)
Sub3 <- asNetwork(sub3)
Sub4 <- asNetwork(sub4)
Sub <- list(Sub1, Sub2, Sub3, Sub4)
Sub

## [[1]]
##  Network attributes:
##   vertices = 16 
##   directed = TRUE 
##   hyper = FALSE 
##   loops = FALSE 
##   multiple = FALSE 
##   bipartite = FALSE 
##   total edges= 3 
##     missing edges= 0 
##     non-missing edges= 3 
## 
##  Vertex attribute names: 
##     color Drugs Drugs_dif Gender Program Smoking vertex.names 
## 
##  Edge attribute names: 
##     Weight 
## 
## [[2]]
##  Network attributes:
##   vertices = 16 
##   directed = TRUE 
##   hyper = FALSE 
##   loops = FALSE 
##   multiple = FALSE 
##   bipartite = FALSE 
##   total edges= 24 
##     missing edges= 0 
##     non-missing edges= 24 
## 
##  Vertex attribute names: 
##     color Drugs Drugs_dif Gender Program Smoking vertex.names 
## 
##  Edge attribute names: 
##     Weight 
## 
## [[3]]
##  Network attributes:
##   vertices = 16 
##   directed = TRUE 
##   hyper = FALSE 
##   loops = FALSE 
##   multiple = FALSE 
##   bipartite = FALSE 
##   total edges= 24 
##     missing edges= 0 
##     non-missing edges= 24 
## 
##  Vertex attribute names: 
##     color Drugs Drugs_dif Gender Program Smoking vertex.names 
## 
##  Edge attribute names: 
##     Weight 
## 
## [[4]]
##  Network attributes:
##   vertices = 16 
##   directed = TRUE 
##   hyper = FALSE 
##   loops = FALSE 
##   multiple = FALSE 
##   bipartite = FALSE 
##   total edges= 20 
##     missing edges= 0 
##     non-missing edges= 20 
## 
##  Vertex attribute names: 
##     color Drugs Drugs_dif Gender Program Smoking vertex.names 
## 
##  Edge attribute names: 
##     Weight

Null-Modell:

Sub_Null <- btergm(Sub ~ edges + gwesp(0.1, fixed = T)+ memory(type = "stability"))

##              t=2 t=3 t=4
## Sub (row)     16  16  16
## Sub (col)     16  16  16
## memory (row)  16  16  16
## memory (col)  16  16  16

##              t=2 t=3 t=4
## Sub (row)     16  16  16
## Sub (col)     16  16  16
## memory (row)  16  16  16
## memory (col)  16  16  16

summary(Sub_Null)

##                     Estimate Boot mean    2.5%   97.5%
## edges               -2.01575  -1.96450 -2.0978 -1.3636
## gwesp.OTP.fixed.0.1  0.91142   0.96882  0.5343  1.7799
## edgecov.memory[[i]]  1.11017   1.21415  0.8998  2.0567

Model_Sub:

model_Sub <- btergm(Sub ~ edges + gwesp(0.1, fixed = T) + memory(type = "stability") + nodematch("Gender") + nodematch("Program") + nodematch("Smoking") + nodematch("Drugs_dif"))

##              t=2 t=3 t=4
## Sub (row)     16  16  16
## Sub (col)     16  16  16
## memory (row)  16  16  16
## memory (col)  16  16  16

##              t=2 t=3 t=4
## Sub (row)     16  16  16
## Sub (col)     16  16  16
## memory (row)  16  16  16
## memory (col)  16  16  16

Bewertung der Modellgüte mit Goodness of Fit:

gof.Sub1 <- gof(model_Sub, statistics = c(esp, geodesic))

##              t=2 t=3 t=4
## Sub (row)     16  16  16
## Sub (col)     16  16  16
## memory (row)  16  16  16
## memory (col)  16  16  16

##              t=2 t=3 t=4
## Sub (row)     16  16  16
## Sub (col)     16  16  16
## memory (row)  16  16  16
## memory (col)  16  16  16

gof.Sub2 <- gof(model_Sub, statistics = c(odeg, ideg))

##              t=2 t=3 t=4
## Sub (row)     16  16  16
## Sub (col)     16  16  16
## memory (row)  16  16  16
## memory (col)  16  16  16

##              t=2 t=3 t=4
## Sub (row)     16  16  16
## Sub (col)     16  16  16
## memory (row)  16  16  16
## memory (col)  16  16  16

plot(gof.Sub1)

plot(gof.Sub2)

Die schwarze Linie liegt hier in vielen Fällen nah am Median der Box-Plots und bleibt (mit einer kleinen Ausnahme bei Outdegrees) innerhalb des Intervalls, d.h. dass die Modellgüte in Ordnung ist.

Ergebnisse der Modellierung:

summary(model_Sub, level = 0.95)

##                     Estimate Boot mean    2.5%   97.5%
## edges               -3.23701  -3.22566 -3.4961 -2.6571
## gwesp.OTP.fixed.0.1  0.82848   0.85249  0.4354  1.7172
## edgecov.memory[[i]]  0.98459   1.11796  0.7766  2.2899
## nodematch.Gender     0.49814   0.50641 -0.2431  1.1107
## nodematch.Program    1.00394   1.01188  0.4116  1.3566
## nodematch.Smoking    0.34180   0.38434  0.0407  1.2051
## nodematch.Drugs_dif  0.10317   0.12664 -0.3343  0.8786

Die Ergebnisse der Modellierung zeigen, dass weder die Variable* Gender* noch die Variable Drugs_dif signifikant sind, weil 0 innerhalb deren Konfidenzintervalle liegt. Die Wahrscheinlichkeiten wurden deswegen nur für die signifikanten Variablen Program und Smoking berechnet. Für die Berechnung der Wahrscheinlichkeiten wurde der edges-Wert (-2,01575) aus dem Null-Modell verwendet.

Ermittlung der Wahrscheinlichkeiten:

e <- (-2.01575+ (1.00394)) # Program
1 - 1 / (1+exp(e))

## [1] 0.2666258

e <- (-2.01575+ (1.00394)) # Program
1 - 1 / (1+exp(e))

## [1] 0.2666258

e <- exp(cbind(OR = coef(model_Sub), confint(model_Sub)))
e <- data.frame(e)
e <- e[4:nrow(e),] 
names(e) <- c('or', 'esti','lcl', 'ucl')
ggplot(e, aes(x = or, y = rownames(e))) + geom_vline(aes(xintercept = 1), size = .6, linetype = "dashed") +
  geom_errorbarh(aes(xmax = ucl, xmin = lcl), size = .5, height = 0.1, color = "darkred") +
  geom_point(size = 2.5, color = "darkred") +
  labs(x = 'Odds ratio & 95% CI', y = "", caption = "Abbildung 31.") + scale_y_discrete(limits = rownames(e)) + 
  ggtitle("Odd's Ratios") + theme(plot.title = element_text(hjust = 0.5)) +
    theme(panel.background = element_rect(fill = "#D1EEEE", colour = NA), panel.border = element_rect(fill = NA, colour = "black", size = 0.6))

7.3 Vergleich der Ergebnisse

Die ermittelten Wahrscheinlichkeiten aus den Modellen model_Net und model_Sub wurden miteinander vergliechen.

Wahrscheinlichkeiten der Homophilie in model_Net und model_Sub

	Gender	Program	Smoking	Drugs	Drugs_dif
Net	11%	20%	11%	9%	-
Sub	-	26,7%	15,8%	-	-

Die Wahrscheinlichkeit der programmbezogenen Homophilie liegt im model_Net bei 20%, die Wahrscheinlichkeit der geschlechtsbezogenen Homophilie bei 11%, der rauchenbezogenen Homophilie ebenfalls bei 11% und der drogenbezogenen Homophilie bei 9%. Wie erwartet, ist der Einfuss der Variable Program am stärksten. Gegen die Erwartungen ist der Einfuss der Variable Smoking zum einen nicht gering und zum anderen genau so groß wie der Einfluss der Variable Gender. Ebenfalls gegen die Erwartungen ist der merkbare Einfluss der Variable Soft Drugs. Die Wahrscheinlichkeit der drogenbezogenen Homophilie liegt hier bei 9% und damit ist sie nur um 2% geringer als die Wahrscheinlichkeit der geschlechtsbezogenen Homophilie. Wie erwartet, ist der Einfluss der Variable Program im model_Sub auch am stärksten. Die Wahrscheinlichkeit der programmbezogenen Homophilie in den Subnetzwerken liegt bei 26,7% und ist damit etwas höher als die Wahrscheinlichkeit der programmbezogenen Homophilie im model_Net. Auch die Wahrscheinlichkeit der raucherbezogenen Homophilie ist hier um 4,8% höher als in model_Net. Gegen die Erwartungen ist die Variable Gender hier nicht signifikant. Auch als nicht signifikant erwies sich die Variable Drugs_dif. Aber ein starker Einfluss dieser Variable wurde auch nicht erwartet.

Quellen

Duijn van, Marijtje A.J./Zeggelink, Evelien P.H./ Huisman, Mark/Stokman, Frans N./Wasseur, Frans W. (2003): Evolution of sociology freshmen into a friendship network. Journal of Mathematical Sociology 27. S. 153-191.

Freeman, Linton C. (1979): Centrality in Social Networks Conceptual Clarification. Social Networks 1. S. 215-239.

Girvan, M./Newman, M. E. (2002): Community structure in social and biological networks. Proceedings of the National Academy of Sciences, 99(12):7821–7826.

Leifeld, Philip/Cranmer, Skyler J./Desmarais, Bruce A. (2018): Temporal Exponential Random Graph Models with btergm: Estimation and Bootstrap Confidence Intervals. Journal of Statistical Software 83. S. 1-36.

Watts, D. J./Strogatz, S. H. (1998): Collective dynamics of “small-world” networks. Nature 393(6684). S. 440-442.

Fußnoten

Duijn/Zeggelink/Huisman et al(2003). S. 154.↩︎

Social Network Analysis

Entwicklung eines sozialen Netzwerkes der Soft Drugs Konsumenten

Maja Lichman

1. Das Projekt

2. Ladung der Pakete

3. Datenbearbeitung

3.1 Ladung der Attribute

3.2 Ladung der Soziomatrizen

4. Umwandlung der Matrizen in Graphen

4.1 Erstellung der Graphen für Gesamtnetzwerke

4.2 Erstellung der Subgraphen

5. Sichtung der Attribute

5.1 Visualisierung der Attributen in gesamten Netzwerken

5.2 Visualisierung der Attributen in Subnetzwerken

6. Analyse der Netzwerke

6.1 Visualisierung der Subnetzwerke

6.2 Ermittlung der Freundschaften

6.3 Berechnung der Centrality-Parameter

6.4 Berechnung der zentralen Parameter (Centralization)

6.5 Communities

6.5.1 Communities der Gesamtnetzwerke

6.5.2 Communities der Subnetzwerke

6.6 Small Worlds

7. Temporal Exponential Random Graph Models

7.1 BTERGM für die gesamten Netzwerke

7.2 BTERGM für die Subnetzwerke

7.3 Vergleich der Ergebnisse

Quellen

Fußnoten