---
title: "Diffusion"
author: "by James Hollway"
output: 
  learnr::tutorial:
    theme: journal
runtime: shiny_prerendered
---

```{r setup, include = FALSE}
library(learnr)
library(manynet)
library(migraph)
library(patchwork)
knitr::opts_chunk$set(echo = FALSE)
```

## Investigate diffusion through simulation

In this tutorial, we're going to look at several diffusion processes 
and how they operate across various networks.
Let's start off with creating and visualising a few networks 
that we might be interested in here.
Let's take the `ison_networkers` dataset from `{manynet}`,
and create or generate ring, lattice, random, scale-free, and small-world
versions with the same number of nodes.

```{r create, echo = TRUE, exercise = TRUE}

```

```{r create-hint-1}
# Let's create a new object, "nw", the removes the names of all vertex names
# Hint: We want to use two functions used for reformatting networks, graphs, and matrices

nw <- ____(____(ison_networkers))
```

```{r create-hint-2}
# We also want to remove edge direction, so that any pair of nodes with at least
# one directed edge will be connected by an undirected edge in the new network.

nw <- ____(to_unnamed(ison_networkers))
```

```{r create-solution}
nw <- to_undirected(to_unnamed(ison_networkers))
```

### Creating and visualising different network structures

Now, using the "nw" network from the last section, let's create or generate ring, lattice, random, scale-free, and small-world versions with the same number of nodes using functions like:

+ `create_ring()`: Creates a ring or chord graph of the given dimensions that loops around is of a certain width or thickness.
+ `create_lattice()`: Creates a graph of the given dimensions with ties to all neighbouring nodes
+ `generate_random()`: Generates a random network with a particular probability.
+ `generate_scalefree()`: Generates a small-world structure following the lattice rewiring model.
+ `generate_smallworld()`: Generates a scale-free structure following the preferential attachment model.

```{r create-nwstructure, echo = TRUE, exercise = TRUE}

```

```{r create-nwstructure-hint-1}
# Let's generate a ring structure, "rg", with a width of 2, using the appropriate
# function above

rg <- ____(____, ____)
```

```{r create-nwstructure-hint-2}

rg <- create_ring(nw, width = 2)
```

```{r create-nwstructure-hint-3}
# Let's generate a lattice structure, "la", using the appropriate function above

la <- ____(____)
```

```{r create-nwstructure-hint-4}

la <- create_lattice(nw)
```

```{r create-nwstructure-hint-5}
# Let's generate a random structure, "rd", without attributes

rd <- ____(____, ____)
```

```{r create-nwstructure-hint-6}

rd <- generate_random(nw, with_attr = FALSE)
```

```{r create-nwstructure-hint-7}
# The last two will look similar. For the smallworld structure we call the object "sw" 
# and for scalefree, "sf". We will also set the proportion of possible ties to 0.025.

sf <- ____(nw, ____)
sw <- ____(nw, ____)
```

```{r create-nwstructure-hint-8}

sf <- generate_scalefree(nw, 0.025)
sw <- generate_smallworld(nw, 0.025)
```

```{r create-nwstructure-hint-9}
# Finally, let's plot the respective graphs:

autographr(____) + ggtitle("Networkers") +
autographr(____) + ggtitle("Ring") +
autographr(____) + ggtitle("Lattice") +
autographr(____) + ggtitle("Random") +
autographr(____) + ggtitle("Scale-Free") +
autographr(____) + ggtitle("Small-World")
```

```{r create-nwstructure-solution}
# Here is the solution:

rg <- create_ring(nw, width = 2)
la <- create_lattice(nw)
rd <- generate_random(nw, with_attr = FALSE)
sf <- generate_scalefree(nw, 0.025)
sw <- generate_smallworld(nw, 0.025)
autographr(nw) + ggtitle("Networkers") +
autographr(rg) + ggtitle("Ring") +
autographr(la) + ggtitle("Lattice") +
autographr(rd) + ggtitle("Random") +
autographr(sf) + ggtitle("Scale-Free") +
autographr(sw) + ggtitle("Small-World")
```


