In sctyner/netvizinf: Create network lineups for visual inference on stochastic actor-oriented models

knitr::opts_chunk$set(echo = TRUE, cache = TRUE)

Where do we start?

We start with some data that we want to model using RSiena. So, let's find some data and fit a simple model to it.

library(RSiena)
friend.data.w1 <- as.matrix(read.table("../data/s50-network1.dat"))
friend.data.w2 <- as.matrix(read.table("../data/s50-network2.dat"))
friend.data.w3 <- as.matrix(read.table("../data/s50-network3.dat"))
drink <- as.matrix(read.table("../data/s50-alcohol.dat"))
friendship <- sienaDependent(
  array(c(friend.data.w1, friend.data.w2,
          friend.data.w3),
        dim = c(50, 50, 3)))
alcohol <- varCovar(drink)
mydata <- sienaDataCreate(friendship, alcohol)
myeffnull <- getEffects(mydata)
myalgorithm <- sienaAlgorithmCreate(projname = 's50_3')
set.seed(823746)
ansnull <- siena07(myalgorithm, data = mydata, effects = myeffnull,
                   returnChains = TRUE, returnDataFrame = TRUE,
                   returnDeps = TRUE, silent = TRUE, verbose = FALSE,
                   batch = TRUE)

What's next?

Now that we have our fitted model, we want to look "underneath the hood" to see the microsteps that are going on underneath. Let's extract those microsteps.

library(netvizinf)
library(dplyr)
library(readr)
library(sna)
library(network)
ansnullchains <- get_chain_info(ansnull)
ansnullchains %>% 
  filter(period == 1) %>%  #only look at chains from wave 1 to wave 2
  group_by(rep) %>%
  select(rep, from = X4, to = X5) %>% 
  mutate(val = as.numeric(!from == to),
         from = paste0("V", parse_number(from)+1), # make the chains
         to = paste0("V", parse_number(to)+1)     # match the data vars 
  ) -> ansnullchainsw1w2

# create microstep data from 1 of the 1000 reps in the chain. 
library(geomnet)
wave1friends <- fortify(as.adjmat(friend.data.w1))
ms1 <- listMicrosteps(dat = wave1friends, 
                      microsteps = filter(ansnullchainsw1w2, rep == 1))
# we're only going to do the first 5 microsteps. 
microsteps <- ms1[1:5]

Get data in a form to visualize

Now, we want to create datasets that are appropriate for visualization using some functions from netvizinf and tweenr.

to_tween <- pretween_vertices(microsteps = microsteps, layoutparams = list(n = 50))
library(tweenr)
tweendat <- tween_states(data = to_tween, 20 ,1,"linear", nframes = 100)
# create some visualization variables.
pte <- pretween_edges(microsteps)
# color new edges
library(ggplot2)
library(animation)
library(gganimate)
p <- ggplot(data = unique(tweendat[, c("from", "x.from", "y.from",
                                  "addedge", "rmvedge", ".frame")]), 
                          aes(x=x.from, y = y.from, frame = .frame)) +
  geom_segment(data = tweendat, aes(x = x.from, y = y.from, xend = x.to, yend = y.to, frame = .frame, color = addedge)) + 
  geom_point(size=5, color = 'grey40') + 
  #geom_text(aes(label=from), size = 3, alpha = .5, color = 'white') + 
  scale_colour_manual(values = c("black", "red"), guide = guides(color = "none")) + 
  scale_alpha_identity() + 
  theme_void() 
animation::ani.options(interval = 1/4)
gganimate(p, "fivemicrosteps_attempt1.gif", title_frame = F)

My incredibly screwed up attempt to do this more efficiently

# baby edge disappear example

layout1 <- data.frame(x = c(0,1), y = c(0,1), id = c("V1", "V2"), ms = 0, rmvedge = c(T,F))
layout2 <- data.frame(x = c(0,1), y = c(1,0), id = c("V1", "V2"), ms = 1, rmvedge = F)

babytweend <- tween_states(list(layout1, layout2), 5,1,"linear", 5)

babyedge1 <- data.frame(from = "V1", to = "V2", rmvedge = TRUE, ms = 0)
babyedge2 <- data.frame(from = c("V1", "V2"), to = NA, rmvedge = FALSE, ms = 1)
babyedges <- rbind(babyedge1, babyedge2)

babystep1 <- merge(babyedges, babytweend, by.x = c("from", "rmvedge", "ms"), by.y = c("id", "rmvedge", "ms"), all.y = T) %>% arrange(.frame, x,y)
babystep2 <- merge(babystep1, babytweend[,-5], by.x = c("to", "ms",".frame"), by.y = c("id", "ms",".frame"), all.x=T)

idx <- is.na(babystep2$to) & babystep2$ms < 1 & babystep2$ms > 0 & babystep2$from == "V1"

babystep2$to[idx] <- "V2"
fms <- babystep2$.frame[idx]
babystep2[idx, c("x.y", "y.y")] <- babystep2[babystep2$from == "V2" & babystep2$.frame %in% fms,c("x.x", "y.x")]

ggplot(data = babystep2, aes(x = x.x, y = y.x, frame = .frame)) +
  geom_segment(aes(xend = x.y, yend = y.y, alpha = 1-ms), color = 'red') + 
  geom_point(color = 'grey40') + 
  scale_alpha_identity() + 
  facet_wrap(~.frame)


# bigger example 
microsteps <- ms1[1:5]
to_tween <- pretween_vertices(microsteps = microsteps, layoutparams = list(n = 50))
pte <- pretween_edges(microsteps = microsteps)

