网络数据统计分析笔记|| 动态网络


前情回顾：

Gephi网络图极简教程
Network在单细胞转录组数据分析中的应用
网络数据统计分析笔记|| 为什么研究网络
网络数据统计分析笔记|| 操作网络数据
网络数据统计分析笔记|| 网络数据可视化
网络数据统计分析笔记|| 网络数据的描述性分析
网络数据统计分析笔记||网络图的数学模型
网络数据统计分析笔记|| 网络图的统计模型
网络数据统计分析笔记|| 网络拓扑结构推断
网络数据统计分析笔记|| 网络图上的过程建模与预测

动态网络（Dynamic Networks）是指加上时间戳的网络，包含时序网络和切片网络两种类型。其中时序网络是指网络从初始状态不断演化的情况。切片网络要简单一些，就是由一组切片构成的动态网络。

# CHUNK 1
library(sand)
data(hc)

# CHUNK 2
head(hc)
# ---
##   Time ID1 ID2  S1  S2
## 1  140  15  31 MED ADM
## 2  160  15  22 MED MED
## 3  500  15  16 MED MED
## 4  520  15  16 MED MED
## 5  560  16  22 MED MED
## 6  580  16  22 MED MED
# ---

# CHUNK 3
ID.stack <- c(hc$ID1,hc$ID2)
Status.stack <- c(as.character(hc$S1),
   as.character(hc$S2))
my.t <- table(ID.stack,Status.stack)
v.status <- character(nrow(my.t))
for(i in (1:length(v.status))){
   v.status[i] <- names(which(my.t[i,]!=0))
}
table(v.status)
# ---
## v.status
## ADM MED NUR PAT
##   8  11  27  29
# ---

# CHUNK 4
status.t <- table(hc$S1,hc$S2)
status.t <- status.t + t(status.t)
diag(status.t) <- round(diag(status.t)/2)
status.t
# ---
##         ADM   MED   NUR   PAT
##   ADM   279   459  2596   441
##   MED   459  5660  1769  1471
##   NUR  2596  1769 12695  6845
##   PAT   441  1471  6845   209
# ---

# CHUNK 5
tmp.es <- paste(hc$S1,"-",hc$S2,sep="")
e.status <- character(dim(hc)[[1]])
e.status[tmp.es=="ADM-ADM"] <- "ADM-ADM"
e.status[tmp.es=="MED-MED"] <- "MED-MED"
e.status[tmp.es=="NUR-NUR"] <- "NUR-NUR"
e.status[tmp.es=="PAT-PAT"] <- "PAT-PAT"
e.status[(tmp.es=="ADM-MED") |
   (tmp.es=="MED-ADM")] <- "ADM-MED"
e.status[(tmp.es=="ADM-NUR") |
   (tmp.es=="NUR-ADM")] <- "ADM-NUR"
e.status[(tmp.es=="ADM-PAT") |
   (tmp.es=="PAT-ADM")] <- "ADM-PAT"
e.status[(tmp.es=="MED-NUR") |
   (tmp.es=="NUR-MED")] <- "MED-NUR"
e.status[(tmp.es=="MED-PAT") |
   (tmp.es=="PAT-MED")] <- "MED-PAT"
e.status[(tmp.es=="NUR-PAT") |
   (tmp.es=="PAT-NUR")] <- "NUR-PAT"

my.hc <- data.frame(Time = hc$Time/(60*60),
                      ID1 = hc$ID1,
                      ID2 = hc$ID2,
                      Status = e.status)

library(lattice)
histogram(~Time|Status, data=my.hc, xlab="Hours",
   layout=c(5,2))

# CHUNK 6
vids <- sort(unique(c(hc$ID1, hc$ID2)))
g.week <- graph_from_data_frame(hc[, c("ID1", "ID2", 
   "Time")], vertices=data.frame(vids),
   directed=FALSE)
E(g.week)$Time <- E(g.week)$Time  / (60 * 60)

# CHUNK 7
summary(g.week)
# ---
## IGRAPH ab0ca23 UN-- 75 32424 -- 
## + attr: name (v/c), Time (e/n)
# ---

# CHUNK 8
status <- unique(rbind(data.frame(id=hc$ID1,
   status=hc$S1), data.frame(id=hc$ID2, status=hc$S2)))
V(g.week)$Status <-
   as.character(status[order(status[,1]),2])

# CHUNK 9
E(g.week)$weight <- 1
g.week.wgtd <- simplify(g.week)
summary(g.week.wgtd)
# ---
## IGRAPH 09000d9 UNW- 75 1139 -- 
## + attr: name (v/c), Status (v/c), weight (e/n)
# ---

