読者です 読者をやめる 読者になる 読者になる

ネットワーク分析を学ぶ(1日目)

ネットワーク分析を勉強していきます。
以下の本を読んで色々と試しつつ、学びつつ、という感じです。

ネットワーク分析 (Rで学ぶデータサイエンス 8)
ネットワーク分析 (Rで学ぶデータサイエンス 8)鈴木 努 金 明哲

共立出版 2009-09-25
売り上げランキング : 160105


Amazonで詳しく見る
by G-Tools

グラフの最短距離を求めるアルゴリズム

ダイクストラ

ある始点からの各頂点への最短距離を求める手法

ウォーシャル・フロイド法

全ての頂点間の最短距離を求める手法
アルゴリズム上3重ループが出て来る。

この辺りは、Rよりも別の言語で実装した方が勉強になりそうですね。
Perlの勉強をかねて実装してみようかと計画中です。

ネットワーク構造の指標

構造に関する指標です。

密度

定義は

グラフにおいて張ることのできるすべての辺の数に対する、実際の辺の数の比率

ということです。
密度=1で全ての頂点の間に辺がある完全グラフとなります。

推移性

頂点iと頂点jの間に関係があり、頂点jと頂点kの間に関係がある。
さらに、頂点iと頂点kにも関係がある場合の、頂点iと頂点kの関係は推移的である、ということになります。
ややこしいですね。

推移性は、グラフの中で推移的な関係が成り立っている割合となります。
参考書では、無向グラフの場合のみが書かれています。

相互性

有向グラフで双方向性がどれだけ達成されているかを表す指標です。

試してみた

上記について、参考書6章のデータを元に、試してみました。
推移性が少し微妙な気がするので、また後ほど検討してみたいと思います。

library(sna)

# データの入力

ADVICE <- matrix(c(
0,1,0,1,0,0,0,1,0,0,0,0,0,0,0,1,0,1,0,0,1,
0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,1,
1,1,0,1,0,1,1,1,1,1,1,1,0,1,0,0,1,1,0,1,1,
1,1,0,0,0,1,0,1,0,1,1,1,0,0,0,1,1,1,0,1,1,
1,1,0,0,0,1,1,1,0,1,1,0,1,1,0,1,1,1,1,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,0,0,0,1,0,0,0,0,1,1,0,1,0,0,1,1,0,0,1,
0,1,0,1,0,1,1,0,0,1,1,0,0,0,0,0,0,1,0,0,1,
1,1,0,0,0,1,1,1,0,1,1,1,0,1,0,1,1,1,0,0,1,
1,1,1,1,1,0,0,1,0,0,1,0,1,0,1,1,1,1,1,1,0,
1,1,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,1,
1,1,0,0,1,0,0,0,1,0,0,0,0,1,0,0,0,1,0,0,0,
0,1,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,1,0,0,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,
1,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,
1,1,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,1,
1,1,1,1,1,0,1,1,1,1,1,0,1,1,1,1,0,0,1,1,1,
1,1,1,0,1,0,1,0,0,1,1,0,0,1,1,0,0,1,0,1,0,
1,1,0,0,0,1,0,1,0,0,1,1,0,1,1,1,1,1,0,0,1,
0,1,1,1,0,1,1,1,0,0,0,1,0,1,0,0,1,1,0,1,0),
nrow = 21, byrow = TRUE)


FRIEND <- matrix(c(
0,1,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,0,0,
1,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,0,0,0,1,0,0,0,0,1,0,0,
1,1,0,0,0,0,0,1,0,0,0,1,0,0,0,1,1,0,0,0,0,
0,1,0,0,0,0,0,0,1,0,1,0,0,1,0,0,1,0,1,0,1,
0,1,0,0,0,0,1,0,1,0,0,1,0,0,0,0,1,0,0,0,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,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,0,0,0,0,0,0,0,0,0,
0,0,1,0,1,0,0,1,1,0,0,1,0,0,0,1,0,0,0,1,0,
1,1,1,1,1,0,0,1,1,0,0,1,1,0,1,0,1,1,1,0,0,
1,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,1,
0,0,0,0,1,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,
1,0,1,0,1,1,0,0,1,0,1,0,0,1,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,0,
1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,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,0,
1,1,1,0,1,0,0,0,0,0,1,1,0,1,1,0,0,0,0,1,0,
0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,1,0,0,0,
0,1,0,0,0,0,0,0,0,0,0,1,0,0,0,0,1,1,0,0,0),
nrow = 21, byrow = TRUE)


