for(rep_iter in 1:repetition_iteration){
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1 # i.e. T=150, then num_theta=149 (tau), and num_beta=148
temp <- matrix(NA, nrow=num_time, ncol=num_stats)
for(t in 1:num_time){
if(num_stats == 2){
temp[t,] = summary(y_data[[t]] ~ edges + mutual)
}else if(num_stats == 3){
temp[t,] = summary(y_data[[t]] ~ edges + mutual + triangles)
}else if(num_stats == 4){
yt <- network(y_data[[t]])
network::set.vertex.attribute(yt, "Gender", gender)
temp[t,] = summary(yt ~ edges + mutual + triangles + nodematch("Gender"))
}
}
est_CP <- e.divisive(as.matrix(temp), sig.lvl=p_thres, R=R_val, min.size=15); rm(temp)
est_CP <- est_CP$estimates; print(est_CP)
est_CP <- sort(est_CP)
est_CP <- est_CP + 1
num_CP <- length(est_CP)
gt_CP_corrected <- c(1, true_CP, tau+2) # tau+2 = T+1
est_CP_corrected <- c(1, est_CP, tau+2)
gt_list <- est_list <- list();
for(i in 2:length(gt_CP_corrected)){
gt_list[[i-1]] <- gt_CP_corrected[i-1]:(gt_CP_corrected[i]-1)
}
for(i in 2:length(est_CP_corrected)){
est_list[[i-1]] <- est_CP_corrected[i-1]:(est_CP_corrected[i]-1)
}
if(num_CP == 0){
dist_est_gt <- Inf
dist_gt_est <- -Inf
covering_metric <- 0
}else{
holder <- c()
for(i in true_CP){
dist_diff <- c()
for(j in est_CP){dist_diff <- c(dist_diff, abs(j-i))}
holder <- c(holder, min(dist_diff))
}
dist_est_gt <- max(holder)
holder <- c()
for(i in est_CP){
dist_diff <- c()
for(j in true_CP){dist_diff <- c(dist_diff, abs(j-i))}
holder <- c(holder, min(dist_diff))
}
dist_gt_est <- max(holder)
covering_metric <- 0
for(i in 1:length(gt_list)){
A <- gt_list[[i]]
jaccard <- c()
for(j in 1:length(est_list)){
A_prime <- est_list[[j]]
jaccard <- c(jaccard,length(intersect(A,A_prime))/length(union(A,A_prime)))
}
covering_metric <- covering_metric + length(A)*max(jaccard)
}
covering_metric <- covering_metric/(tau+1) # tau+1 = T
}
abs_error <- abs(num_CP - length(true_CP))
result[rep_iter, 1] <- abs_error
result[rep_iter, 2] <- dist_est_gt
result[rep_iter, 3] <- dist_gt_est
result[rep_iter, 4] <- covering_metric
}
return(result)
}
}
sim_result8 <- Evaluation_ecp(SBM_list,p_thres=0.05,num_stats=length(network_stats), R_val=200)
sim_result8 <- Evaluation_ecp(SBM_list,p_thres=0.05, num_stats=length(network_stats), R_val=100)
sim_result8 <- Evaluation_ecp(SBM_list,p_thres=0.01, num_stats=length(network_stats), R_val=100)
install.packages("NetworkChange")
library(NetworkChange)
## Not run:
set.seed(1973)
Y <- MakeBlockNetworkChange(n=10, T=40, type ="split")
View(Y[,,1])
image(Y[,,1])
image(Y[,,40])
G <- 100 ## Small mcmc scans to save time
\## Fit multiple models for break number detection using Bayesian model comparison
## Fit multiple models for break number detection using Bayesian model comparison
out0 <- NetworkStatic(Y, R=2, mcmc=G, burnin=G, verbose=G, Waic=TRUE)
out0
out1 <- NetworkChange(Y, R=2, m=1, mcmc=G, burnin=G, verbose=G, Waic=TRUE)
plotU(out1)
detect <- BreakDiagnostic(Y, R = 2, break.upper = 3, mcmc = 2000, burnin = 1000)
detect[[1]]    # a plot comparing candidate break numbers (e.g., WAIC / marginal)
print(detect[[2]])  # ta
G <- 2000  # increase for real analyses
out0 <- NetworkStatic(Y, R = 2, mcmc = G, burnin = G, Waic = TRUE)
out1 <- NetworkChange(Y, R = 2, m = 1, mcmc = G, burnin = G, Waic = TRUE)
out2 <- NetworkChange(Y, R = 2, m = 2, mcmc = G, burnin = G, Waic = TRUE)
models <- list(out0, out1, out2)
# Compare models by WAIC (or use MarginalCompare for log marginal likelihood)
WaicCompare(models)           # lower is better
bp <- BreakPointLoss(models, waic = TRUE, display = TRUE)
models <- list(out1, out2)
# Compare models by WAIC (or use MarginalCompare for log marginal likelihood)
WaicCompare(models)           # lower is better
bp <- BreakPointLoss(models, waic = TRUE, display = TRUE)
bp$ave.loss              # per-model expected loss (lower = better)
bp$Tau                   # expected break times for each model
bp$Tau.samp              # MCMC samples of break times (for CIs)
best_i <- which.min(bp$ave.loss)   # index of best model in `models`
tau_hat <- bp$Tau[[best_i]]        # estimated CPs (time indices in 1..T)
tau_hat
?array
Evaluation_NC <- function(y_list, is_experiment=FALSE, true_CP=c(26, 51, 76)){
if(is_experiment){
y_data <- y_list
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1
temp <- array(NA, dim=c(n,n,num_time))
for(iter in 1:length(y_data)){temp[,,iter] <- c(y_data[[iter]])}
est_CP <- binary_search(temp, c(), 1, num_time, p_threshold); rm(temp)
est_CP <- sort(est_CP)
est_CP <- est_CP + 1
return(est_CP)
}else{
repetition_iteration <- length(y_list)
result <- matrix(NA, nrow=repetition_iteration, ncol = 4)
for(rep_iter in 1:repetition_iteration){
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1 # i.e. T=150, then num_theta=149 (tau), and num_beta=148
temp <- array(NA, dim=c(n,n,num_time))
for(iter in 1:length(y_data)){temp[,,iter] <- c(y_data[[iter]])}
G <- 100
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, Waic = TRUE)
out3 <- NetworkChange(temp, R = 2, m = 3, mcmc = G, burnin = G, Waic = TRUE)
out4 <- NetworkChange(temp, R = 2, m = 4, mcmc = G, burnin = G, Waic = TRUE)
models <- list(out2, out3, out4)
bp <- BreakPointLoss(models, waic = TRUE, display = TRUE)
best_i <- which.min(bp$ave.loss)
est_CP <- bp$Tau[[best_i]]
print(est_CP)
est_CP <- est_CP + 1
num_CP <- length(est_CP)
gt_CP_corrected <- c(1, true_CP, tau+2) # tau+2 = T+1
est_CP_corrected <- c(1, est_CP, tau+2)
gt_list <- est_list <- list();
for(i in 2:length(gt_CP_corrected)){
gt_list[[i-1]] <- gt_CP_corrected[i-1]:(gt_CP_corrected[i]-1)
}
for(i in 2:length(est_CP_corrected)){
est_list[[i-1]] <- est_CP_corrected[i-1]:(est_CP_corrected[i]-1)
}
if(num_CP == 0){
dist_est_gt <- Inf
dist_gt_est <- -Inf
covering_metric <- 0
}else{
holder <- c()
for(i in true_CP){
dist_diff <- c()
for(j in est_CP){dist_diff <- c(dist_diff, abs(j-i))}
holder <- c(holder, min(dist_diff))
}
dist_est_gt <- max(holder)
holder <- c()
for(i in est_CP){
dist_diff <- c()
for(j in true_CP){dist_diff <- c(dist_diff, abs(j-i))}
holder <- c(holder, min(dist_diff))
}
dist_gt_est <- max(holder)
covering_metric <- 0
for(i in 1:length(gt_list)){
A <- gt_list[[i]]
jaccard <- c()
for(j in 1:length(est_list)){
A_prime <- est_list[[j]]
jaccard <- c(jaccard,length(intersect(A,A_prime))/length(union(A,A_prime)))
}
covering_metric <- covering_metric + length(A)*max(jaccard)
}
covering_metric <- covering_metric/(tau+1) # tau+1 = T
}
abs_error <- abs(num_CP - length(true_CP))
result[rep_iter, 1] <- abs_error
result[rep_iter, 2] <- dist_est_gt
result[rep_iter, 3] <- dist_gt_est
result[rep_iter, 4] <- covering_metric
}
return(result)
}
}
num_seq = 15
num_node <- c(50, 100, 200)
network_stats=c("edges", "mutual")
i <- 1
set.seed(1)
SBM_list <- sim_SBM_list(num_seq, n=num_node[i], rho=0.0)
sim_result9 <- Evaluation_eNC(SBM_list)
sim_result9 <- Evaluation_NC(SBM_list)
y_list <- SBM_list
repetition_iteration <- length(y_list)
result <- matrix(NA, nrow=repetition_iteration, ncol = 4)
rep_iter <- 1
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1 # i.e. T=150, then num_theta=149 (tau), and num_beta=148
temp <- array(NA, dim=c(n,n,num_time))
for(iter in 1:length(y_data)){temp[,,iter] <- c(y_data[[iter]])}
dim(temp)
G <- 100
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, Waic = TRUE)
G <- 1000
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, Waic = TRUE)
out2 <- NetworkChange(temp, R = 5, m = 2, mcmc = G, burnin = G, Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, Waic = F)
out3 <- NetworkChange(temp, R = 2, m = 3, mcmc = G, burnin = G, Waic = TRUE)
out4 <- NetworkChange(temp, R = 2, m = 4, mcmc = G, burnin = G, Waic = TRUE)
?NetworkChange
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, UL.Normal = 'Normal',Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, UL.Normal = 'NULL', Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, UL.Normal =NULL, Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, UL.Normal = 'NULL', Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, UL.Normal = 'Normal', Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, degree.normal = 'NULL', Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, degree.normal = 'eigen', Waic = TRUE)
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
temp <- array(NA, dim=c(n,n,num_time))
for(iter in 1:length(y_data)){temp[,,iter] <- c(y_data[[iter]]); temp[,,iter] <- diag(n)}
G <- 100
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, degree.normal = 'eigen', Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, Waic = TRUE)
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
temp <- array(NA, dim=c(n,n,num_time))
for(iter in 1:length(y_data)){temp[,,iter] <- c(y_data[[iter]]); diag(temp[,,iter]) <- 1}
G <- 100
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, Waic = TRUE)
out2 <- NetworkChange(temp, R = 3, m = 2, mcmc = G, burnin = G, Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, degree.normal = "NULL",
UL.Normal = "NULL",Waic = TRUE)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, degree.normal = "NULL",
UL.Normal = "NULL",Waic = F)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, degree.normal = "Lsym",
UL.Normal = "NULL",Waic = F)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, degree.normal = "Lsym",
UL.Normal = "Normal",Waic = F)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, degree.normal = "Lsym",
UL.Normal = "orthonormal",Waic = F)
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, DIC=T)
temp <- array(NA, dim=c(n,n,num_time))
for(iter in 1:length(y_data)){temp[,,iter] <- c(y_data[[iter]]); diag(temp[,,iter]) <- 1}
image(temp[,,1])
temp <- array(NA, dim=c(n,n,num_time))
for(iter in 1:length(y_data)){temp[,,iter] <- c(y_data[[iter]])}
G <- 100
out2 <- NetworkChange(temp, R = 2, m = 2, mcmc = G, burnin = G, DIC=T)
image(temp[,,1])
image(temp[,,26])
image(temp[,,100])
dim(temp)
Evaluation_ecp <- function(y_list, p_thres, num_stats, R_val, is_experiment=FALSE, true_CP=c(26, 51, 76)){
library(ergm)
if(is_experiment){
y_data <- y_list
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1
temp <- matrix(NA, nrow=num_time, ncol=num_stats)
for(t in 1:num_time){
if(num_stats == 2){
yt <- network(y_data[[t]], directed = F)
temp[t,] = summary(yt ~ edges + triangles)
}else if(num_stats == 3){
yt <- network(y_data[[t]], directed = F)
temp[t,] = summary(yt ~ edges + isolates + triangles)
}
}
est_CP <- e.divisive(as.matrix(temp), sig.lvl=p_thres, R=R_val, k=NULL, min.size=10); rm(temp)
est_CP <- est_CP$estimates
est_CP <- sort(est_CP)
est_CP <- est_CP + 1
return(est_CP)
}else{
repetition_iteration <- length(y_list)
result <- matrix(NA, nrow=repetition_iteration, ncol = 4)
for(rep_iter in 1:repetition_iteration){
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1 # i.e. T=150, then num_theta=149 (tau), and num_beta=148
temp <- matrix(NA, nrow=num_time, ncol=num_stats)
for(t in 1:num_time){
if(num_stats == 2){
temp[t,] = summary(y_data[[t]] ~ edges + mutual)
}else if(num_stats == 3){
temp[t,] = summary(y_data[[t]] ~ edges + mutual + triangles)
}else if(num_stats == 4){
yt <- network(y_data[[t]])
network::set.vertex.attribute(yt, "Gender", gender)
temp[t,] = summary(yt ~ edges + mutual + triangles + nodematch("Gender"))
}
}
est_CP <- e.divisive(as.matrix(temp), sig.lvl=p_thres, R=R_val, min.size=15); rm(temp)
est_CP <- est_CP$estimates; print(est_CP)
est_CP <- sort(est_CP)
est_CP <- est_CP + 1
num_CP <- length(est_CP)
gt_CP_corrected <- c(1, true_CP, tau+2) # tau+2 = T+1
est_CP_corrected <- c(1, est_CP, tau+2)
gt_list <- est_list <- list();
for(i in 2:length(gt_CP_corrected)){
gt_list[[i-1]] <- gt_CP_corrected[i-1]:(gt_CP_corrected[i]-1)
}
for(i in 2:length(est_CP_corrected)){
est_list[[i-1]] <- est_CP_corrected[i-1]:(est_CP_corrected[i]-1)
}
if(num_CP == 0){
dist_est_gt <- Inf
dist_gt_est <- -Inf
covering_metric <- 0
}else{
holder <- c()
for(i in true_CP){
dist_diff <- c()
for(j in est_CP){dist_diff <- c(dist_diff, abs(j-i))}
holder <- c(holder, min(dist_diff))
}
dist_est_gt <- max(holder)
holder <- c()
for(i in est_CP){
dist_diff <- c()
for(j in true_CP){dist_diff <- c(dist_diff, abs(j-i))}
holder <- c(holder, min(dist_diff))
}
dist_gt_est <- max(holder)
covering_metric <- 0
for(i in 1:length(gt_list)){
A <- gt_list[[i]]
jaccard <- c()
for(j in 1:length(est_list)){
A_prime <- est_list[[j]]
jaccard <- c(jaccard,length(intersect(A,A_prime))/length(union(A,A_prime)))
}
covering_metric <- covering_metric + length(A)*max(jaccard)
}
covering_metric <- covering_metric/(tau+1) # tau+1 = T
}
abs_error <- abs(num_CP - length(true_CP))
result[rep_iter, 1] <- abs_error
result[rep_iter, 2] <- dist_est_gt
result[rep_iter, 3] <- dist_gt_est
result[rep_iter, 4] <- covering_metric
}
return(result)
}
}
num_seq = 15
num_node <- c(50, 100, 200)
network_stats=c("edges", "mutual")
i <- 1
set.seed(1)
SBM_list <- sim_SBM_list(num_seq, n=num_node[i], rho=0.0)
sim_result8 <- Evaluation_ecp(SBM_list,p_thres=0.01, num_stats=length(network_stats), R_val=100)
Evaluation_ecp <- function(y_list, p_thres, num_stats, R_val, is_experiment=FALSE, true_CP=c(26, 51, 76)){
library(ergm)
if(is_experiment){
y_data <- y_list
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1
temp <- matrix(NA, nrow=num_time, ncol=num_stats)
for(t in 1:num_time){
if(num_stats == 2){
yt <- network(y_data[[t]], directed = F)
temp[t,] = summary(yt ~ edges + triangles)
}else if(num_stats == 3){
yt <- network(y_data[[t]], directed = F)
temp[t,] = summary(yt ~ edges + isolates + triangles)
}
}
est_CP <- e.divisive(as.matrix(temp), sig.lvl=p_thres, R=R_val, k=NULL, min.size=10); rm(temp)
est_CP <- est_CP$estimates
est_CP <- sort(est_CP)
est_CP <- est_CP + 1
return(est_CP)
}else{
repetition_iteration <- length(y_list)
result <- matrix(NA, nrow=repetition_iteration, ncol = 4)
for(rep_iter in 1:repetition_iteration){
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1 # i.e. T=150, then num_theta=149 (tau), and num_beta=148
temp <- matrix(NA, nrow=num_time, ncol=num_stats)
for(t in 1:num_time){
if(num_stats == 2){
temp[t,] = summary(y_data[[t]] ~ edges + mutual)
}else if(num_stats == 3){
temp[t,] = summary(y_data[[t]] ~ edges + mutual + triangles)
}else if(num_stats == 4){
yt <- network(y_data[[t]])
network::set.vertex.attribute(yt, "Gender", gender)
temp[t,] = summary(yt ~ edges + mutual + triangles + nodematch("Gender"))
}
}
est_CP <- e.divisive(as.matrix(temp), sig.lvl=p_thres, R=R_val, k=NULL, min.size=15); rm(temp)
est_CP <- est_CP$estimates; print(est_CP)
est_CP <- sort(est_CP)
est_CP <- est_CP + 1
num_CP <- length(est_CP)
gt_CP_corrected <- c(1, true_CP, tau+2) # tau+2 = T+1
est_CP_corrected <- c(1, est_CP, tau+2)
gt_list <- est_list <- list();
for(i in 2:length(gt_CP_corrected)){
gt_list[[i-1]] <- gt_CP_corrected[i-1]:(gt_CP_corrected[i]-1)
}
for(i in 2:length(est_CP_corrected)){
est_list[[i-1]] <- est_CP_corrected[i-1]:(est_CP_corrected[i]-1)
}
if(num_CP == 0){
dist_est_gt <- Inf
dist_gt_est <- -Inf
covering_metric <- 0
}else{
holder <- c()
for(i in true_CP){
dist_diff <- c()
for(j in est_CP){dist_diff <- c(dist_diff, abs(j-i))}
holder <- c(holder, min(dist_diff))
}
dist_est_gt <- max(holder)
holder <- c()
for(i in est_CP){
dist_diff <- c()
for(j in true_CP){dist_diff <- c(dist_diff, abs(j-i))}
holder <- c(holder, min(dist_diff))
}
dist_gt_est <- max(holder)
covering_metric <- 0
for(i in 1:length(gt_list)){
A <- gt_list[[i]]
jaccard <- c()
for(j in 1:length(est_list)){
A_prime <- est_list[[j]]
jaccard <- c(jaccard,length(intersect(A,A_prime))/length(union(A,A_prime)))
}
covering_metric <- covering_metric + length(A)*max(jaccard)
}
covering_metric <- covering_metric/(tau+1) # tau+1 = T
}
abs_error <- abs(num_CP - length(true_CP))
result[rep_iter, 1] <- abs_error
result[rep_iter, 2] <- dist_est_gt
result[rep_iter, 3] <- dist_gt_est
result[rep_iter, 4] <- covering_metric
}
return(result)
}
}
sim_result8 <- Evaluation_ecp(SBM_list,p_thres=0.01, num_stats=length(network_stats), R_val=100)
library(ergm)
y_list <- SBM_list
rep_iter <- 1
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1 # i.e. T=150, then num_theta=149 (tau), and num_beta=148
num_stats=length(network_stats)
temp <- matrix(NA, nrow=num_time, ncol=num_stats)
for(t in 1:num_time){
if(num_stats == 2){
temp[t,] = summary(y_data[[t]] ~ edges + mutual)
}else if(num_stats == 3){
temp[t,] = summary(y_data[[t]] ~ edges + mutual + triangles)
}else if(num_stats == 4){
yt <- network(y_data[[t]])
network::set.vertex.attribute(yt, "Gender", gender)
temp[t,] = summary(yt ~ edges + mutual + triangles + nodematch("Gender"))
}
}
num_stats == 2
summary(y_data[[t]] ~ edges + mutual)
length(y_data)
temp[t,] = summary(y_data[[t]] ~ edge + mutual)
yt <- network(y_data[[t]], directed = F)
summary(yt ~ edges + mutual)
library(devtools)
#install_github("allenkei/CPDstergm", force = TRUE)
library(CPDstergm)
y_data <- y_list[[rep_iter]]
num_time <- length(y_data)
n <- dim(y_data[[1]])[1]
tau <- num_time-1 # i.e. T=150, then num_theta=149 (tau), and num_beta=148
temp <- matrix(NA, nrow=num_time, ncol=num_stats)
for(t in 1:num_time){
yt <- network(y_data[[t]], directed = F)
if(num_stats == 2){
temp[t,] = summary(yt ~ edges + mutual)
}else if(num_stats == 3){
temp[t,] = summary(yt ~ edges + mutual + triangles)
}else if(num_stats == 4){
yt <- network(yt)
network::set.vertex.attribute(yt, "Gender", gender)
temp[t,] = summary(yt ~ edges + mutual + triangles + nodematch("Gender"))
}
}
