社会ネットワーク分析の練習

Mathematicaフォーラムに載っている事例で練習してみる。

# この図を再分析してみる
# http://www.mathforum.jp/uservisit/05seijikeizai/zu1.gif
library(igraph)
adjm <- matrix(c(0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
                 1,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
                 1,0,0,1,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,
                 0,1,1,0,1,1,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,
                 0,1,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
                 0,0,0,1,1,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,
                 0,0,0,0,0,1,0,1,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,
                 0,0,0,0,1,0,1,0,1,1,0,0,0,0,1,0,0,0,0,0,0,0,0,
                 0,0,0,1,0,0,0,1,0,1,0,0,0,0,1,0,0,0,0,0,0,0,0,
                 0,0,0,1,0,1,1,1,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,1,1,1,0,0,0,0,0,0,0,0,0,
                 0,0,0,0,0,0,0,0,0,0,1,0,1,1,0,0,0,0,0,0,0,0,0,
                 0,0,0,0,0,0,0,0,0,0,1,1,0,1,0,0,0,0,0,0,0,0,0,
                 0,0,0,0,0,0,0,0,0,0,1,1,1,0,1,0,0,0,0,0,0,0,0,
                 0,0,1,0,0,0,0,1,1,0,0,0,0,1,0,1,0,0,0,0,0,1,0,
                 0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,0,1,1,0,0,0,
                 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,1,0,0,0,0,
                 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,1,0,0,0,
                 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,1,0,0,0,
                 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,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,1,1,
                 0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,1,0,1,
                 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0),
                 23,byrow=TRUE)
g1 <- graph.adjacency(adjm, mode="undirected")

V(g1)$label <- 1:23
V(g1)$label[10] <- "ビル"
V(g1)$label[15] <- "スー"

wtc <- walktrap.community(g1)
size <- nrow(wtc$merges)
Q <- numeric(size)
STEPS <- 1:size

for (i in STEPS) {
 memb <- community.to.membership(g1, wtc$merges, steps=i)
 Q[i] <- modularity(g1, memb$membership)
 }

# modularity Q の分布を見たいときはこんな感じで。
# plot(STEPS, Q, type="b", main="modularity Q", xlab="Steps", ylab="Q")

# modularity Q が最大になるstepでクラスタを分割
memb <- community.to.membership(g1, wtc$merges, steps=which.max(Q))

PR <- page.rank(g1)$vector
V(g1)$size <- 25*PR/max(PR)
# パステルカラー
V(g1)$color <- c("#ffbcbc","#bcbcff","#bcffbc","#ffddbc")[memb$membership+1]
par(mar=c(0, 0, 0, 0))
plot(g1, layout=layout.fruchterman.reingold, vertex.label.family="mono")

# ちょっときれいに出力したいときはCarioパッケージを使う。
library(Cairo)
Cairo(640, 640, file="plot.png", type="png", bg="white")
par(mar=c(0, 0, 0, 0))
plot(g1, layout=layout.fruchterman.reingold, vertex.label.family="mono")
dev.off()