REPORT <- matrix(c(
0,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,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,1,0,0,0,0,0,0,0,
0,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,0,0,0,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,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,0,0,0,0,0,0,0,0,0,0,0,0,1,
0,0,0,0,0,0,0,0,0,0,0,0,0,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,1,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,
0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,
0,0,0,0,0,0,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,1,0,0,0,0,0,0,0,
0,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,0,0,0,0,0,0,0,0,0,0,1,
0,0,0,0,0,0,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,1,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,
0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
nrow = 21, byrow = TRUE)


# plot
gplot(ADVICE, 
      xlab="ADVICE", 
      arrowhead.cex=0.3, 
      edge.lwd=0.7, 
      displaylabels=T, 
      label.pos=5, 
      vertex.cex=2, 
      vertex.col="white")

gplot(ADVICE, 
      xlab="FRIEND", 
      arrowhead.cex=0.3, 
      edge.lwd=0.7, 
      displaylabels=T, 
      label.pos=5, 
      vertex.cex=2, 
      vertex.col="white")

gplot(REPORT, 
      xlab="REPORT", 
      arrowhead.cex=0.3, 
      edge.lwd=0.7, 
      displaylabels=T, 
      label.pos=5, 
      vertex.cex=2, 
      vertex.col="white")


# ダイクストラ法
dijkstra <- function(matrix, vertex) {
  L <- matrix
  L[which(L==0)] <- Inf # 到達不能な行列には無限大
  diag(L) <- 0 # 対角成分も0
  n <- nrow(matrix)
  d <- rep(Inf, n) # 始点から各頂点への距離を示すベクトル
  d[vertex] <- 0 # 始点を0に
  M <- 1:n # 距離が未確定な頂点リスト
  M <- M[-vertex] # 始点を除く
  i <- vertex

  while (length(M) > 0) {
    for (j in 1:n) {
      d[j] <- min(d[j], d[i] + L[i,j]) # 最小距離の書き換え
    }
    i <- M[which(d[M] == min(d[M]))[1]] # 次の探索点の決定
    M <- M[-which(M == i)] # 探索が終わった頂点を除く
  }
  return(d)
}


# ウォーシャル・フロイド法
WF <- function(matrix) {
  L <- matrix
  L[which(L == 0)] <- Inf # 到達不能な頂点への距離は無限大
  diag(L) <- 0  # 対角要素に0を入れる
  n <- nrow(matrix)
  for (k in 1:n) {
    for (i in 1:n) {
      for (j in 1:n) {
        L[i,j] <- min(L[i,j], L[i,k] + L[k,j]) # 中間点を経由した方が距離が短いか否か
      }
    }
  }
  return(L)
}


# ダイクストラ法とウォーシャル・フロイド法
# 1番目の頂点に対する比較
dijkstra(ADVICE, 1)
WF(ADVICE)[1,]

# 到達可能性行列
# 全て1なら強連結
reachability(ADVICE)



# 密度
# 完全グラフへの近さを表している
density <- sum(ADVICE) / (nrow(ADVICE) * nrow(ADVICE)-1)
density


# 推移性
# 推移的な関係が成り立っている頂点の比率
# 書籍では無効グラフの場合しか書いていないので、
# 距離2の近接行列は自力で求める
ADVICE2 <- WF(ADVICE)
ADVICE2[which(ADVICE2 != 2)] <- 0
ADVICE2[which(ADVICE2 == 2)] <-1
sum(ADVICE2 * ADVICE) / sum(ADVICE2)

# 相互性
# 双方向の関係性がどれくらいあるか
# 完全に無関係のものをどう扱うべきかは要検討
bidirection.ADVICE <- ADVICE * t(ADVICE)
oneway.ADVICE <- ADVICE + t(ADVICE)
oneway.ADVICE[which(oneway.ADVICE >= 1)] <- 1
sum(bidirection.ADVICE) / sum(oneway.ADVICE)
# 相互に有効辺をもつ頂点のペア数の比率

grecip(ADVICE, measure = "dyadic.nonnull")

# 双方向の関係の数そのもの
mutuality(ADVICE)

ちょっと不明点など

  • 参考書では無向グラフの例と有向グラフの例が混ざっていて、有向グラフ

要素積をとって、双方向性を確かめているけど、大きなネットワークでやるとほぼ確実に死ぬと思います。


ネットワーク分析、色々と奥が深そうですね。
実データで試すとどういう結果が得られるか楽しみですが、まずはネットワーク分析をさくっと学ぶように頑張りたいと思います。