### Examining diffusion across networks of different structure

Now, let's start off by examining a pretty straight-forward structure,
that of the ring network.
To run a basic diffusion model across this network,
simply pass it to `play_diffusion()` and (save and) plot the result.

```{r ring, exercise = TRUE, exercise.setup = "create"}

```

```{r ring-hint}
# Let's call the ring structure from the previous section, "rg", and create a new object
# "rg1" with a seed of 1. Don't forget to plot it!

rg1 <- play_diffusion(____, ____)
____(____)
```

```{r ring-solution}
rg1 <- play_diffusion(rg, seeds = 1)
plot(rg1)
```

The result object, when printed, lists how many of the nodes in the network,
`n`, are 'infected' (`I`) or not (`S`) at each step `t`.
The plot visualises this, with the proportion of `S` in blue and `I` in red.
The bar plot behind shows how many nodes are newly 'infected' at each
time point.

We can see that there is a pretty constant diffusion across this network,
with 2-3 nodes being newly infected at each time-point.
The whole network is infected by the eighth time-point.

### Varying seed nodes

Since the ring network we constructed is cyclical,
then no matter where the 'infection' starts, 
it should diffuse throughout the whole network.
To see whether this is true, 
try choosing the sixteenth (middle) node 
and see whether the result is any different.

```{r ring2, exercise = TRUE, exercise.setup = "create"}

```

```{r ring2-solution}
rg2 <- play_diffusion(rg, seeds = 16)
plot(rg2)
```

```{r ring2-interp, echo = FALSE}
question("Do you see any differences?",
         answer("Yes"),
         answer("No", correct = TRUE),
        allow_retry = TRUE)
```

Now what if we seed the network with more than one infected node?
Choosing the first four nodes we can see that the process is jump-started,
but doesn't really conclude that much faster.

```{r ring3, exercise = TRUE, exercise.setup = "create"}

```

```{r ring3-hint}
# Remember we want to see the first four nodes.

plot(play_diffusion(rg, seeds = ____))
```

```{r ring3-solution}
plot(play_diffusion(rg, seeds = 1:4))
```

But what if we seed the network at three different places?
Here we can use `node_is_random()` to randomly select some nodes to seed.
Try it with four randomly-selected nodes and see what you get.

```{r ring4, exercise = TRUE, exercise.setup = "create"}

```

```{r ring4-hint}
# We will be using the node_is_random() within the seed argument to random select 
# 4 nodes

plot(play_diffusion(rg, seeds = ____(rg, ____)))
```

```{r ring4-solution}
plot(play_diffusion(rg, seeds = node_is_random(rg, 4)))
```

```{r ring4-interp, echo = FALSE}
question("Do you see any differences?",
         answer("Yes", correct = TRUE),
         answer("No"),
        allow_retry = TRUE)
```

Where the innovation/disease is optimally seeded to 
accelerate or decelerate diffusions 
is a crucial question in network intervention studies.

### Varying networks

Now let's see whether where the infection is seeded matters
when the network has a different structure.
Here let's play and plot two diffusion on the lattice network,
one with the first node as seed and again one on the last.

```{r lattice, exercise = TRUE, exercise.setup = "create"}

```

```{r lattice-solution}
plot(play_diffusion(la, seeds = 1))/
plot(play_diffusion(la, seeds = 16))
```

```{r lattice-interp, echo = FALSE}
question("Do you see any differences?",
         answer("Yes", correct = TRUE),
         answer("No"),
        allow_retry = TRUE)
```

Let's try one more network type, this time the scale-free network.
Play and plot the results over ten steps for node 10,
random, maximum, and minimum nodes as seeds.

Similar to the previous examples, we will be using the following functions within the seed argument:

+ `node_is_random()`: Returns a logical vector indicating a random selection of nodes as TRUE.
+ `node_is_max()`: Returns logical of which nodes hold the maximum of some measure.
+ `node_is_min()`: Returns logical of which nodes hold the minimum of some measure.

```{r scale, exercise = TRUE, exercise.setup = "create"}

```

```{r scale-solution}
plot(play_diffusion(sf, seeds = 10, steps = 10)) / 
plot(play_diffusion(sf, seeds = node_is_random(sf), steps = 10)) /
plot(play_diffusion(sf, seeds = node_is_max(node_degree(sf)), steps = 10)) /
plot(play_diffusion(sf, seeds = node_is_min(node_degree(sf)), steps = 10))
```

```{r mindeg-interp, echo = FALSE}
question("Which of these four led to the fastest diffusion process?",
         answer("Minimum degree node(s), because there are many more nodes with the minimum degree.", correct = TRUE),
         answer("Node 10 as seed, because it is the most influential."),
         answer("Maximum degree node(s), because these nodes are the most influential."),
         answer("A random node, because this time it selected a good seed."),
        allow_retry = TRUE,
        random_answer_order = TRUE)
```

### Varying thresholds

So far, we've been using a simple diffusion model where each node
needs only to be in contact with one infectious individual to be infected.
But what if nodes have higher _thresholds_ or even where they vary?

Let's first start out with our ring network again.
Show that whereas a threshold of one will result in complete infection,
a threshold of two will not lead to any diffusion process unless
there are two seeds and that they are in another nodes neighbourhood.

```{r complex, exercise = TRUE, exercise.setup = "create"}

```

```{r complex-solution}
plot(play_diffusion(rg, seeds = 1, thresholds = 1))/
plot(play_diffusion(rg, seeds = 1, thresholds = 2))/
plot(play_diffusion(rg, seeds = 1:2, thresholds = 2))/
plot(play_diffusion(rg, seeds = c(1,16), thresholds = 2))
```

```{r complex-interp, echo = FALSE}
question("For which seed/threshold combinations was there complete infection?",
         answer("seeds = 1 and thresholds = 1", correct = TRUE),
         answer("seeds = 1 and thresholds = 2"),
         answer("seeds = 1:2 and thresholds = 2", correct = TRUE),
         answer("seeds = c(1,16) and thresholds = 2"),
        allow_retry = TRUE)
```

In our ring network, all nodes have the same degree.
But many typical social networks include some variation in degree.
A threshold of 2 would be easy to surpass for particularly well connected nodes,
but impossible for pendants.
Let's see what happens when we use this threshold on a scale-free network.

```{r sfcomplex, exercise = TRUE, exercise.setup = "create"}

```

```{r sfcomplex-solution}
plot(play_diffusion(sf, seeds = 1, thresholds = 2))
```

```{r sfcomplex-interp, echo=FALSE}
question("Does it matter how many seeds are used?",
         answer("Yes"),
         answer("No", correct = TRUE),
        allow_retry = TRUE)
```

That's because there's variation in degree in a scale-free network.
Let's try again, but this time we're going to specify the threshold
as a proportion of contacts that should be infected before the node 
will become infected.
Try thresholds of 0.1, 0.25, and 0.5 on two seeds and 10 steps.

```{r sfprop, exercise = TRUE, exercise.setup = "create"}

```

```{r sfprop-hint}
plot(play_diffusion(sf, seeds = 1:2, thresholds = ____, steps = ____))/
plot(play_diffusion(sf, seeds = 1:2, thresholds = ____, steps = ____))/
plot(play_diffusion(sf, seeds = 1:2, thresholds = ____, steps = ____))
```

```{r sfprop-solution}
plot(play_diffusion(sf, seeds = 1:2, thresholds = 0.1, steps = 10))/
plot(play_diffusion(sf, seeds = 1:2, thresholds = 0.25, steps = 10))/
plot(play_diffusion(sf, seeds = 1:2, thresholds = 0.5, steps = 10))
```

