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

knitr::opts_chunk$set(echo = TRUE)

Get Small Friends Data

library(RSiena)
library(tidyverse)
library(sna)
library(network)
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"))
fd2.w1 <- friend.data.w1[20:35,20:35]
fd2.w2 <- friend.data.w2[20:35,20:35]
fd2.w3 <- friend.data.w3[20:35,20:35]
friendshipData <- array(c(fd2.w1, fd2.w2,fd2.w3), dim = c(16, 16, 3))
friendship <- sienaDependent(friendshipData)
alcohol <- varCovar(drink[20:35,])
mydata <- sienaDataCreate(friendship, alcohol)
myeffnull <- getEffects(mydata)
myalgorithm <- sienaAlgorithmCreate(projname = 's16_3')
set.seed(823746)
ansnull <- siena07(myalgorithm, data = mydata, effects = myeffnull,
                   returnChains = TRUE, returnDataFrame = TRUE,
                   returnDeps = TRUE, silent = TRUE, verbose = FALSE,
                   batch = TRUE)
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)) -> ansnullchainsw1w2

# create microstep data from 1 of the 1000 reps in the chain. 
library(geomnet)
colnames(fd2.w1) <- paste0("V", 1:16)
rownames(fd2.w1) <- paste0("V", 1:16)
wave1friends <- fortify(as.adjmat(fd2.w1))
ms1 <- listMicrosteps(dat = wave1friends, 
                      microsteps = filter(ansnullchainsw1w2, rep == 1))
# we're only going to do the first 5 microsteps. 
microsteps <- ms1[1:5]  
pte <- pretween_edges(microsteps = microsteps)
ptv <- pretween_vertices(pte = pte, layoutparams = list(n = 16))
library(tweenr)

to_nest <- tween_states(ptv, 10, 1, "linear", 50)
to_nest$addedge <- as.logical(to_nest$addedge)
to_nest$rmvedge <- as.logical(to_nest$rmvedge)
to_nest %>% nest(-c(.frame, ms)) -> tweennest 

library(purrr)
tweennest %>% 
  group_by(.frame) %>%
  mutate(joineddf = map(.x = data, .f = joinData, 
                        currentMS = ms, microsteps = pte)) -> testpurrmeth

testpurrmeth2 <- testpurrmeth[,-3] %>% unnest()
edges_unnested <- testpurrmeth2
# testpurrplot <- ggplot(data = testpurrmeth2,
#                        aes(x = x.from, y = y.from, xend = x.to, 
#                            yend = y.to, frame = .frame)) +
#   geom_segment(aes(alpha = 1 - (addedge + rmvedge), color = 1 - (addedge + rmvedge))) + 
#   geom_point(shape = 21, aes(fill = addedge + rmvedge), color = 'grey40') + 
#   scale_fill_continuous(low = 'grey40', high = 'green', guide = guides(fill = "none")) + 
#   scale_color_continuous(low = "red", high = 'black', guide = guides(color = "none")) + 
#   scale_alpha_identity() + 
#   theme_void()
# animation::ani.options(interval = 1/10)
# gganimate(testpurrplot, "purrmethod.gif", title_frame = F)
# 
# purrmetfrm1 <- filter(testpurrmeth2, .frame %in% 1:20)
# purrmetfrm1 <- purrmetfrm1 %>% 
#   mutate(.alpha = ifelse(addedge + rmvedge == 0, 1, 1-ms))

# ggplot() + 
#   geom_segment(data = purrmetfrm1, aes(x = x.from, y = y.from, 
#                                          xend = x.to, yend = y.to,
#                                          color = 1 - .alpha)) + 
#   geom_point(data = filter(to_nest, , aes(x = x, y = x, fill = addedge + rmvedge), 
#              shape = 21, color = 'grey40') + 
#   scale_fill_manual(values = c('grey40','green')) + 
#   scale_color_continuous(low = "red", high = 'black') + 
#   scale_alpha_identity() + 
#   theme_void() + 
#   facet_wrap(~.frame)
# 
# ggplot(data = to_nest %>% filter(.frame %in% 1:16)) + 
#   geom_point(shape = 21, aes(x=x, y=y, fill = addedge + rmvedge), color = 'grey40') + 
#   scale_fill_continuous(low = 'grey40', high = 'green') + 
#   theme_void() +
#   facet_wrap(~.frame)
# 
# ggplot() + 
#   geom_curve(data = purrmetfrm1 %>% filter(.frame %in% 1:15), curvature = .1,
#              aes(x = x.from, y = y.from, xend = x.to, yend = y.to,
#                  alpha = .alpha)) + 
#   geom_point(data = filter(to_nest, .frame %in% 1:15), shape = 21,
#              aes(x=x, y=y, fill = addedge + rmvedge), 
#              color = 'grey40') +
#   scale_fill_continuous(low = "grey40", high = "green") + 
#   scale_alpha_identity() + 
#   facet_wrap(~.frame) + 
#   theme_void()

Okay, I think I've decided to do this with 2 separate data frames: one for nodes (to_nest) and one for edges (testpurrmeth2 above). Now that the plots are looking okay, need to get the colors right.

Add color

# edge color 
edges_unnested_color <- colorEdges(edges_unnested = unnested_edges)



#ealpha <- 1 - (edges_unnested_color[rmvidx,"ms"][[1]] - #edges_unnested_color[rmvidx,"microstep"][[1]])
#edges_unnested_color[rmvidx,"ecolor"] <- rgb(1, 0, 0, alpha = ealpha) 
#ealpha2 <- 1 - (edges_unnested_color[addidx,"microstep"][[1]] - edges_unnested_color[addidx,"ms"][[1]]) 
#edges_unnested_color[addidx,"ecolor"] <- rgb(1, 0, 0, alpha = ealpha2) 