# CHUNK 10
is_simple(g.week.wgtd)
# ---
## [1] TRUE
# ---

# CHUNK 11
summary(E(g.week.wgtd)$weight)
# ---
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
##    1.00    3.00    8.00   28.47   23.00 1059.00
# ---

# CHUNK 12
g.week.96 <- subgraph.edges(g.week,
   E(g.week)[Time <= 96])

# CHUNK 13
g.sl12 <- lapply(1:8, function(i) {
   g <- subgraph.edges(g.week,
                       E(g.week)[Time > 12*(i-1) &
                                 Time <= 12*i],
                       delete.vertices=FALSE)
   simplify(g)
})

# CHUNK 14
sapply(g.sl12,vcount)
# ---
## [1] 75 75 75 75 75 75 75 75
# ---

# CHUNK 15
sapply(g.sl12,ecount)
# ---
## [1] 179 294 257 282 265 314 197 305
# ---

# CHUNK 16
library(networkDynamic)

# CHUNK 17
hc.spls <- cbind((hc$Time-20)/(60*60),
                   hc$Time/(60*60),
                   hc$ID1,hc$ID2)
hc.dn <- networkDynamic(edge.spells=hc.spls)

# CHUNK 18
is.active(hc.dn,onset=0,terminus=1,e=c(1))
# ---
## [1] TRUE
# ---
is.active(hc.dn,onset=1,terminus=2,e=c(1))
# ---
## [1] FALSE
# ---

# CHUNK 19
get.edge.activity(hc.dn,e=c(1))
# ---
## [[1]]
##            [,1]       [,2]
## [1,] 0.03333333 0.03888889
# ---

# CHUNK 20
get.edge.activity(hc.dn,e=c(10))
# ---
## [[1]]
##           [,1]       [,2]
## [1,]  0.800000  0.8055556
## [2,]  1.355556  1.3611111
## [3,]  1.505556  1.5111111
## [4,] 24.894444 24.9055556
## [5,] 25.005556 25.0166667
## [6,] 25.388889 25.3944444
## [7,] 25.500000 25.5055556
# ---

# CHUNK 21
g.sl12.dN <- get.networks(hc.dn,start=0,end=96,
                           time.increment=12)

# CHUNK 22
hc.dn.df <- as.data.frame(hc.dn)
names(hc.dn.df)
# ---
## [1] "onset"             "terminus"
## [3] "tail"              "head"
## [5] "onset.censored"    "terminus.censored"
## [7] "duration"          "edge.id"
# ---

# CHUNK 23
summary(hc.dn.df$duration)
# ---
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
## 0.005556 0.005556 0.005556 0.012833 0.011111 1.088889
# ---

# CHUNK 24
detach(package:networkDynamic)
set.seed(42)
l = layout_with_fr(g.week.wgtd)
v.cols <- character(75)
v.cols[V(g.week.wgtd)$Status=="ADM"] <- "yellow"
v.cols[V(g.week.wgtd)$Status=="MED"] <- "blue"
v.cols[V(g.week.wgtd)$Status=="NUR"] <- "green"
v.cols[V(g.week.wgtd)$Status=="PAT"] <- "black"
plot(g.week.wgtd, layout=l, vertex.size=3,
    edge.width=2*(E(g.week.wgtd)$weight)/100,
    vertex.color=v.cols,vertex.label=NA,)



opar <- par()
par(mfrow=c(2,4),
     mar=c(0.5, 0.5, 0.5, 0.5),
     oma=c(0.5, 1.0, 0.5, 0))
for(i in (1:8)) {
   plot(g.sl12[[i]], layout=l, vertex.size=5,
     edge.width=2*(E(g.week.wgtd)$weight)/1000,
     vertex.color=v.cols,vertex.label=NA)
   title(paste(12*(i-1),"to",12*i,"hrs"))
}
par(opar)




# Establish colors for edge status.
tmp.es <- paste(v.status[hc.dn.df$tail],"-",
                 v.status[hc.dn.df$head],sep="")
mycols <- numeric(nrow(hc.dn.df))
mycols[tmp.es=="ADM-ADM"] <- 1
mycols[tmp.es=="MED-MED"] <- 2
mycols[tmp.es=="NUR-NUR"] <- 3
mycols[tmp.es=="PAT-PAT"] <- 4
mycols[(tmp.es=="ADM-MED") | (tmp.es=="MED-ADM")] <- 5
mycols[(tmp.es=="ADM-NUR") | (tmp.es=="NUR-ADM")] <- 6
mycols[(tmp.es=="ADM-PAT") | (tmp.es=="PAT-ADM")] <- 7
mycols[(tmp.es=="MED-NUR") | (tmp.es=="NUR-MED")] <- 8
mycols[(tmp.es=="MED-PAT") | (tmp.es=="PAT-MED")] <- 9
mycols[(tmp.es=="NUR-PAT") | (tmp.es=="PAT-NUR")] <- 10
my.palette <- rainbow(10)
# Produce plot.
ne <- max(hc.dn.df$edge.id)
max.t <- max(hc.dn.df$terminus)
plot(c(0,max.t),c(0,ne),ann=F,type='n')
segments(hc.dn.df$onset,hc.dn.df$edge.id,
   hc.dn.df$terminus,hc.dn.df$edge.id,
   col=my.palette[mycols])