```{r sfprop-interp, echo = FALSE}
question("Does the threshold proportion matter?",
         answer("Yes", correct = TRUE),
         answer("No"),
        allow_retry = TRUE)
```

What's happening here is that the high degree nodes in this scale-free network
are obstructing the diffusion process because it is unlikely that many of their branches are already infected.

Lastly, note that it may be that thresholds vary across the network.
You could make this depend on some nodal attribute, 
or just assign some random variation.
Try two diffusion models, one where the threshold is 0.1 for the first 10
and 0.25 for the latter group of 22 nodes,
and another diffusion where the threshold levels are reversed.

```{r rand, exercise = TRUE, exercise.setup = "create"}

```

```{r rand-hint}
plot(play_diffusion(sf, thresholds = c(rep(____,____), rep(____,____))))/
plot(play_diffusion(sf, thresholds = c(rep(____,____), rep(____,____))))
```

```{r rand-solution}
plot(play_diffusion(sf, thresholds = c(rep(0.1,10), rep(0.25,22))))/
plot(play_diffusion(sf, thresholds = c(rep(0.25,10), rep(0.1,22))))
```

Since the first ten nodes are the first to join the scale-free network
and are preferentially attached by those who follow,
they will have a higher degree and only with a lower threshold will
we see complete infection.

## Investigate epidemiological models

So far we've been looking at variations on a 
pretty straight-forward diffusion process
where nodes can only belong to one of two states or 'compartments',
**S**usceptible and **I**nfected (the basic SI model).
This has been useful, but sometimes what we are interested in,
whether disease, innovation, or some other behaviour,
has more complicated and probabilistic dynamics.
But before we get into that,
let's see how we can play and plot several simulations
to see what the range of outcomes might be like.

### Running multiple simulations

To do this, we need to use `play_diffusions()` (note the plural).
It has all the same arguments as its singular counterpart,
along with a couple of additional parameters 
to indicate how many simulations it should run, e.g. `times = 50`,
whether it should use `strategy = "multisession"` 
to run the simulations across multiple cores
instead of the default `strategy = "sequential`,
and `verbose = TRUE` if it should inform you of computational progress.
Try this out with our well-mixed random network, 10 steps, 5 times,
and with a `transmissibility` parameter set to 0.5
to indicate that in only 1/2 cases is contagion successful.

```{r diffusions, exercise = TRUE, exercise.setup = "create"}

```

```{r diffusions-hint}
# Remember, we are looking at the random network from before, "rd", with 
# a transmissibility parameter of 0.5, 5 times, and 10 steps.

plot(play_diffusions(____, transmissibility = ____, times = ____, steps = ____))
```

```{r diffusions-solution}
plot(play_diffusions(rd, transmissibility = 0.5, times = 5, steps = 10))
```

Note that in this plot the number of new infections is not plotted,
and the loess line smooths over the varying trajectories.
The blue line is the proportion of nodes in the Susceptible compartment,
and the red line is the proportion of nodes in the Infected compartment.

### SIR models

Let's start off with an **SIR** model in which, 
after some period in which an infected node is themselves infectious,
they recover and can no longer infect or become reinfected.
To add a recovered component to the model,
specify the `recovery` argument.
Let's try a rate of recovery of 0.20,
which means that it'll take an infected node on average
5 steps (days?) to recover.

```{r sir, exercise = TRUE}

```

```{r sir-hint}
# Remember, we are still looking at the random network, "rd", with a 
# recovery rate of 20 percent.

plot(play_diffusions(____, recovery = ____))
```

```{r sir-solution}
plot(play_diffusions(rd, recovery = 0.2))
```

What we see in these kinds of models is typically a spike in infections
towards the start, but as these early infections recover and become immune,
then they can provide some herd immunity to those who remain susceptible.

### SIRS models

That's great, but maybe the immunity conferred from having recovered
from the contagion doesn't last forever.
In this kind of model, add an additional waning parameter of 0.05.
Play a single diffusion so that you can see what's going on in a particular run.