# vertex color
vertexdata <- to_nest
#vertexdata <- vertexdata %>% mutate(vcolor = 
                 #                     ifelse(as.logical(addedge) + as.logical(rmvedge) == 0, 
         #                                    rgb(102, 102, 102, alpha = 255, maxColorValue = #255), 
 #                                            NA))

vertexdata$vcolor <- "grey40"
vertexdata$vsize <- 1   
changess <- get_changes(pte)
#rmvidx <- which(as.logical(vertexdata$rmvedge))
#addidx <- which(as.logical(vertexdata$addedge)) 
# group by floor ms, then if any in the group are true, color accordingly 
# ifelse(any(rmvidx))
for (i in 1:nrow(changess)){
  chng <- changess[i,]
  changecolors <- which(vertexdata$id == chng$id & floor(vertexdata$ms) == chng$ms)
  Nc <- length(changecolors)
  vertexdata[changecolors, "vcolor"] <- tween_color(c("red", "grey40"),n = Nc, ease = "quartic-in")
  vertexdata[changecolors, "vsize"] <- tween_numeric(c(5, 1),n = Nc, ease = "quartic-in")
}

# vertexdata[rmvidx,"vcolor"] <- (vertexdata[rmvidx,] %>% group_by(floor(ms)) %>% 
#                                   mutate(count = seq_len(n())) %>% 
#                                   mutate(vcolor = tween_color(c("blue", "grey40"), n = n(), ease = "quartic-in")[[1]][count]) %>% ungroup() %>% select(vcolor))[[1]]
# vertexdata[addidx,"vcolor"] <- (vertexdata[addidx,] %>% group_by(floor(ms)) %>% 
#                                   mutate(count = seq_len(n())) %>% 
#                                   mutate(vcolor = tween_color(c("blue", "grey40"), n = n(), ease = "quartic-in")[[1]][count]) %>% ungroup() %>% select(vcolor))[[1]]

Animations

# add size of ego node and make smaller as edge appears/disappears check
# make node and edge the same color check
# make edges that don't change grey. 
library(gganimate)
plotsmallfriends <- ggplot() + 
  geom_curve(data = edges_unnested_color, curvature = .1,
             aes(x = x.from, y = y.from, xend = x.to, yend = y.to,
                 color = ecolor, frame = .frame, size = esize/2)) + 
  scale_color_identity() +
  geom_point(data = vertexdata, shape = 21,
             aes(x=x, y=y, fill = vcolor, frame = .frame, size = 5*vsize), 
             color = 'grey40') +
  scale_size_identity() + 
  geom_text(data = vertexdata, size = 3, 
             aes(x=x, y=y, label = id, frame = .frame), 
             color = "black") + 
  #geom_label(data = vertexdata %>% filter(id == "V1"), aes(frame = .frame, x = rep(-1,58), y = rep(2,58), label = round(ms,4))) + 
  scale_fill_identity() + 
  theme_void()
animation::ani.options(interval = 1/3)
gganimate(plotsmallfriends, "purrmethod_smallfriendslabeled2.gif", title_frame = F)

More microsteps example

pte <- pretween_edges(microsteps = ms1)
ptv <- pretween_vertices(pte = pte, layoutparams = list(n = 16))

library(tweenr)

ptv[[39]] <- ptv[[39]][-13,]
ptv[[39]]$rmvedge[12] <- TRUE

tweened_nodes <- tween_states(ptv, 10, 2, "linear", 500)
tweened_nodes$addedge <- as.logical(tweened_nodes$addedge)
tweened_nodes$rmvedge <- as.logical(tweened_nodes$rmvedge)
tweened_nodes %>% nest(-c(.frame, ms)) -> tweened_nested

library(purrr)
tweened_nested %>% 
  group_by(.frame) %>%
  mutate(joineddf = map(.x = data, .f = joinData, 
                        currentMS = ms, microsteps = pte)) -> joined_data

unnested_edges <- joined_data[,-3] %>% unnest()
#edges_unnested <- testpurrmeth2

# edge color 
edges_unnested_color <- colorEdges(edges_unnested = unnested_edges)

# vertex color
vertexdata_colors <- colorVertices(vertexdata = tweened_nodes, pte = pte)

# plot
plotsmallfriends_allms <- ggplot() + 
  geom_curve(data = edges_unnested_color, curvature = .1,
             aes(x = x.from, y = y.from, xend = x.to, yend = y.to,
                 color = ecolor, frame = .frame, size = esize/2)) + 
  scale_color_identity() +
  geom_point(data = vertexdata_colors, shape = 21,
             aes(x=x, y=y, fill = vcolor, frame = .frame, size = 4*vsize), 
             color = 'grey40') +
  scale_size_identity() + 
  #geom_text(data = vertexdata, size = 3, 
  #           aes(x=x, y=y, label = id, frame = .frame), 
  #           color = "black") + 
  #geom_label(data = vertexdata %>% filter(id == "V1"), aes(frame = .frame, x = rep(-1,58), y = rep(2,58), label = round(ms,4))) + 
  scale_fill_identity() + 
  theme_void()
animation::ani.options(list(interval = 1/4, ani.width = 200, ani.height = 200))
gganimate(plotsmallfriends_allms, "smallfriends_allmsteps.gif", title_frame = F)
#something not quite right with the additions. Nodes don't get highlighted until after edge is already changing. # nodes need to get smaller faster # something not quite right with additional edges either. # also should figure out how to make actual size of gif smaller so that it's not so large file-size wise

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