title(xlab="Time (hours)",
   ylab="Interacting Pair
   (Ordered by First Interaction)")
clip(0,max.t,0,ne)
abline(v=c(11,35,59,83),lty="dashed",lw=2,
   col="lightgray")
# Add legend to plot.
status.pairs <- c("ADM-ADM","MED-MED","NUR-NUR",
   "PAT-PAT", "ADM-MED","ADM-NUR","ADM-PAT",
    "MED-NUR", "MED-PAT","NUR-PAT")
legend(7,1140,status.pairs,
        text.col=my.palette[(1:10)],cex=0.7)

动态网络的特征化

all.deg <- sapply(g.sl12,degree)
sl.lab<- sapply(1:8, function(i) 
   paste(12*(i-1), "-", 12*i, "hrs", sep=""))
deg.df <- data.frame(Degree=as.vector(all.deg),
   Slice = rep(sl.lab,each=75),
   Status = rep(V(g.week)$Status, times=8))



library(ggplot2)
p = qplot(factor(Degree), data=deg.df,
           geom="bar",fill=Status)
p+facet_grid(Slice~.) + xlab("Degree") + ylab("Count")

# CHUNK 28
top.deg <- lapply(1:8,function(i) {
   all.deg[,i][rank(all.deg[,i])>=70]
})

table(unlist(lapply(1:8,function(i)
   as.numeric(names(top.deg[[i]])))))
# ---
##  1  5  7  8 10 11 13 15 17 19 21 22 23 24 25 26 27 29 31
##  2  2  4  1  1  2  2  4  3  3  2  1  3  2  1  2  2  2  1
## 34 36 37 63 64
##  1  1  2  1  2
# ---

# CHUNK 29
V(g.week)$Status[c(7,15)]
# ---
## [1] "NUR" "MED"
# ---

# CHUNK 30
all.str <- sapply(g.sl12,strength)
all.r <- all.str/all.deg
round(all.r[c(7,15),],digits=2)
# ---
##     [,1]  [,2] [,3]  [,4]  [,5]  [,6]  [,7]  [,8]
## 7   2.00 25.79 11.1 32.73 14.20 33.19  8.33 37.34
## 15 29.71 26.33 17.0 12.48 19.27 15.30 19.40 12.93
# ---

# CHUNK 31
summary(c(all.r))
# ---
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's
##    1.00    5.00   10.43   12.06   15.73   47.35     261
# ---

# CHUNK 32
sp.len <- lapply(1:8, function(i) {
   spl <- distances(g.sl12[[i]],v=c(7,15),
                    to=V(g.sl12[[i]]),
                    weights=NA)
   spl[spl==Inf] <- NA
   spl
})
ave.spl <- sapply(1:8,function(i) 
   apply(sp.len[[i]],1,mean,na.rm=T))
round(ave.spl,digits=2)
# ---
##    [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
## 7  3.05 1.27 1.79 1.12 1.80 1.33 2.00 1.24
## 15 1.72 1.51 2.48 1.35 1.36 1.26 1.61 1.36
# ---

# CHUNK 33
sapply(g.sl12,diameter)
# ---
## [1]  9  8 26 28 10 10 10 10
# ---

# CHUNK 34
round(sapply(g.sl12,mean_distance),digits=2)
# ---
## [1] 2.12 1.70 1.81 1.67 1.79 1.70 1.91 1.78
# ---

动态网络建模目前尚且不易。因为引入时间，新问题中的组合爆炸也是一个重要原因。

https://www.zhihu.com/question/265008836
https://zhuanlan.zhihu.com/p/148190973
https://www.ccs.neu.edu/home/rraj/Talks/DynamicNetworks/DYNAMO/IntroDynamicNetworks.pdf
https://briatte.github.io/ggnet/
https://link.springer.com/referencework/10.1007/978-1-4614-7163-9
https://blog.csdn.net/tanzhangwen/article/details/8262017

©著作权归作者所有,转载或内容合作请联系作者
  • 人面猴
    序言：七十年代末，一起剥皮案震惊了整个滨河市，随后出现的几起案子，更是在滨河造成了极大的恐慌，老刑警刘岩，带你破解...
    沈念sama阅读 213,711评论 6赞 493
  • 死咒
    序言：滨河连续发生了三起死亡事件，死亡现场离奇诡异，居然都是意外死亡，警方通过查阅死者的电脑和手机，发现死者居然都...
    沈念sama阅读 91,079评论 3赞 387
  • 救了他两次的神仙让他今天三更去死
    文/潘晓璐 我一进店门，熙熙楼的掌柜王于贵愁眉苦脸地迎上来，“玉大人，你说我怎么就摊上这事。” “怎么了？”我有些...
    开封第一讲书人阅读 159,194评论 0赞 349
  • 道士缉凶录：失踪的卖姜人
    文/不坏的土叔 我叫张陵，是天一观的道长。 经常有香客问我，道长，这世上最难降的妖魔是什么？ 我笑而不...
    开封第一讲书人阅读 57,089评论 1赞 286
  • 港岛之恋（遗憾婚礼）
    正文 为了忘掉前任，我火速办了婚礼，结果婚礼上，老公的妹妹穿的比我还像新娘。我一直安慰自己，他们只是感情好，可当我...
    茶点故事阅读 66,197评论 6赞 385
  • 恶毒庶女顶嫁案：这布局不是一般人想出来的
    文/花漫 我一把揭开白布。 她就那样静静地躺着，像睡着了一般。 火红的嫁衣衬着肌肤如雪。 梳的纹丝不乱的头发上，一...
    开封第一讲书人阅读 50,306评论 1赞 292
  • 城市分裂传说
    那天，我揣着相机与录音，去河边找鬼。 笑死，一个胖子当着我的面吹牛，可吹牛的内容都是我干的。 我是一名探鬼主播，决...
    沈念sama阅读 39,338评论 3赞 412
  • 双鸳鸯连环套：你想象不到人心有多黑
    文/苍兰香墨 我猛地睁开眼，长吁一口气：“原来是场噩梦啊……” “哼！你这毒妇竟也来了？” 一声冷哼从身侧响起，我...
    开封第一讲书人阅读 38,119评论 0赞 269
  • 万荣杀人案实录
    序言：老挝万荣一对情侣失踪，失踪者是张志新（化名）和其女友刘颖，没想到半个月后，有当地人在树林里发现了一具尸体，经...
    沈念sama阅读 44,541评论 1赞 306
  • 护林员之死
    正文 独居荒郊野岭守林人离奇死亡，尸身上长有42处带血的脓包…… 初始之章·张勋 以下内容为张勋视角 年9月15日...
    茶点故事阅读 36,846评论 2赞 328
  • 白月光启示录
    正文 我和宋清朗相恋三年，在试婚纱的时候发现自己被绿了。 大学时的朋友给我发了我未婚夫和他白月光在一起吃饭的照片。...
    茶点故事阅读 39,014评论 1赞 341
  • 活死人
    序言：一个原本活蹦乱跳的男人离奇死亡，死状恐怖，灵堂内的尸体忽然破棺而出，到底是诈尸还是另有隐情，我是刑警宁泽，带...
    沈念sama阅读 34,694评论 4赞 337
  • 日本核电站爆炸内幕
    正文 年R本政府宣布，位于F岛的核电站，受9级特大地震影响，放射性物质发生泄漏。R本人自食恶果不足惜，却给世界环境...
    茶点故事阅读 40,322评论 3赞 318
  • 男人毒药：我在死后第九天来索命
    文/蒙蒙 一、第九天 我趴在偏房一处隐蔽的房顶上张望。 院中可真热闹，春花似锦、人声如沸。这庄子的主人今日做“春日...
    开封第一讲书人阅读 31,026评论 0赞 21
  • 一桩弑父案，背后竟有这般阴谋
    文/苍兰香墨 我抬头看了看天上的太阳。三九已至，却和暖如春，着一层夹袄步出监牢的瞬间，已是汗流浃背。 一阵脚步声响...
    开封第一讲书人阅读 32,257评论 1赞 267
  • 情欲美人皮
    我被黑心中介骗来泰国打工， 没想到刚下飞机就差点儿被人妖公主榨干…… 1. 我叫王不留，地道东北人。 一个月前我还...
    沈念sama阅读 46,863评论 2赞 365
  • 代替公主和亲
    正文 我出身青楼，却偏偏与公主长得像，于是被迫代替她去往敌国和亲。 传闻我的和亲对象是个残疾皇子，可洞房花烛夜当晚...
    茶点故事阅读 43,895评论 2赞 351