```{r sirs, exercise = TRUE}

```

```{r sirs-solution}
plot(play_diffusion(rd, recovery = 0.25, waning = 0.05))
```

```{r sirs-interp, echo = FALSE}
question("Does the process reach a stable state?",
         answer("Yes", correct = TRUE),
         answer("No"),
        allow_retry = TRUE)
```

### SEIR models

Lastly, we'll consider a compartment for nodes that have been Exposed
but are not yet infectious.
This kind of an incubation period is due to some `latency`.
Again, this should be specified as a proportion 
(try 0.25, approx four days).
Play a single diffusion so that you can see what's going on in a particular run.

```{r seir, exercise = TRUE, exercise.setup = "create"}

```

```{r seir-solution}
plot(play_diffusion(rd, latency = 0.25, recovery = 0.25))
```

## Investigate learning through simulation

Lastly, we're going to consider a different kind of model:
a DeGroot learning model.
As you will recall, a network that is strongly connected and aperiodic
will converge to a consensus of (any) beliefs entered.

### Expectations of convergence and consensus 

Let's try this out on the `ison_networkers` dataset included in the package.
First of all, check whether the network is _connected_ and _aperiodic_ via the following functions:

+ `is_connected()`: Tests whether network is weakly connected if the network is *undirected* or strongly connected if directed.
+ `is_aperiodic()`: Tests whether network is aperiodic.

```{r aperiod, exercise = TRUE}

```

```{r aperiod-hint}
# By default is_connected() will check whether a directed network
# is strongly connected.
```

```{r aperiod-solution}
is_connected(ison_networkers)
is_aperiodic(ison_networkers)
```

```{r aperiod-interp, echo = FALSE}
question("Based on these results, would you expect this network to converge to a consensus?",
  answer("No"),
  answer("Yes", correct = TRUE),
  random_answer_order = TRUE,
  allow_retry = TRUE
)
```

### Playing the DeGroot learning model

Now let's see whether you are right.
We want to see whether some random distribution of beliefs converges
to a consensus in this network (`ison_networkers`).
Let's play the DeGroot learning game on this network
with a vector of random belief probabilities 
(the same length as the nodes in the network)
drawn from the binomial distribution with **probability 0.25**.
Create the distribution of **beliefs** and graph the network
to show where they have been distributed.
Then play the learning model with these beliefs, and plot the result.

```{r degroot, exercise = TRUE}

```

```{r degroot-hint}
beliefs <- rbinom(network_nodes(____), 1, prob = 0.25)
____ %>% mutate(____ = beliefs) %>% autographr(node_color = "____")
netlearn <- play_learning(____, ____)
plot(____)
```

```{r degroot-solution}
beliefs <- rbinom(network_nodes(ison_networkers), 1, prob = 0.25)
ison_networkers %>% mutate(beliefs = beliefs) %>% autographr(node_color = "beliefs")
netlearn <- play_learning(ison_networkers, beliefs)
plot(netlearn)
```

Each line in this plot represents the belief trajectory of a single node
at each step.
About a quarter of the nodes begin believing, 
and the other three quarters do not.
Then we can see how responsive these nodes are to the random distribution
of beliefs across the network.
Some revise their beliefs more significantly than others.

```{r degroot-interp, echo = FALSE}
question("What are some true statements about these results?",
  answer("Some nodes revise their beliefs more than others.",
         correct = TRUE),
  answer("There seems to be a consensus.",
         correct = TRUE),
  answer("It takes more than two steps to reach consensus.",
         correct = TRUE),
  answer("One node never updates their belief beyond their initial belief.",
         message = "All nodes in this network eventually update their beliefs."),
  answer("I would get the same shared belief if I reran the code.",
         message = "If you reran the code, a different random belief vector would be created and more or less influential nodes might believe or not."),
  random_answer_order = TRUE,
  allow_retry = TRUE
)
```
