################################################################################## # Load libraries library(network) # Load Monk Data data(sampson, package="ergm") ySampson <- as.matrix(samplike) rownames(ySampson) <- 1:18 colnames(ySampson) <- 1:18 # Plot Data layout <- network.layout.fruchtermanreingold(samplike, layout.par=NULL) plot(samplike, label=1:18, mode="fruchtermanreingold", coord=layout) # Fit the Stochastic Block Model set.seed(1) library(mixer) fitb <- mixer(ySampson, qmin=1, qmax=5, method="variational") # Choose the best model mod <- getModel(fitb) mod # Compare estimated block membership with Sampson's groups library(mclust) z <- t(mod$Taus) grp <- get.vertex.attribute(samplike, "group") table(map(z), grp) ################################################################################## # Load the lda package for fitting the MMSB model. library(lda) # Load the compositions package for the ternary plots library(compositions) # Load the network library library(network) # Load the data library(MBCbook) data(PoliticalBlogs) yblog<-as.matrix(PoliticalBlogs) # Set parameters used for model fitting. set.seed <- 1 G <- 7 beta.prior <- list(1, diag(5, G) + 1) alpha.prior <- 0.1 # Fit the MMSB model. fit <- mmsb.collapsed.gibbs.sampler(yblog, K=G, num.iterations=10000, alpha=alpha.prior, beta.prior=beta.prior, burnin=1000L) # Extract the results and plot them. memberships <- with(fit, t(document_sums) / colSums(document_sums)) colnames(memberships) <- paste("Block", 1:G, sep="") plot(acomp(memberships)) # Summarize the results taumean <- apply(memberships,2,mean) taumean Theta <- fit$blocks.pos/(fit$blocks.pos+fit$blocks.neg) Theta # Further explore the extent of mixed membership entropy <- function(p){ p <- p[p>0] sum(-p*log(p)) } EoM <- exp(apply(memberships, 1, entropy)) hist(EoM) ################################################################################## # Load the relevant library library(latentnet); library(ergm.count) # Set a color palette for plots colPalette <- c("#999999","#E69F00","#56B4E9","#009E73","#F0E442","#0072B2","#D55E00","#CC79A7") # Load the Karate data data(zach) # Fit the model to the data. In this case a 2D latent space and G=4. set.seed(1) fit <- ergmm(zach~euclidean(d=2, G=4)) # Plot the fitted model plot(fit, pie=TRUE, cluster.col=colPalette[-1], edge.col="gray") # Compare the estimated group with faction.id lab <- get.vertex.attribute(zach, "faction.id") table(fit$mkl$Z.K, lab) # Compare the estimated group with club lab <- get.vertex.attribute(zach, "club") table(fit$mkl$Z.K, lab) # Fit a model with sender/receiver effects, 2D latent space and G=2. fit <- ergmm(as.network(zach)~euclidean(d=2, G=2)+rsender(var=1, var.df=3)+rreceiver(var=1, var.df=3)) # Plot the fitted model plot(fit, pie=TRUE, rand.eff="receiver", cluster.col=colPalette[-1], edge.col="gray") # Compare the estimated group with faction.id lab <- get.vertex.attribute(zach, "faction.id") table(fit$mkl$Z.K, lab) # Compare the estimated group with club lab <- get.vertex.attribute(zach, "club") table(fit$mkl$Z.K, lab) ################################################################################## # Load the relevant libraries library(VBLPCM); library(network); library(MBCbook) # Set a color palette for plots colPalette <- c("#999999","#E69F00","#56B4E9","#009E73","#F0E442","#0072B2","#D55E00","#CC79A7") # Load the data data(Friend) yfriend <- as.matrix(Friend) # Fit the model to the data. In this case a 2D latent space and G=4 set.seed(1) v.start<-vblpcmstart(Friend,G=2,model=c("rreceiver")) v.fit<-vblpcmfit(v.start) # Plot the fitted model plot(v.fit, R2=0.03,pie=TRUE, rand.eff="rreceiver", colours=colPalette[-1]) # Compare the fitted groups with seniority lab <- attrib$seniority table(lab, map(t(v.fit$V_lambda))) # Fit the same model using latentnet fit <- ergmm(as.network(yfriend)~euclidean(d=2, G=2)+rreceiver(var=1,var.df=3)) # Plot the fitted model plot(fit, pie=TRUE, rand.eff="sociality", cluster.col=colPalette[-1], edge.col="gray") # Compare the fitted groups with status lab <- attrib$seniority table(lab,fit$mkl$Z.K)