Finding Tight-Knit Groups of Friends

2. Compute the smallest 12 eigenvalues and corresponding eigenvectors of the Laplacian of the friendship graph.

#computing adjacency matrix 
people <- sort(unique(c(data$from,data$to)))

from_factor <- factor(data$from, levels=people)
to_factor <- factor(data$to, levels=people)

A <- unclass(table(from_factor, to_factor))
A <- unclass(pmax(A, t(A)))

#computing degree matrix
degrees <- rowSums(A)
D <- diag(degrees)

#computing laplacian
L = D-unclass(A)
values <- eigen(L, symmetric=TRUE)

#12 smallest eigenvalues of laplacian 

n <- 1495
smallest_12_values <- values$values[(n-11):n]
smallest_12_vectors <- values$vectors[,(n-11):n]
round(smallest_12_values, digits=3)

 [1] 0.133 0.120 0.081 0.074 0.054 0.014 0.000 0.000 0.000 0.000 0.000 0.000

3. How many connected components does this graph have, and what are the sizes of the connected components?

v1 <- smallest_12_vectors[,7] 
v2 <- smallest_12_vectors[,8]
v3 <- smallest_12_vectors[,9]
v4 <- smallest_12_vectors[,10]
v5 <- smallest_12_vectors[,11] 
v6 <- smallest_12_vectors[,12]  

ccs <- list(v1,v2,v3,v4,v5,v6)
lengths <- list()
i<-1
for (v in ccs) {
  lengths[i] <- length(v[abs(v)>(1e-12)])
  i = i+1
}
lengths

[[1]]
[1] 1495

[[2]]
[1] 1495

[[3]]
[1] 1495

[[4]]
[1] 1495

[[5]]
[1] 1495

[[6]]
[1] 1495

cc_matrix <- matrix(ncol=6, data = c(v1,v2,v3,v3,v5,v6))
dim(cc_matrix)

[1] 1495    6

set.seed(123)
km <- kmeans(cc_matrix, centers=6)
plot(cc_matrix, col=km$cluster, pch=19)

table(km$cluster)

  1   2   3   4   5   6 
  7 312   4 368  44 760 

Given that there are 6 zero-valued eigenvalues, it’s evident that there are 6 connected components. To find the size of the connected components, we can use the 6 corresponding eigenvectors as columns of a matrix, and perform k-means on this matrix. This will help identify the clusters within the data and thereby determine the size of each cluster. Applying the k-means algorithm gave the following results:

Component 1	Component 2	Component 3	Component 4	Component 5	Component 6
7	312	4	368	44	760

\[ cond(S) = \frac{\sum_{i\in S, i\in V\backslash S} A_{ij}}{\min(A(S),A(V\backslash S)} \]

Each of the three sets below were found using the 7th, 30th, and 10th smallest eigenvectors respectively. After plotting, I identified the prominent bands that were not part of the main cluster and extracted those vertices.

cond <- function(s) {
  A_S <- sum(diag(D)[which(people %in% s)]) 
  V_minus_S <- sum(diag(D)[which(!(people %in% s))])
  s_i <- which(people %in% s)
  sum_Aij <- sum(A[s_i, -s_i])
  
  c <- sum_Aij / ifelse(A_S < V_minus_S, A_S, V_minus_S)
  return(c)
}

create_list <- function(l, m, c) {
  new_list <- list(length = l, members = m, conductance = c)
  return(new_list)
}

Set 1

This set corresponds to the vertices whose values in the 7th smallest eigenvector are in the range [-0.045, -0.04].

l <- 12
v7 <- smallest_12_vectors[,l-6] #first eigenvector with a non-zero e-value
plot(v7, type="p", pch=19, cex=0.5, main="7th Smallest Eigenvector", xlab="Node index", ylab="Eigenvector value")

s1 <- which(v7 < -0.04 & v7 > -0.045)
s1_length <- length(which(v7 < -0.04 & v7 > -0.045))
s1_members <- s1[1:10]
cond_s1 <- cond(s1)

create_list(s1_length, s1_members, cond_s1)

$length
[1] 199

$members
 [1]  2  6  8 13 17 21 55 60 67 71

$conductance
[1] 0.02901731

Set 2

This set corresponds to the vertices whose values in the 30th smallest eigenvector are in the range [-0.04, -0.01].

all_vectors <- values$vectors
v30 <- all_vectors[,n-29]

plot(v30, type="p", pch=19, cex=0.5, main="30th Smallest Eigenvector", xlab="Node index", ylab="Eigenvector value")

s2 <- which(v30 > -.04 & v30 < -.01)

s2_length <- length(s2)
s2_members <- s2[1:10]
cond_s2 <- cond(s2)

create_list(s2_length, s2_members, cond_s2)

$length
[1] 427

$members
 [1]  5  7 12 15 23 27 30 34 42 44

$conductance
[1] 0.02111757

Set 3

This set corresponds to the vertices whose values in the 10th smallest eigenvector are in the range [0.02, 0.03].

v10 <- all_vectors[,n-9]
plot(v10, type="p", pch=19, cex=0.5, main="10th Smallest Eigenvector", xlab="Node index", ylab="Eigenvector value")

s3 <- which(v10>0.02 & v10<0.03)

s3_length <- length(s3)
s3_members <- s3[1:10]
cond_s3 <- cond(s3)

create_list(s3_length, s3_members, cond_s3)

$length
[1] 209

$members
 [1]  2  6  8 13 17 21 55 60 67 71

$conductance
[1] 0.01179245

5. Select a random set of 150 nodes, and compute the conductance of that set.

set.seed(123)
random_set <- sample(1:1495, 150)

cond(random_set)

[1] 0.9014746

The conductances found in sets 1,2,3 in conjunction with the plots indicate tight-knit friendships within the group and a disconnect from the rest of the graph. Comparing with the above benchmark of 0.9 confirms tight-knitness within groups given that a conductance of 0.9 indicates that vertices in our randomly sampled set share minimal internal friendships.