3次元オブジェクトをグラフにしてみる

平均曲率を用いて、3次元オブジェクトの表面を色付けした。

凹んでいるところは赤、出っ張っているところは緑になっている。
　
いま、同じ色でひと続きになっている領域を仲間分けして、なおかつ、隣り合う領域がどうなっているかを調べたい。
ある頂点と、その頂点を含む三角形(1-ring)を選び、それに隣り合っている三角形をすべて、再度抽出する。
このとき、既に選ばれた三角形たちは、重複して抽出すると計算に時間がかかるので、適宜除く。

# 球面に色を付けた時、同じ色が付いている閉じた領域をチェックする
K0 <- NULL
for(k0 in 1:nrow(v1[[i]]$f)){
  if( !any(mapply(function(z) k0 %in% z, K0)) ){ # いままでのK に kが含まれていなかったら新規のtriangle
    print(paste("Processing", k0))
    k <- k0
    foo0 <- which(mapply(function(x) any(v1[[i]]$f[x,] %in% v1[[i]]$f[k,]), seq(nrow(v1[[i]]$f))))
    foo1 <- foo0[cols[foo0] == cols[k[1]]] # k の三角形と同じ色をもって隣り合っている三角形たち
    #plot3d(bun.v, type="n", axes=FALSE, xlab="", ylab="", zlab="")
    #shade3d(mesh.tri, col=rep(cols, each=3))
    #rgl.viewpoint(10, 30, zoom=0.7)
    m2 <- tmesh3d(t(v1[[i]]$v), t(v1[[i]]$f[foo1,]), homogeneous=FALSE)
    #wire3d(m2)
    K <- list(k, foo1)
    while( !all(K[[length(K)]] %in% K[[length(K)-1]]) ){
      k <- setdiff(K[[length(K)]], K[[length(K)-1]])
      foo0 <- which(mapply(function(x) any(v1[[i]]$f[x,] %in% v1[[i]]$f[k,]), seq(nrow(v1[[i]]$f))))
      foo1 <- foo0[cols[foo0] == cols[k[1]]]
      K <- c(K, list(foo1))
      #open3d()
      #plot3d(bun.v, type="n", axes=FALSE, xlab="", ylab="", zlab="")
      #shade3d(mesh.tri, col=rep(cols, each=3))
      m <- v1[[i]]$f[setdiff(K[[length(K)]], K[[length(K)-1]]),]
      m2 <- tmesh3d(t(v1[[i]]$v), t(v1[[i]]$f[foo1,]), homogeneous=FALSE)
      #points3d(matrix(v1[[i]]$v[m,], nc=3))
      #texts3d(matrix(v1[[i]]$v[m,], nc=3), texts=unique(c(v1[[i]]$f[k,])))
      #wire3d(m2, col=4)
    }
    K1 <- sort(unique(unlist(K)))
    K0 <- c(K0, list(K1))
  }
}

隣接する三角形が広がっていく様子。最前線しかプロットしていない。

すべての隣り合う三角形をプロットした図。

　
いま、ひと続きになっている領域をメッシュで色塗りしたが、このふたつの紫、水色の領域は隣り合っている。


隣り合う領域をadjacent matrix として、グラフ化。
背中の広い範囲の緑、首まわりの赤がおおきなノードとして表現される。赤いノードからは顔、耳2つが隣接していて、それもノードとして出ている。
ノードの大きさは、対応する領域の面積としている。
グラフ構造に落とせれば、ノードの密度や、ネットワーク解析を応用してそういう統計量もとれる。

# K0 は同じ色で塗られるtriangle のひとつづきの領域
# 隣り合う領域を探す
V0 <- mapply(function(z) unique(c(v1[[i]]$f[z,])), K0) # 含まれる頂点たち
adj_mat <- mapply(function(z2) mapply(function(z1) any(z2 %in% z1)+0, V0), V0)
g0 <- graph.adjacency(adj_mat, mode="undirected", diag=FALSE)
V(g0)$size <- mapply(function(z) sum(area0[[i]][z,]), K0) * 10
V(g0)$color <- mapply(function(z) cols[z[1]], K0)
plot(g0)