tweendat <- tween_states(data = to_tween, statelength = 18, 1, "linear",100)
tweendat$addedge <- as.logical(tweendat$addedge)
tweendat$rmvedge <- as.logical(tweendat$rmvedge)

# first, split according to microstep. 
listTweened <- split(tweendat, as.factor(tweendat$ms))

listPostTween <- list()
# then, join edges
for (i in 1:length(listTweened)){
  # if rmvedge, merge 'old' edgelist with tweened
  currentMS <- unique(listTweened[[i]]$ms)
  ms_from_edges <- floor(currentMS)

  if(sum(listTweened[[i]]$addedge) > 0 & currentMS != round(currentMS)) {
    step1 <- merge(microsteps[[currentMS+2]], listTweened[[i]], 
                   by.x = "from", 
                   by.y = "id", all.x = TRUE)
    names(step1)[names(step1) %in% c("x", "y")] <- c("x.from", "y.from")
    step2 <- merge(step1, listTweened[[i]], 
                   by.x = c("to", "ms", "addedge", "rmvedge",".frame"), 
                   by.y = c("id", "ms","addedge", "rmvedge",".frame"), 
                   all.x = TRUE)
    names(step2)[names(step2) %in% c("x", "y")]  <- c("x.to", "y.to")
    listPostTween[[i]] <- step2
  } else {
    step1 <- merge(microsteps[[ms_from_edges+1]], listTweened[[i]], 
                   by.x = "from", by.y = "id", all.x = TRUE)
    names(step1)[names(step1) %in% c("x", "y")] <- c("x.from", "y.from")
    step2 <- merge(step1, listTweened[[i]],
                  by.x = c("to", "ms", "addedge", "rmvedge",".frame"),
                  by.y = c("id", "ms","addedge", "rmvedge",".frame"),
                  all.x = TRUE)
    names(step2)[names(step2) %in% c("x", "y")]  <- c("x.to", "y.to")
    listPostTween[[i]] <- step2
  }
}

# merge first, then go back and overwrite. 
# use all.y so that all frames are included, and none are NA. 
#step1 <- merge(pte, tweendat, by.x = c("from","addedge", "rmvedge",  "microstep"), by.y = c("id", "addedge", "rmvedge","ms"), all.y = TRUE)
#names(step1)[names(step1) %in% c("x", "y")] <- c("x.from", "y.from")
# remove the logicals in tweened because they're only relevant to the 'from' node 
#lgcls <- names(tweendat) %in% c("addedge", "rmvedge")
#step2 <- merge(step1, tweendat[,-which(lgcls)], by.x = c("to", "microstep", ".frame"), by.y = c("id", "ms",".frame"), all.x = TRUE)
#names(step2)[names(step2) %in% c("x", "y")]  <- c("x.to", "y.to")

#B <- length(unique(pte$microstep))

# for (i in 1:B){
#   new_data_to_plot <- list()
#   msid <- unique(pte$microstep)[i]
#   nodesub <- filter(tweendat, ms == msid)
#   edgesub <- filter(pte, microstep == msid)
#   allsub <- filter(step2, microstep >= msid & microstep <= msid+1)
#   if (sum(edgesub$rmvedge) > 0){
#     fromid <- unique(edgesub$from[which(edgesub$rmvedge)])
#     toid <- unique(edgesub$to[which(edgesub$rmvedge)])
#     idx_to_change <- which(is.na(allsub$to) & allsub$microstep < msid+1 &
#                              allsub$microstep > msid & allsub$from == fromid)
#     allsub$to[idx_to_change] <- toid
#     fms <- allsub$.frame[idx_to_change]
#     allsub[idx_to_change, c("x.to", "y.to")] <- allsub[which(allsub$from == toid & 
#                                                                allsub$.frame %in% fms), c("x.from", "y.from")]
#     new_data_to_plot[[i]] <- allsub
#   } else if (sum(edges))
# }

# if (sum(listTweened[[i]]$rmvedge) > 0){
#   step1 <- merge(microsteps[[ms_from_edges+1]], listTweened[[i]], 
#                  by.x = "from", 
#                  by.y = "id", all.x = TRUE)
#   names(step1)[names(step1) %in% c("x", "y")] <- c("x.from", "y.from")
#   step2 <- merge(step1, listTweened[[i]], 
#                  by.x = c("to", "ms", "addedge", "rmvedge",".frame"), 
#                  by.y = c("id", "ms","addedge", "rmvedge",".frame"), 
#                  all.x = TRUE)
#   names(step2)[names(step2) %in% c("x", "y")]  <- c("x.to", "y.to")
#   listPostTween[[i]] <- step2
# } else if (sum(listTweened[[i]]$addedge) > 0 & ceiling(currentMS) < ms_from_edges+1){
#   
# }
# if addedge, merge 'new' edgelist with tweened

# postTweendf <- do.call("rbind", listPostTween)
# 
# testp <- ggplot(data = postTweendf, aes(x = x.from, y = y.from, xend = x.to, yend = y.to, frame = .frame, color = addedge)) +
#   geom_segment(aes(color = ms)) + 
#   geom_point(size=4, color = 'grey40') + 
#   #geom_text(aes(label=from), size = 3, alpha = .5, color = 'white') + 
#   #scale_colour_manual(guide = guides(color = "none")) + 
#   scale_alpha_identity() + 
#   theme_void() 
# animation::ani.options(interval = 1/10)
# gganimate(testp, "newmethod.gif", title_frame = F)

sctyner/netvizinf documentation built on May 29, 2019, 4:20 p.m.