From 7179d50359a6708c21b8219dd1722b497c853adf Mon Sep 17 00:00:00 2001 From: Jael Tan Date: Tue, 7 Nov 2023 10:54:21 +0100 Subject: [PATCH 1/7] Added some plots to tutorial 7 --- inst/tutorials/tutorial7/diffusion.Rmd | 96 +++++++- inst/tutorials/tutorial7/diffusion.html | 306 +++++++++++++++++------- 2 files changed, 304 insertions(+), 98 deletions(-) diff --git a/inst/tutorials/tutorial7/diffusion.Rmd b/inst/tutorials/tutorial7/diffusion.Rmd index 272d3dc5..544f969e 100644 --- a/inst/tutorials/tutorial7/diffusion.Rmd +++ b/inst/tutorials/tutorial7/diffusion.Rmd @@ -51,7 +51,7 @@ nw <- to_undirected(to_unnamed(ison_networkers)) 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_ring()`: Creates a ring or chord graph of the given dimensions that loops around and is of a specified 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. @@ -157,8 +157,29 @@ ____(____) ``` ```{r ring-solution} -rg1 <- play_diffusion(rg, seeds = 1) -plot(rg1) +rg_d <- play_diffusion(rg, seeds = 1) +plot(rg_d) + +# visualise the diffusion in the network within first 5 steps of infection +rg <- rg %>% + add_node_attribute("Infected", rep("0", network_nodes(rg))) # original graph +rg1 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d$I[1]), + rep("0", rg_d$S[1]))) # t = 0 +rg2 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d$I[2]), + rep("0", rg_d$S[2]))) # t = 1 +rg3 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d$I[3]), + rep("0", rg_d$S[3]))) # t = 2 +rg4 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d$I[4]), + rep("0", rg_d$S[4]))) # t = 3 +rg5 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d$I[5]), + rep("0", rg_d$S[5]))) # t = 4 +rg_set <- list(rg, rg1, rg2, rg3, rg4, rg5) +autographs(rg_set, node_color = "Infected") ``` The result object, when printed, lists how many of the nodes in the network, @@ -185,8 +206,8 @@ and see whether the result is any different. ``` ```{r ring2-solution} -rg2 <- play_diffusion(rg, seeds = 16) -plot(rg2) +rg_d2 <- play_diffusion(rg, seeds = 16) +plot(rg_d2) ``` ```{r ring2-interp, echo = FALSE, purl = FALSE} @@ -211,7 +232,29 @@ plot(play_diffusion(rg, seeds = ____)) ``` ```{r ring3-solution} -plot(play_diffusion(rg, seeds = 1:4)) +rg_d3 <- play_diffusion(rg, seeds = 1:4) +plot(rg_d3) + +# visualise the diffusion in the network within first 5 steps of infection +rg <- rg %>% + add_node_attribute("Infected", rep("0", network_nodes(rg))) # original graph +rg1 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d3$I[1]), + rep("0", rg_d3$S[1]))) # t = 0 +rg2 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d3$I[2]), + rep("0", rg_d3$S[2]))) # t = 1 +rg3 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d3$I[3]), + rep("0", rg_d3$S[3]))) # t = 2 +rg4 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d3$I[4]), + rep("0", rg_d3$S[4]))) # t = 3 +rg5 <- rg %>% + add_node_attribute("Infected", c(rep("1", rg_d3$I[5]), + rep("0", rg_d3$S[5]))) # t = 4 +rg_set <- list(rg, rg1, rg2, rg3, rg4, rg5) +autographs(rg_set, node_color = "Infected") ``` But what if we seed the network at three different places? @@ -258,6 +301,9 @@ one with the first node as seed and again one on the last. ```{r lattice-solution} plot(play_diffusion(la, seeds = 1))/ plot(play_diffusion(la, seeds = 16)) +la %>% + add_node_attribute("color", c(1, rep(0, 14), 2, rep(0, 16))) %>% + autographr(node_color = "color") ``` ```{r lattice-interp, echo = FALSE, purl = FALSE} @@ -282,6 +328,12 @@ Similar to the previous examples, we will be using the following functions withi ``` ```{r scale-solution} +sf %>% + as_tidygraph() %>% + activate(nodes) %>% + mutate(degree = ifelse(node_is_max(node_degree(sf)), "max", + ifelse(node_is_min(node_degree(sf)), "min", "others"))) %>% + autographr(node_color = "degree") + guides(color = "legend") + labs(color = "degree") 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)) / @@ -401,6 +453,28 @@ 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)))) + +# visualise the diffusion in the network from steps 1 to 5 +sf_d <- play_diffusion(sf, thresholds = c(rep(0.1,10), rep(0.25,22))) +sf <- sf %>% + add_node_attribute("Infected", rep("0", network_nodes(sf))) # before diffusion +sf1 <- sf %>% + add_node_attribute("Infected", c(rep("1", sf_d$I[1]), + rep("0", sf_d$S[1]))) # t = 0 +sf2 <- sf %>% + add_node_attribute("Infected", c(rep("1", sf_d$I[2]), + rep("0", sf_d$S[2]))) # t = 1 +sf3 <- sf %>% + add_node_attribute("Infected", c(rep("1", sf_d$I[3]), + rep("0", sf_d$S[3]))) # t = 2 +sf4 <- sf %>% + add_node_attribute("Infected", c(rep("1", sf_d$I[4]), + rep("0", sf_d$S[4]))) # t = 3 +sf5 <- sf %>% + add_node_attribute("Infected", c(rep("1", sf_d$I[5]), + rep("0", sf_d$S[5]))) # t = 4 +sf_set <- list(sf, sf1, sf2, sf3, sf4, sf5) +autographs(sf_set, node_color = "Infected") ``` Since the first ten nodes are the first to join the scale-free network @@ -498,6 +572,7 @@ Play a single diffusion so that you can see what's going on in a particular run. ```{r sirs-solution} plot(play_diffusion(rd, recovery = 0.25, waning = 0.05)) +plot(play_diffusions(rd, recovery = 0.25, waning = 0.05)) ``` ```{r sirs-interp, echo = FALSE, purl = FALSE} @@ -513,7 +588,8 @@ 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). +(0 indicates an exposed individual is immediately infected, +and 0.25 is 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", purl = FALSE} @@ -521,7 +597,9 @@ Play a single diffusion so that you can see what's going on in a particular run. ``` ```{r seir-solution} -plot(play_diffusion(rd, latency = 0.25, recovery = 0.25)) +plot(play_diffusion(rd, latency = 0.5)) / +plot(play_diffusion(rd, latency = 0.25)) / +plot(play_diffusion(rd, latency = 0.1)) ``` ## Investigate learning through simulation @@ -537,7 +615,7 @@ 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. ++ `is_aperiodic()`: Tests whether network is aperiodic, meaning there is no integer k > 1 that divides the length of every cycle of the graph. ```{r aperiod, exercise = TRUE, purl = FALSE} diff --git a/inst/tutorials/tutorial7/diffusion.html b/inst/tutorials/tutorial7/diffusion.html index e99049ea..fddd3db7 100644 --- a/inst/tutorials/tutorial7/diffusion.html +++ b/inst/tutorials/tutorial7/diffusion.html @@ -153,7 +153,7 @@

Creating and visualising different network structures

with the same number of nodes using functions like:

Playing the DeGroot learning model label = "ring", code = "", opts = list(label = "\"ring\"", exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), engine = "r")), code_check = NULL, error_check = NULL, check = NULL, - solution = structure(c("rg1 <- play_diffusion(rg, seeds = 1)", - "plot(rg1)"), chunk_opts = list(label = "ring-solution")), - tests = NULL, options = list(eval = FALSE, echo = TRUE, results = "markup", + solution = structure(c("rg_d <- play_diffusion(rg, seeds = 1)", + "plot(rg_d)", "", "# visualise the diffusion in the network within first 5 steps of infection", + "rg <- rg %>%", " add_node_attribute(\"Infected\", rep(\"0\", network_nodes(rg))) # original graph", + "rg1 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d$I[1]),", + " rep(\"0\", rg_d$S[1]))) # t = 0", + "rg2 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d$I[2]),", + " rep(\"0\", rg_d$S[2]))) # t = 1", + "rg3 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d$I[3]),", + " rep(\"0\", rg_d$S[3]))) # t = 2", + "rg4 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d$I[4]),", + " rep(\"0\", rg_d$S[4]))) # t = 3", + "rg5 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d$I[5]),", + " rep(\"0\", rg_d$S[5]))) # t = 4", + "rg_set <- list(rg, rg1, rg2, rg3, rg4, rg5)", "autographs(rg_set, node_color = \"Infected\")" + ), chunk_opts = list(label = "ring-solution")), tests = NULL, + options = list(eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, comment = NA, highlight = FALSE, size = "normalsize", background = "#F7F7F7", strip.white = TRUE, cache = 0, @@ -943,8 +1035,8 @@

Playing the DeGroot learning model

label = "ring2", code = "", opts = list(label = "\"ring2\"", exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), engine = "r")), code_check = NULL, error_check = NULL, check = NULL, - solution = structure(c("rg2 <- play_diffusion(rg, seeds = 16)", - "plot(rg2)"), chunk_opts = list(label = "ring2-solution")), + solution = structure(c("rg_d2 <- play_diffusion(rg, seeds = 16)", + "plot(rg_d2)"), chunk_opts = list(label = "ring2-solution")), tests = NULL, options = list(eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, comment = NA, highlight = FALSE, size = "normalsize", @@ -971,10 +1063,10 @@

Playing the DeGroot learning model

@@ -1007,15 +1099,29 @@

Playing the DeGroot learning model

label = "ring3", code = "", opts = list(label = "\"ring3\"", exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), engine = "r")), code_check = NULL, error_check = NULL, check = NULL, - solution = structure("plot(play_diffusion(rg, seeds = 1:4))", chunk_opts = list( - label = "ring3-solution")), tests = NULL, options = list( - eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, - tidy.opts = NULL, collapse = FALSE, prompt = FALSE, comment = NA, - highlight = FALSE, size = "normalsize", background = "#F7F7F7", - strip.white = TRUE, cache = 0, cache.path = "diffusion_cache/html/", - cache.vars = NULL, cache.lazy = TRUE, dependson = NULL, - autodep = FALSE, cache.rebuild = FALSE, fig.keep = "high", - fig.show = "asis", fig.align = "default", fig.path = "diffusion_files/figure-html/", + solution = structure(c("rg_d3 <- play_diffusion(rg, seeds = 1:4)", + "plot(rg_d3)", "", "# visualise the diffusion in the network within first 5 steps of infection", + "rg <- rg %>%", " add_node_attribute(\"Infected\", rep(\"0\", network_nodes(rg))) # original graph", + "rg1 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d3$I[1]),", + " rep(\"0\", rg_d3$S[1]))) # t = 0", + "rg2 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d3$I[2]),", + " rep(\"0\", rg_d3$S[2]))) # t = 1", + "rg3 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d3$I[3]),", + " rep(\"0\", rg_d3$S[3]))) # t = 2", + "rg4 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d3$I[4]),", + " rep(\"0\", rg_d3$S[4]))) # t = 3", + "rg5 <- rg %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", rg_d3$I[5]),", + " rep(\"0\", rg_d3$S[5]))) # t = 4", + "rg_set <- list(rg, rg1, rg2, rg3, rg4, rg5)", "autographs(rg_set, node_color = \"Infected\")" + ), chunk_opts = list(label = "ring3-solution")), tests = NULL, + options = list(eval = FALSE, echo = TRUE, results = "markup", + tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, + comment = NA, highlight = FALSE, size = "normalsize", + background = "#F7F7F7", strip.white = TRUE, cache = 0, + cache.path = "diffusion_cache/html/", cache.vars = NULL, + cache.lazy = TRUE, dependson = NULL, autodep = FALSE, + cache.rebuild = FALSE, fig.keep = "high", fig.show = "asis", + fig.align = "default", fig.path = "diffusion_files/figure-html/", dev = "png", dev.args = NULL, dpi = 192, fig.ext = "png", fig.width = 6.5, fig.height = 4, fig.env = "figure", fig.cap = NULL, fig.scap = NULL, fig.lp = "fig:", fig.subcap = NULL, @@ -1077,10 +1183,10 @@

Playing the DeGroot learning model

@@ -1114,7 +1220,8 @@

Playing the DeGroot learning model

exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), engine = "r")), code_check = NULL, error_check = NULL, check = NULL, solution = structure(c("plot(play_diffusion(la, seeds = 1))/", - "plot(play_diffusion(la, seeds = 16))"), chunk_opts = list( + "plot(play_diffusion(la, seeds = 16))", "la %>%", " add_node_attribute(\"color\", c(1, rep(0, 14), 2, rep(0, 16))) %>%", + " autographr(node_color = \"color\")"), chunk_opts = list( label = "lattice-solution")), tests = NULL, options = list( eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, comment = NA, @@ -1142,10 +1249,10 @@

Playing the DeGroot learning model

@@ -1178,8 +1285,11 @@

Playing the DeGroot learning model

label = "scale", code = "", opts = list(label = "\"scale\"", exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), engine = "r")), code_check = NULL, error_check = NULL, check = NULL, - solution = structure(c("plot(play_diffusion(sf, seeds = 10, steps = 10)) / ", - "plot(play_diffusion(sf, seeds = node_is_random(sf), steps = 10)) /", + solution = structure(c("sf %>%", " as_tidygraph() %>%", + " activate(nodes) %>%", " mutate(degree = ifelse(node_is_max(node_degree(sf)), \"max\",", + " ifelse(node_is_min(node_degree(sf)), \"min\", \"others\"))) %>%", + " autographr(node_color = \"degree\") + guides(color = \"legend\") + labs(color = \"degree\")", + "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))" ), chunk_opts = list(label = "scale-solution")), tests = NULL, @@ -1210,22 +1320,22 @@

Playing the DeGroot learning model

@@ -1291,19 +1401,19 @@

Playing the DeGroot learning model

@@ -1366,10 +1476,10 @@

Playing the DeGroot learning model

@@ -1433,10 +1543,10 @@

Playing the DeGroot learning model

@@ -1470,7 +1580,21 @@

Playing the DeGroot learning model

exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), engine = "r")), code_check = NULL, error_check = NULL, check = NULL, solution = structure(c("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))))" + "plot(play_diffusion(sf, thresholds = c(rep(0.25,10), rep(0.1,22))))", + "", "# visualise the diffusion in the network from steps 1 to 5", + "sf_d <- play_diffusion(sf, thresholds = c(rep(0.1,10), rep(0.25,22)))", + "sf <- sf %>%", " add_node_attribute(\"Infected\", rep(\"0\", network_nodes(sf))) # before diffusion", + "sf1 <- sf %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", sf_d$I[1]),", + " rep(\"0\", sf_d$S[1]))) # t = 0", + "sf2 <- sf %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", sf_d$I[2]),", + " rep(\"0\", sf_d$S[2]))) # t = 1", + "sf3 <- sf %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", sf_d$I[3]),", + " rep(\"0\", sf_d$S[3]))) # t = 2", + "sf4 <- sf %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", sf_d$I[4]),", + " rep(\"0\", sf_d$S[4]))) # t = 3", + "sf5 <- sf %>%", " add_node_attribute(\"Infected\", c(rep(\"1\", sf_d$I[5]),", + " rep(\"0\", sf_d$S[5]))) # t = 4", + "sf_set <- list(sf, sf1, sf2, sf3, sf4, sf5)", "autographs(sf_set, node_color = \"Infected\")" ), chunk_opts = list(label = "rand-solution")), tests = NULL, options = list(eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, @@ -1592,15 +1716,17 @@

Playing the DeGroot learning model

include = FALSE)), setup = NULL, chunks = list(list(label = "sirs", code = "", opts = list(label = "\"sirs\"", exercise = "TRUE", purl = "FALSE"), engine = "r")), code_check = NULL, error_check = NULL, - check = NULL, solution = structure("plot(play_diffusion(rd, recovery = 0.25, waning = 0.05))", chunk_opts = list( - label = "sirs-solution")), tests = NULL, options = list( - eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, - tidy.opts = NULL, collapse = FALSE, prompt = FALSE, comment = NA, - highlight = FALSE, size = "normalsize", background = "#F7F7F7", - strip.white = TRUE, cache = 0, cache.path = "diffusion_cache/html/", - cache.vars = NULL, cache.lazy = TRUE, dependson = NULL, - autodep = FALSE, cache.rebuild = FALSE, fig.keep = "high", - fig.show = "asis", fig.align = "default", fig.path = "diffusion_files/figure-html/", + check = NULL, solution = structure(c("plot(play_diffusion(rd, recovery = 0.25, waning = 0.05))", + "plot(play_diffusions(rd, recovery = 0.25, waning = 0.05))" + ), chunk_opts = list(label = "sirs-solution")), tests = NULL, + options = list(eval = FALSE, echo = TRUE, results = "markup", + tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, + comment = NA, highlight = FALSE, size = "normalsize", + background = "#F7F7F7", strip.white = TRUE, cache = 0, + cache.path = "diffusion_cache/html/", cache.vars = NULL, + cache.lazy = TRUE, dependson = NULL, autodep = FALSE, + cache.rebuild = FALSE, fig.keep = "high", fig.show = "asis", + fig.align = "default", fig.path = "diffusion_files/figure-html/", dev = "png", dev.args = NULL, dpi = 192, fig.ext = "png", fig.width = 6.5, fig.height = 4, fig.env = "figure", fig.cap = NULL, fig.scap = NULL, fig.lp = "fig:", fig.subcap = NULL, @@ -1620,10 +1746,10 @@

Playing the DeGroot learning model

@@ -1656,15 +1782,17 @@

Playing the DeGroot learning model

label = "seir", code = "", opts = list(label = "\"seir\"", exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), engine = "r")), code_check = NULL, error_check = NULL, check = NULL, - solution = structure("plot(play_diffusion(rd, latency = 0.25, recovery = 0.25))", chunk_opts = list( - label = "seir-solution")), tests = NULL, options = list( - eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, - tidy.opts = NULL, collapse = FALSE, prompt = FALSE, comment = NA, - highlight = FALSE, size = "normalsize", background = "#F7F7F7", - strip.white = TRUE, cache = 0, cache.path = "diffusion_cache/html/", - cache.vars = NULL, cache.lazy = TRUE, dependson = NULL, - autodep = FALSE, cache.rebuild = FALSE, fig.keep = "high", - fig.show = "asis", fig.align = "default", fig.path = "diffusion_files/figure-html/", + solution = structure(c("plot(play_diffusion(rd, latency = 0.5)) /", + "plot(play_diffusion(rd, latency = 0.25)) /", "plot(play_diffusion(rd, latency = 0.1))" + ), chunk_opts = list(label = "seir-solution")), tests = NULL, + options = list(eval = FALSE, echo = TRUE, results = "markup", + tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, + comment = NA, highlight = FALSE, size = "normalsize", + background = "#F7F7F7", strip.white = TRUE, cache = 0, + cache.path = "diffusion_cache/html/", cache.vars = NULL, + cache.lazy = TRUE, dependson = NULL, autodep = FALSE, + cache.rebuild = FALSE, fig.keep = "high", fig.show = "asis", + fig.align = "default", fig.path = "diffusion_files/figure-html/", dev = "png", dev.args = NULL, dpi = 192, fig.ext = "png", fig.width = 6.5, fig.height = 4, fig.env = "figure", fig.cap = NULL, fig.scap = NULL, fig.lp = "fig:", fig.subcap = NULL, @@ -1723,10 +1851,10 @@

Playing the DeGroot learning model

@@ -1787,27 +1915,27 @@

Playing the DeGroot learning model

@@ -1832,7 +1960,7 @@

Playing the DeGroot learning model

From 6413cd5594530705375f417a1c3ab9c8abd28008 Mon Sep 17 00:00:00 2001 From: hollway Date: Tue, 7 Nov 2023 23:23:59 +0100 Subject: [PATCH 2/7] Fixed SIR plot labelling --- R/class_models.R | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/R/class_models.R b/R/class_models.R index f692ba0f..764402b1 100644 --- a/R/class_models.R +++ b/R/class_models.R @@ -220,20 +220,27 @@ plot.diff_model <- function(x, ...){ S <- E <- I <- I_new <- R <- NULL # initialize variables to avoid CMD check notes data <- x p <- ggplot2::ggplot(data) + - ggplot2::geom_line(ggplot2::aes(x = t, y = S/n, color = "A"),size = 1.25) + - ggplot2::geom_line(ggplot2::aes(x = t, y = I/n, color = "C"),size = 1.25) + + ggplot2::geom_line(ggplot2::aes(x = t, y = S/n, color = "A"), linewidth = 1.25) + + ggplot2::geom_line(ggplot2::aes(x = t, y = I/n, color = "C"), linewidth = 1.25) + ggplot2::geom_col(ggplot2::aes(x = t, y = I_new/n), alpha = 0.4) + - ggplot2::theme_minimal() + ggplot2::ylim(0,1) + + ggplot2::theme_minimal() + + ggplot2::coord_cartesian(ylim = c(0,1)) + # using coord_cartesion to avoid printing warnings ggplot2::ylab("Proportion") + ggplot2::xlab("Steps") - if(any(data$E>0)) + labs <- c("Susceptible", "Infected") + if(any(data$E>0)){ p <- p + - ggplot2::geom_line(ggplot2::aes(x = t, y = E/n, color = "B"),size = 1.25) - if(any(data$R>0)) + ggplot2::geom_line(ggplot2::aes(x = t, y = E/n, color = "B"),size = 1.25) + labs <- c("Susceptible", "Exposed", "Infected") + } + if(any(data$R>0)){ p <- p + - ggplot2::geom_line(ggplot2::aes(x = t, y = R/n, color = "D"),size = 1.25) + ggplot2::geom_line(ggplot2::aes(x = t, y = R/n, color = "D"),size = 1.25) + labs <- c(labs, "Recovered") + } + p + ggplot2::scale_color_manual("Legend", - labels = c("Susceptible", "Exposed", "Infected", "Recovered"), + labels = labs, values = c(A = "blue", B = "orange", C = "red", D = "darkgreen"), guide = "legend") @@ -252,18 +259,25 @@ plot.diffs_model <- function(x, ...){ method = "loess", se=TRUE, level = .95, formula = 'y~x') + ggplot2::geom_smooth(ggplot2::aes(x = t, y = I/n, color = "C"), method = "loess", se=TRUE, level = .95, formula = 'y~x') + - ggplot2::theme_minimal() + ggplot2::ylim(0,1) + + ggplot2::theme_minimal() + + ggplot2::coord_cartesian(ylim = c(0,1)) + # using coord_cartesion to avoid printing warnings ggplot2::ylab("Proportion") + ggplot2::xlab("Steps") - if(any(data$E>0)) + labs <- c("Susceptible", "Infected") + if(any(data$E>0)){ p <- p + - ggplot2::geom_smooth(ggplot2::aes(x = t, y = E/n, color = "B"), - method = "loess", se=TRUE, level = .95, formula = 'y~x') - if(any(data$R>0)) + ggplot2::geom_smooth(ggplot2::aes(x = t, y = E/n, color = "B"), + method = "loess", se=TRUE, level = .95, formula = 'y~x') + labs <- c("Susceptible", "Exposed", "Infected") + } + if(any(data$R>0)){ p <- p + - ggplot2::geom_smooth(ggplot2::aes(x = t, y = R/n, color = "D"), - method = "loess", se=TRUE, level = .95, formula = 'y~x') + ggplot2::geom_smooth(ggplot2::aes(x = t, y = R/n, color = "D"), + method = "loess", se=TRUE, level = .95, formula = 'y~x') + labs <- c(labs, "Recovered") + } + p + ggplot2::scale_color_manual("Legend", - labels = c("Susceptible", "Exposed", "Infected", "Recovered"), + labels = labs, values = c(A = "blue", B = "orange", C = "red", D = "darkgreen"), guide = "legend") From 4b5c580cceb8dcdc827b3f87c5da086325f1ab02 Mon Sep 17 00:00:00 2001 From: hollway Date: Tue, 7 Nov 2023 23:24:50 +0100 Subject: [PATCH 3/7] Fixed play_diffusion documentation --- R/model_play.R | 32 ++++++++++++++++---------------- man/play.Rd | 14 +++++++------- 2 files changed, 23 insertions(+), 23 deletions(-) diff --git a/R/model_play.R b/R/model_play.R index 1fe54215..3a653539 100644 --- a/R/model_play.R +++ b/R/model_play.R @@ -11,26 +11,26 @@ #' of the number of contacts/exposures sufficient for infection. #' If less than 1, the threshold is interpreted as complex, #' where the threshold concerns the proportion of contacts. -#' @param transmissibility A proportion indicating the transmission rate, +#' @param transmissibility The transmission rate probability, #' \eqn{\beta}. #' By default 1, which means any node for which the threshold is met #' or exceeded will become infected. #' Anything lower means a correspondingly lower probability of adoption, #' even when the threshold is met or exceeded. -#' @param recovery A proportion indicating the rate of recovery, -#' \eqn{\gamma}. +#' @param recovery The probability those who are infected +#' recover, \eqn{\gamma}. #' For example, if infected individuals take, on average, #' four days to recover, then \eqn{\gamma = 0.25}. #' By default 0, which means there is no recovery (i.e. an SI model). #' Anything higher results in an SIR model. -#' @param latency A proportion indicating the rate at which those exposed +#' @param latency The inverse probability those who have been exposed #' become infectious (infected), \eqn{\sigma}. #' For example, if exposed individuals take, on average, -#' four days to become infectious, then \eqn{\sigma = 0.25}. +#' four days to become infectious, then \eqn{\sigma = 0.75} (1/1-0.75 = 1/0.25 = 4). #' By default 0, which means those exposed become immediately infectious (i.e. an SI model). #' Anything higher results in e.g. a SEI model. -#' @param waning A proportion indicating the rate at which those who are -#' recovered become susceptible again, \eqn{\xi}. +#' @param waning The probability those who are recovered +#' become susceptible again, \eqn{\xi}. #' For example, if recovered individuals take, on average, #' four days to lose their immunity, then \eqn{\xi = 0.25}. #' By default 0, which means any recovered individuals retain lifelong immunity (i.e. an SIR model). @@ -107,14 +107,14 @@ play_diffusion <- function(.data, # count exposures for each node: tabcontact <- table(contacts) # identify those nodes who are exposed at or above their threshold - new <- as.numeric(names(which(tabcontact >= thresholds[as.numeric(names(tabcontact))]))) - new <- new[stats::rbinom(length(new), 1, transmissibility)==1] + newinf <- as.numeric(names(which(tabcontact >= thresholds[as.numeric(names(tabcontact))]))) + newinf <- newinf[stats::rbinom(length(newinf), 1, transmissibility)==1] if(!is.null(recovery) & length(recovered)>0) - new <- setdiff(new, recovered) # recovered can't be reinfected + newinf <- setdiff(newinf, recovered) # recovered can't be reinfected if(!is.null(exposed) & length(exposed)>0) - new <- setdiff(new, exposed) # exposed already infected - if(is.infinite(steps) & length(new)==0 & length(exposed)==0) break # if no new infections we can stop - exposed <- c(exposed, new) + newinf <- setdiff(newinf, exposed) # exposed already infected + if(is.infinite(steps) & length(newinf)==0 & length(exposed)==0) break # if no new infections we can stop + exposed <- c(exposed, newinf) # new list of infected infectious <- exposed[stats::rbinom(length(exposed), 1, latency)==0] @@ -123,9 +123,9 @@ play_diffusion <- function(.data, # tick time t <- t+1 # record new infections - if(!is.null(new) & length(new)>0) + if(!is.null(newinf) & length(newinf)>0) events <- rbind(events, - data.frame(t = t, nodes = new, event = "I")) + data.frame(t = t, nodes = newinf, event = "I")) # record recoveries if(!is.null(exposed) & length(exposed)>0) events <- rbind(events, @@ -143,7 +143,7 @@ play_diffusion <- function(.data, n = n, S = n - (length(exposed) + length(infected) + length(recovered)), E = length(exposed), - I_new = length(new), + I_new = length(newinf), I = length(infected), R = length(recovered))) if(is.infinite(steps) & length(infected)==n) break diff --git a/man/play.Rd b/man/play.Rd index b01acda5..20462356 100644 --- a/man/play.Rd +++ b/man/play.Rd @@ -69,29 +69,29 @@ of the number of contacts/exposures sufficient for infection. If less than 1, the threshold is interpreted as complex, where the threshold concerns the proportion of contacts.} -\item{transmissibility}{A proportion indicating the transmission rate, +\item{transmissibility}{The transmission rate probability, \eqn{\beta}. By default 1, which means any node for which the threshold is met or exceeded will become infected. Anything lower means a correspondingly lower probability of adoption, even when the threshold is met or exceeded.} -\item{latency}{A proportion indicating the rate at which those exposed +\item{latency}{The inverse probability those who have been exposed become infectious (infected), \eqn{\sigma}. For example, if exposed individuals take, on average, -four days to become infectious, then \eqn{\sigma = 0.25}. +four days to become infectious, then \eqn{\sigma = 0.75} (1/1-0.75 = 1/0.25 = 4). By default 0, which means those exposed become immediately infectious (i.e. an SI model). Anything higher results in e.g. a SEI model.} -\item{recovery}{A proportion indicating the rate of recovery, -\eqn{\gamma}. +\item{recovery}{The probability those who are infected +recover, \eqn{\gamma}. For example, if infected individuals take, on average, four days to recover, then \eqn{\gamma = 0.25}. By default 0, which means there is no recovery (i.e. an SI model). Anything higher results in an SIR model.} -\item{waning}{A proportion indicating the rate at which those who are -recovered become susceptible again, \eqn{\xi}. +\item{waning}{The probability those who are recovered +become susceptible again, \eqn{\xi}. For example, if recovered individuals take, on average, four days to lose their immunity, then \eqn{\xi = 0.25}. By default 0, which means any recovered individuals retain lifelong immunity (i.e. an SIR model). From ba7dd8d9bfbf5ec139e1ba19a7e9db357bc16c29 Mon Sep 17 00:00:00 2001 From: hollway Date: Tue, 7 Nov 2023 23:25:30 +0100 Subject: [PATCH 4/7] Elaborated diffusion tutorial more --- inst/tutorials/tutorial7/diffusion.Rmd | 101 ++- inst/tutorials/tutorial7/diffusion.html | 864 +++++++++++++++--------- 2 files changed, 615 insertions(+), 350 deletions(-) diff --git a/inst/tutorials/tutorial7/diffusion.Rmd b/inst/tutorials/tutorial7/diffusion.Rmd index 544f969e..55d0095f 100644 --- a/inst/tutorials/tutorial7/diffusion.Rmd +++ b/inst/tutorials/tutorial7/diffusion.Rmd @@ -13,6 +13,12 @@ library(manynet) library(migraph) library(patchwork) knitr::opts_chunk$set(echo = FALSE) +nw <- to_undirected(to_unnamed(manynet::ison_networkers)) +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) ``` ## Investigate diffusion through simulation @@ -186,7 +192,7 @@ 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. +time point, or the so-called 'force of infection' ($F = \beta I$). We can see that there is a pretty constant diffusion across this network, with 2-3 nodes being newly infected at each time-point. @@ -503,7 +509,7 @@ 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`, +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 @@ -524,8 +530,10 @@ plot(play_diffusions(____, transmissibility = ____, times = ____, steps = ____)) 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. +Note that in this plot the number of new infections is not plotted +because this might vary a bit each time the simulation is run. +Instead, the loess line smooths over the varying trajectories +and a (hardly distinguishable for this call) grey border to the line represents the standard error. 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. @@ -558,12 +566,25 @@ 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. +If you get moderately different results each time, +try increasing the number of `times` the simulation is run, +which should average out these differences and make the results more reliable. + +```{r sirtimes, exercise = TRUE, purl = FALSE} + +``` + +```{r sirtimes-solution} +plot(play_diffusions(rd, recovery = 0.2, times = 100)) +``` ### 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. +In this kind of model, add an additional `waning` parameter of 0.05. +This means that after twenty steps (on average), +a recovered node may lose its recovered status and become susceptible again. Play a single diffusion so that you can see what's going on in a particular run. ```{r sirs, exercise = TRUE, purl = FALSE} @@ -571,8 +592,7 @@ Play a single diffusion so that you can see what's going on in a particular run. ``` ```{r sirs-solution} -plot(play_diffusion(rd, recovery = 0.25, waning = 0.05)) -plot(play_diffusions(rd, recovery = 0.25, waning = 0.05)) +plot(play_diffusion(rd, recovery = 0.2, waning = 0.05)) ``` ```{r sirs-interp, echo = FALSE, purl = FALSE} @@ -582,14 +602,32 @@ question("Does the process reach a stable state?", allow_retry = TRUE) ``` +Depending on your particular simulation, +there might be some variation, +so let's run this same diffusion but multiple (100?) times. + +```{r sirstimes-solution, exercise = TRUE} +plot(play_diffusions(rd, recovery = 0.2, waning = 0.05, times = 100)) +``` + +```{r sirstimes-interp, echo = FALSE, purl = FALSE} +question("Select the true statements", + answer("There are always some infected nodes.", correct = TRUE), + answer("We never get to the stage where everyone has recovered.", correct = TRUE), + answer("There are always some susceptible nodes.", correct = TRUE), + random_answer_order = TRUE, + 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 -(0 indicates an exposed individual is immediately infected, -and 0.25 is approx four days). +This kind of an incubation period is due to some `latency` ($\sigma$). +This should also be specified as a proportion, +but note that this is inverted internally. +This means that a latency of 0 means that exposure immediately renders the node infectious. +A latency of 0.75 means that it will take the node approximately 4 days (1/1-0.75 = 1/0.25 = 4) to become infectious. Play a single diffusion so that you can see what's going on in a particular run. ```{r seir, exercise = TRUE, exercise.setup = "create", purl = FALSE} @@ -597,9 +635,29 @@ Play a single diffusion so that you can see what's going on in a particular run. ``` ```{r seir-solution} -plot(play_diffusion(rd, latency = 0.5)) / -plot(play_diffusion(rd, latency = 0.25)) / -plot(play_diffusion(rd, latency = 0.1)) +plot(play_diffusion(rd, latency = 0.25, recovery = 0.2)) +``` + +### R-nought + +So how can we establish the $R_0$ here? +Well, recall that $R_0 = \frac{\beta}{\gamma}$. +For a network such as ours, the expected number of contacts per node $\beta$ +is the average degree of all nodes, +and the average number of days a node remains contagious is 1 divided by the `recovery` parameter. + +```{r r0, exercise = TRUE, exercise.setup = "create"} +recovery <- 0.2 +mean(node_degree(rd, normalized = FALSE))/(1/recovery) +``` + +```{r r0-interp, echo = FALSE, purl = FALSE} +question("Select any true statements you can make about this R-nought result:", + answer("There will probably be an epidemic.", correct = TRUE), + answer("There are not enough seed nodes to start an epidemic."), + answer("If the recovery rate was instead a mortality rate, it would make no difference.", correct = TRUE), + allow_retry = TRUE, + random_answer_order = TRUE) ``` ## Investigate learning through simulation @@ -631,10 +689,21 @@ is_connected(ison_networkers) is_aperiodic(ison_networkers) ``` -```{r aperiod-interp, echo = FALSE, purl = FALSE} +```{r consens-interp, echo = FALSE, purl = FALSE} question("Based on these results, would you expect this network to converge to a consensus?", answer("No"), - answer("Yes", correct = TRUE), + answer("Yes", correct = TRUE, message = "Only with a strongly connected, aperiodic network will there be convergence to a single consensus."), + random_answer_order = TRUE, + allow_retry = TRUE +) +``` + +```{r aperiod-interp, echo = FALSE, purl = FALSE} +question("If there were aperiodicity but two or more strongly connected components, what would happen?", + answer("There would be no convergence"), + answer("There would be convergence to a single consensus"), + answer("There would be convergence", correct = TRUE), + answer("There would probably be as many separate values as there are components", correct = TRUE), random_answer_order = TRUE, allow_retry = TRUE ) diff --git a/inst/tutorials/tutorial7/diffusion.html b/inst/tutorials/tutorial7/diffusion.html index fddd3db7..a5b44124 100644 --- a/inst/tutorials/tutorial7/diffusion.html +++ b/inst/tutorials/tutorial7/diffusion.html @@ -13,7 +13,7 @@ - + Diffusion @@ -120,13 +120,12 @@

Investigate diffusion through simulation

{manynet}, and create or generate ring, lattice, random, scale-free, and small-world versions with the same number of nodes.

+data-diagnostics="1" data-startover="1" data-lines="0">
+data-lines="0"> 
# 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
 
@@ -134,7 +133,7 @@ 
Investigate diffusion through simulation
+data-lines="0"> 
# 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.
 
@@ -142,7 +141,7 @@ 
Investigate diffusion through simulation
+data-lines="0"> 
nw <- to_undirected(to_unnamed(ison_networkers))
Creating and visualising different network structures with the same number of nodes using functions like:

  • create_ring(): Creates a ring or chord graph of the -given dimensions that loops around and is of a specified width or +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
    • @@ -166,13 +165,12 @@

    Creating and visualising different network structures

+data-lines="0">
+data-diagnostics="1" data-startover="1" data-lines="0"> 
# Let's generate a ring structure, "rg", with a width of 2, using the appropriate
 # function above
 
@@ -180,42 +178,36 @@ 
Creating and visualising different network structures
+data-diagnostics="1" data-startover="1" data-lines="0"> 
rg <- create_ring(nw, width = 2)
+data-diagnostics="1" data-startover="1" data-lines="0"> 
# Let's generate a lattice structure, "la", using the appropriate function above
 
 la <- ____(____)
+data-diagnostics="1" data-startover="1" data-lines="0"> 
la <- create_lattice(nw)
+data-diagnostics="1" data-startover="1" data-lines="0"> 
# Let's generate a random structure, "rd", without attributes
 
 rd <- ____(____, ____)
+data-diagnostics="1" data-startover="1" data-lines="0"> 
rd <- generate_random(nw, with_attr = FALSE)
+data-diagnostics="1" data-startover="1" data-lines="0"> 
# 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.
 
@@ -224,15 +216,13 @@ 
Creating and visualising different network structures
+data-diagnostics="1" data-startover="1" data-lines="0"> 
sf <- generate_scalefree(nw, 0.025)
 sw <- generate_smallworld(nw, 0.025)
+data-diagnostics="1" data-startover="1" data-lines="0"> 
# Finally, let's plot the respective graphs:
 
 autographr(____) + ggtitle("Networkers") +
@@ -244,8 +234,7 @@ 
Creating and visualising different network structures
+data-diagnostics="1" data-startover="1" data-lines="0"> 
# Here is the solution:
 
 rg <- create_ring(nw, width = 2)
@@ -270,13 +259,12 @@ 
Examining diffusion across networks of different structure

 across this network, simply pass it to play_diffusion() and
 (save and) plot the result.

 

+data-diagnostics="1" data-startover="1" data-lines="0">
 
 

 

+data-lines="0">
 
# 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!
 
@@ -285,37 +273,17 @@ 
Examining diffusion across networks of different structure

 

 

-
rg_d <- play_diffusion(rg, seeds = 1)
-plot(rg_d)
-
-# visualise the diffusion in the network within first 5 steps of infection
-rg <- rg %>%
-  add_node_attribute("Infected", rep("0", network_nodes(rg))) # original graph
-rg1 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d$I[1]),
-                                   rep("0", rg_d$S[1]))) # t = 0
-rg2 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d$I[2]),
-                                   rep("0", rg_d$S[2]))) # t = 1
-rg3 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d$I[3]),
-                                   rep("0", rg_d$S[3]))) # t = 2
-rg4 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d$I[4]),
-                                   rep("0", rg_d$S[4]))) # t = 3
-rg5 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d$I[5]),
-                                   rep("0", rg_d$S[5]))) # t = 4
-rg_set <- list(rg, rg1, rg2, rg3, rg4, rg5)
-autographs(rg_set, node_color = "Infected")

+data-lines="0">
+
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.

+time point, or the so-called ‘force of infection’ (\(F = \beta I\)).

 
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.

@@ -327,15 +295,14 @@ 
Varying seed nodes

 network. To see whether this is true, try choosing the sixteenth
 (middle) node and see whether the result is any different.

 

+data-diagnostics="1" data-startover="1" data-lines="0">
 
 

 

-
rg_d2 <- play_diffusion(rg, seeds = 16)
-plot(rg_d2)

+data-lines="0">
+
rg2 <- play_diffusion(rg, seeds = 16)
+plot(rg2)

 

 

 

@@ -349,55 +316,31 @@ 
Varying seed nodes

 Choosing the first four nodes we can see that the process is
 jump-started, but doesn’t really conclude that much faster.

 

+data-diagnostics="1" data-startover="1" data-lines="0">
 
 

 

+data-lines="0">
 
# Remember we want to see the first four nodes.
 
 plot(play_diffusion(rg, seeds = ____))

 

 

-
rg_d3 <- play_diffusion(rg, seeds = 1:4)
-plot(rg_d3)
-
-# visualise the diffusion in the network within first 5 steps of infection
-rg <- rg %>%
-  add_node_attribute("Infected", rep("0", network_nodes(rg))) # original graph
-rg1 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d3$I[1]),
-                                   rep("0", rg_d3$S[1]))) # t = 0
-rg2 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d3$I[2]),
-                                   rep("0", rg_d3$S[2]))) # t = 1
-rg3 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d3$I[3]),
-                                   rep("0", rg_d3$S[3]))) # t = 2
-rg4 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d3$I[4]),
-                                   rep("0", rg_d3$S[4]))) # t = 3
-rg5 <- rg %>%
-  add_node_attribute("Infected", c(rep("1", rg_d3$I[5]),
-                                   rep("0", rg_d3$S[5]))) # t = 4
-rg_set <- list(rg, rg1, rg2, rg3, rg4, rg5)
-autographs(rg_set, node_color = "Infected")

+data-lines="0">
+
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.

 

+data-diagnostics="1" data-startover="1" data-lines="0">
 
 

 

+data-lines="0">
 
# We will be using the node_is_random() within the seed argument to random select 
 # 4 nodes
 
@@ -405,7 +348,7 @@ 
Varying seed nodes

 

 

+data-lines="0">
 
plot(play_diffusion(rg, seeds = node_is_random(rg, 4)))

 

 

@@ -427,18 +370,14 @@ 
Varying networks

 diffusion on the lattice network, one with the first node as seed and
 again one on the last.

 

+data-diagnostics="1" data-startover="1" data-lines="0">
 
 

 

+data-lines="0">
 
plot(play_diffusion(la, seeds = 1))/
-plot(play_diffusion(la, seeds = 16))
-la %>%
-  add_node_attribute("color", c(1, rep(0, 14), 2, rep(0, 16))) %>%
-  autographr(node_color = "color")

+plot(play_diffusion(la, seeds = 16))
@@ -462,20 +401,13 @@

Varying networks

minimum of some measure.
+data-diagnostics="1" data-startover="1" data-lines="0">
-
sf %>%
-  as_tidygraph() %>%
-  activate(nodes) %>%
-  mutate(degree = ifelse(node_is_max(node_degree(sf)), "max",
-                      ifelse(node_is_min(node_degree(sf)), "min", "others"))) %>%
-  autographr(node_color = "degree") + guides(color = "legend") + labs(color = "degree")
-plot(play_diffusion(sf, seeds = 10, steps = 10)) / 
+data-lines="0">
+
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))

@@ -500,13 +432,12 @@ 
Varying thresholds

 will not lead to any diffusion process unless there are two seeds and
 that they are in another nodes neighbourhood.

 

+data-diagnostics="1" data-startover="1" data-lines="0">
 
 

 

+data-lines="0">
 
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))/
@@ -527,12 +458,12 @@ 
Varying thresholds

 scale-free network.

 

+data-lines="0">
 
 

 

+data-lines="0">
 
plot(play_diffusion(sf, seeds = 1, thresholds = 2))

 

 

@@ -549,20 +480,19 @@ 
Varying thresholds

 become infected. Try thresholds of 0.1, 0.25, and 0.5 on two seeds and
 10 steps.

 

+data-diagnostics="1" data-startover="1" data-lines="0">
 
 

 

+data-lines="0">
 
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 = ____))

 

 

+data-lines="0">
 
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))

@@ -584,43 +514,20 @@ 
Varying thresholds

 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.

 

+data-diagnostics="1" data-startover="1" data-lines="0">
 
 

 

+data-lines="0">
 
plot(play_diffusion(sf, thresholds = c(rep(____,____), rep(____,____))))/
 plot(play_diffusion(sf, thresholds = c(rep(____,____), rep(____,____))))

 

 

+data-lines="0">
 
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))))
-
-# visualise the diffusion in the network from steps 1 to 5
-sf_d <- play_diffusion(sf, thresholds = c(rep(0.1,10), rep(0.25,22)))
-sf <- sf %>%
-  add_node_attribute("Infected", rep("0", network_nodes(sf))) # before diffusion
-sf1 <- sf %>%
-  add_node_attribute("Infected", c(rep("1", sf_d$I[1]),
-                                   rep("0", sf_d$S[1]))) # t = 0
-sf2 <- sf %>%
-  add_node_attribute("Infected", c(rep("1", sf_d$I[2]),
-                                   rep("0", sf_d$S[2]))) # t = 1
-sf3 <- sf %>%
-  add_node_attribute("Infected", c(rep("1", sf_d$I[3]),
-                                   rep("0", sf_d$S[3]))) # t = 2
-sf4 <- sf %>%
-  add_node_attribute("Infected", c(rep("1", sf_d$I[4]),
-                                   rep("0", sf_d$S[4]))) # t = 3
-sf5 <- sf %>%
-  add_node_attribute("Infected", c(rep("1", sf_d$I[5]),
-                                   rep("0", sf_d$S[5]))) # t = 4
-sf_set <- list(sf, sf1, sf2, sf3, sf4, sf5)
-autographs(sf_set, node_color = "Infected")

+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
@@ -647,19 +554,19 @@ 
Running multiple simulations

 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
+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.

 

+data-lines="0">
 
 

 

+data-lines="0">
 
# Remember, we are looking at the random network from before, "rd", with 
 # a transmissibility parameter of 0.5, 5 times, and 10 steps.
 
@@ -667,13 +574,16 @@ 
Running multiple simulations

 

 

+data-lines="0">
 
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.

+
Note that in this plot the number of new infections is not plotted
+because this might vary a bit each time the simulation is run. Instead,
+the loess line smooths over the varying trajectories and a (hardly
+distinguishable for this call) grey border to the line represents the
+standard error. 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

@@ -684,13 +594,12 @@

SIR models

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.

+data-diagnostics="1" data-startover="1" data-lines="0">
+data-lines="0"> 
# Remember, we are still looking at the random network, "rd", with a 
 # recovery rate of 20 percent.
 
@@ -698,30 +607,42 @@ 
SIR models
+data-lines="0"> 
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.

+remain susceptible. If you get moderately different results each time, +try increasing the number of times the simulation is run, +which should average out these differences and make the results more +reliable.

+
+ +
+
+
plot(play_diffusions(rd, recovery = 0.2, times = 100))
+

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 +additional waning parameter of 0.05. This means that after +twenty steps (on average), a recovered node may lose its recovered +status and become susceptible again. Play a single diffusion so that you can see what’s going on in a particular run.

+data-diagnostics="1" data-startover="1" data-lines="0">
-
plot(play_diffusion(rd, recovery = 0.25, waning = 0.05))
-plot(play_diffusions(rd, recovery = 0.25, waning = 0.05))
+data-lines="0"> +
plot(play_diffusion(rd, recovery = 0.2, waning = 0.05))
@@ -731,26 +652,63 @@

SIRS models

+

Depending on your particular simulation, there might be some +variation, so let’s run this same diffusion but multiple (100?) +times.

+
+
plot(play_diffusions(rd, recovery = 0.2, waning = 0.05, times = 100))
+ +
+
+
+
+
+
+ +
+

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 (0 indicates an exposed individual is immediately infected, -and 0.25 is approx four days). Play a single diffusion so that you can -see what’s going on in a particular run.

+proportion (try 0.25, approx four days). Play a single diffusion so that +you can see what’s going on in a particular run.

+data-diagnostics="1" data-startover="1" data-lines="0">
-
plot(play_diffusion(rd, latency = 0.5))  /
-plot(play_diffusion(rd, latency = 0.25)) /
-plot(play_diffusion(rd, latency = 0.1))
+data-lines="0"> +
plot(play_diffusion(rd, latency = 0.25, recovery = 0.2))
+
+
+
+

R-nought

+

So how can we establish the \(R_0\) +here? Well, recall that \(R_0 = +\frac{\beta}{\gamma}\). For a network such as ours, the expected +number of contacts per node \(\beta\) +is the average degree of all nodes, and the average number of days a +node remains contagious is 1 divided by the recovery +parameter.

+
+
latency <- 0.25
+mean(node_degree(rd, normalized = FALSE))/(1/latency)
+ +
+
+
+
+
+
+ +
@@ -771,28 +729,34 @@

Expectations of convergence and consensus

  • 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, -meaning there is no integer k > 1 that divides the length of every -cycle of the graph.
    • +
  • is_aperiodic(): Tests whether network is +aperiodic.
    • +data-diagnostics="1" data-startover="1" data-lines="0">
    +data-lines="0"> 
    # By default is_connected() will check whether a directed network
 # is strongly connected.
    +data-lines="0"> 
    is_connected(ison_networkers)
 is_aperiodic(ison_networkers)
    +
    +
    +
    +
    + +
    +
    +
    @@ -814,13 +778,12 @@

    Playing the DeGroot learning model

    been distributed. Then play the learning model with these beliefs, and plot the result.

    +data-diagnostics="1" data-startover="1" data-lines="0">
    +data-lines="0"> 
    beliefs <- rbinom(network_nodes(____), 1, prob = 0.25)
 ____ %>% mutate(____ = beliefs) %>% autographr(node_color = "____")
 netlearn <- play_learning(____, ____)
@@ -828,7 +791,7 @@ 
    Playing the DeGroot learning model
    +data-lines="0"> 
    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)
@@ -854,6 +817,12 @@ 
    Playing the DeGroot learning model
    
 library(migraph)
 library(patchwork)
 knitr::opts_chunk$set(echo = FALSE)
+nw <- to_undirected(to_unnamed(manynet::ison_networkers))
+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)
 
  
 
 
@@ -1092,36 +1060,25 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -1212,7 +1172,10 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -1278,18 +1240,18 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -1363,7 +1325,10 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -1440,7 +1405,10 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -1505,7 +1473,10 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -1572,7 +1543,10 @@ 
    Playing the DeGroot learning model
    
 
 
 
+
+ 
+
+
+
 
  
+
+
+
+
+ 
+
+
+
 
-
-
+ 
 
+
+
+
+ 
+
+
+
+
  
 
  
 
 
 
+
+ 
 
- 
+
+
 
-
-
+
    From 943c93ca9e516516dde916b274609c4ec83bbe8b Mon Sep 17 00:00:00 2001 From: Jael Tan Date: Wed, 8 Nov 2023 10:17:03 +0100 Subject: [PATCH 5/7] Amended colours for autographs plots --- inst/tutorials/tutorial7/diffusion.Rmd | 111 +++--- inst/tutorials/tutorial7/diffusion.html | 484 ++++++++++++++++-------- 2 files changed, 400 insertions(+), 195 deletions(-) diff --git a/inst/tutorials/tutorial7/diffusion.Rmd b/inst/tutorials/tutorial7/diffusion.Rmd index 55d0095f..0c03c9b6 100644 --- a/inst/tutorials/tutorial7/diffusion.Rmd +++ b/inst/tutorials/tutorial7/diffusion.Rmd @@ -166,26 +166,37 @@ ____(____) rg_d <- play_diffusion(rg, seeds = 1) plot(rg_d) -# visualise the diffusion in the network within first 5 steps of infection -rg <- rg %>% - add_node_attribute("Infected", rep("0", network_nodes(rg))) # original graph +# visualise the diffusion within the network in first 5 steps of infection rg1 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d$I[1]), - rep("0", rg_d$S[1]))) # t = 0 + add_node_attribute("Infected", c(rep("Infected", rg_d$I[1]), + rep("Susceptible", rg_d$S[1]) + )) # t = 0 rg2 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d$I[2]), - rep("0", rg_d$S[2]))) # t = 1 + add_node_attribute("Infected", c(rep("Infected", rg_d$I[2]), + rep("Susceptible", rg_d$S[2]) + )) # t = 1 rg3 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d$I[3]), - rep("0", rg_d$S[3]))) # t = 2 + add_node_attribute("Infected", c(rep("Infected", rg_d$I[3]), + rep("Susceptible", rg_d$S[3]) + )) # t = 2 rg4 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d$I[4]), - rep("0", rg_d$S[4]))) # t = 3 + add_node_attribute("Infected", c(rep("Infected", rg_d$I[4]), + rep("Susceptible", rg_d$S[4]) + )) # t = 3 rg5 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d$I[5]), - rep("0", rg_d$S[5]))) # t = 4 -rg_set <- list(rg, rg1, rg2, rg3, rg4, rg5) -autographs(rg_set, node_color = "Infected") + add_node_attribute("Infected", c(rep("Infected", rg_d$I[5]), + rep("Susceptible", rg_d$S[5]) + )) # t = 4 +rg6 <- rg %>% + add_node_attribute("Infected", c(rep("Infected", rg_d$I[6]), + rep("Susceptible", rg_d$S[6]) + )) # t = 4 +rg_set <- list(rg1, rg2, rg3, rg4, rg5, rg6) +plots <- autographs(rg_set, node_color = "Infected") +for (i in 1:length(plots)) { + plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c("red", "blue")) +} +plots ``` The result object, when printed, lists how many of the nodes in the network, @@ -241,26 +252,31 @@ plot(play_diffusion(rg, seeds = ____)) rg_d3 <- play_diffusion(rg, seeds = 1:4) plot(rg_d3) -# visualise the diffusion in the network within first 5 steps of infection -rg <- rg %>% - add_node_attribute("Infected", rep("0", network_nodes(rg))) # original graph +# visualise the diffusion within the network in first 5 steps of infection rg1 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d3$I[1]), - rep("0", rg_d3$S[1]))) # t = 0 + add_node_attribute("Infected", c(rep("Infected", rg_d3$I[1]), + rep("Susceptible", rg_d3$S[1]))) # t = 0 rg2 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d3$I[2]), - rep("0", rg_d3$S[2]))) # t = 1 + add_node_attribute("Infected", c(rep("Infected", rg_d3$I[2]), + rep("Susceptible", rg_d3$S[2]))) # t = 1 rg3 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d3$I[3]), - rep("0", rg_d3$S[3]))) # t = 2 + add_node_attribute("Infected", c(rep("Infected", rg_d3$I[3]), + rep("Susceptible", rg_d3$S[3]))) # t = 2 rg4 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d3$I[4]), - rep("0", rg_d3$S[4]))) # t = 3 + add_node_attribute("Infected", c(rep("Infected", rg_d3$I[4]), + rep("Susceptible", rg_d3$S[4]))) # t = 3 rg5 <- rg %>% - add_node_attribute("Infected", c(rep("1", rg_d3$I[5]), - rep("0", rg_d3$S[5]))) # t = 4 -rg_set <- list(rg, rg1, rg2, rg3, rg4, rg5) -autographs(rg_set, node_color = "Infected") + add_node_attribute("Infected", c(rep("Infected", rg_d3$I[5]), + rep("Susceptible", rg_d3$S[5]))) # t = 4 +rg6 <- rg %>% + add_node_attribute("Infected", c(rep("Infected", rg_d3$I[6]), + rep("Susceptible", rg_d3$S[6]))) # t = 5 +rg_set <- list(rg1, rg2, rg3, rg4, rg5, rg6) +plots <- autographs(rg_set, node_color = "Infected") +for (i in 1:length(plots)) { + plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c("red", "blue")) +} +plots ``` But what if we seed the network at three different places? @@ -460,27 +476,32 @@ plot(play_diffusion(sf, thresholds = c(rep(____,____), rep(____,____)))) 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)))) -# visualise the diffusion in the network from steps 1 to 5 +# visualise the diffusion within the network in the first 5 steps of infection sf_d <- play_diffusion(sf, thresholds = c(rep(0.1,10), rep(0.25,22))) -sf <- sf %>% - add_node_attribute("Infected", rep("0", network_nodes(sf))) # before diffusion sf1 <- sf %>% - add_node_attribute("Infected", c(rep("1", sf_d$I[1]), - rep("0", sf_d$S[1]))) # t = 0 + add_node_attribute("Infected", c(rep("Infected", sf_d$I[1]), + rep("Susceptible", sf_d$S[1]))) # t = 0 sf2 <- sf %>% - add_node_attribute("Infected", c(rep("1", sf_d$I[2]), - rep("0", sf_d$S[2]))) # t = 1 + add_node_attribute("Infected", c(rep("Infected", sf_d$I[2]), + rep("Susceptible", sf_d$S[2]))) # t = 1 sf3 <- sf %>% - add_node_attribute("Infected", c(rep("1", sf_d$I[3]), - rep("0", sf_d$S[3]))) # t = 2 + add_node_attribute("Infected", c(rep("Infected", sf_d$I[3]), + rep("Susceptible", sf_d$S[3]))) # t = 2 sf4 <- sf %>% - add_node_attribute("Infected", c(rep("1", sf_d$I[4]), - rep("0", sf_d$S[4]))) # t = 3 + add_node_attribute("Infected", c(rep("Infected", sf_d$I[4]), + rep("Susceptible", sf_d$S[4]))) # t = 3 sf5 <- sf %>% - add_node_attribute("Infected", c(rep("1", sf_d$I[5]), - rep("0", sf_d$S[5]))) # t = 4 -sf_set <- list(sf, sf1, sf2, sf3, sf4, sf5) -autographs(sf_set, node_color = "Infected") + add_node_attribute("Infected", c(rep("Infected", sf_d$I[5]), + rep("Susceptible", sf_d$S[5]))) # t = 4 +sf6 <- sf %>% + add_node_attribute("Infected", c(rep("Infected", sf_d$I[6]), + rep("Susceptible", sf_d$S[6]))) # t = 5 +sf_set <- list(sf1, sf2, sf3, sf4, sf5, sf6) +plots <- autographs(sf_set, node_color = "Infected") +for (i in 1:length(plots)) { + plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c("red", "blue")) +} +plots ``` Since the first ten nodes are the first to join the scale-free network diff --git a/inst/tutorials/tutorial7/diffusion.html b/inst/tutorials/tutorial7/diffusion.html index a5b44124..bb44eb02 100644 --- a/inst/tutorials/tutorial7/diffusion.html +++ b/inst/tutorials/tutorial7/diffusion.html @@ -13,7 +13,7 @@ - + Diffusion @@ -120,12 +120,13 @@

    Investigate diffusion through simulation

    {manynet}, and create or generate ring, lattice, random, scale-free, and small-world versions with the same number of nodes.

    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>">
    +data-lines="0" data-pipe="|>"> 
    # 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
 
@@ -133,7 +134,7 @@ 
    Investigate diffusion through simulation
    +data-lines="0" data-pipe="|>"> 
    # 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.
 
@@ -141,7 +142,7 @@ 
    Investigate diffusion through simulation
    +data-lines="0" data-pipe="|>"> 
    nw <- to_undirected(to_unnamed(ison_networkers))
    Creating and visualising different network structures 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 +given dimensions that loops around and is of a specified width or thickness.
    • create_lattice(): Creates a graph of the given dimensions with ties to all neighbouring nodes
      • @@ -165,12 +166,13 @@

      Creating and visualising different network structures

    +data-lines="0" data-pipe="|>">
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    # Let's generate a ring structure, "rg", with a width of 2, using the appropriate
 # function above
 
@@ -178,36 +180,42 @@ 
    Creating and visualising different network structures
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    rg <- create_ring(nw, width = 2)
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    # Let's generate a lattice structure, "la", using the appropriate function above
 
 la <- ____(____)
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    la <- create_lattice(nw)
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    # Let's generate a random structure, "rd", without attributes
 
 rd <- ____(____, ____)
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    rd <- generate_random(nw, with_attr = FALSE)
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    # 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.
 
@@ -216,13 +224,15 @@ 
    Creating and visualising different network structures
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    sf <- generate_scalefree(nw, 0.025)
 sw <- generate_smallworld(nw, 0.025)
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    # Finally, let's plot the respective graphs:
 
 autographr(____) + ggtitle("Networkers") +
@@ -234,7 +244,8 @@ 
    Creating and visualising different network structures
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> 
    # Here is the solution:
 
 rg <- create_ring(nw, width = 2)
@@ -259,12 +270,13 @@ 
    Examining diffusion across networks of different structure
    
 across this network, simply pass it to play_diffusion() and
 (save and) plot the result.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    # 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!
 
@@ -273,9 +285,41 @@ 
    Examining diffusion across networks of different structure
    
 
    
 
    
-
    rg1 <- play_diffusion(rg, seeds = 1)
-plot(rg1)
    
+data-lines="0" data-pipe="|>">
+
    rg_d <- play_diffusion(rg, seeds = 1)
+plot(rg_d)
+
+# visualise the diffusion within the network in first 5 steps of infection
+rg1 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d$I[1]),
+                                   rep("Susceptible", rg_d$S[1])
+                                   )) # t = 0
+rg2 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d$I[2]),
+                                   rep("Susceptible", rg_d$S[2])
+                                   )) # t = 1
+rg3 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d$I[3]),
+                                   rep("Susceptible", rg_d$S[3])
+                                   )) # t = 2
+rg4 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d$I[4]),
+                                   rep("Susceptible", rg_d$S[4])
+                                   )) # t = 3
+rg5 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d$I[5]),
+                                   rep("Susceptible", rg_d$S[5])
+                                   )) # t = 4
+rg6 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d$I[6]),
+                                   rep("Susceptible", rg_d$S[6])
+                                   )) # t = 4
+rg_set <- list(rg1, rg2, rg3, rg4, rg5, rg6)
+plots <- autographs(rg_set, node_color = "Infected")
+for (i in 1:length(plots)) {
+  plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c("red", "blue"))
+}
+plots
    
 
    
 
    The result object, when printed, lists how many of the nodes in the
 network, n, are ‘infected’ (I) or not
@@ -295,14 +339,15 @@ 
    Varying seed nodes
    
 network. To see whether this is true, try choosing the sixteenth
 (middle) node and see whether the result is any different.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
-
    rg2 <- play_diffusion(rg, seeds = 16)
-plot(rg2)
    
+data-lines="0" data-pipe="|>">
+
    rg_d2 <- play_diffusion(rg, seeds = 16)
+plot(rg_d2)
    
 
    
 
    
 
    
@@ -316,31 +361,60 @@ 
    Varying seed nodes
    
 Choosing the first four nodes we can see that the process is
 jump-started, but doesn’t really conclude that much faster.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    # Remember we want to see the first four nodes.
 
 plot(play_diffusion(rg, seeds = ____))
    
 
    
 
    
-
    plot(play_diffusion(rg, seeds = 1:4))
    
+data-lines="0" data-pipe="|>">
+
    rg_d3 <- play_diffusion(rg, seeds = 1:4)
+plot(rg_d3)
+
+# visualise the diffusion within the network in first 5 steps of infection
+rg1 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d3$I[1]),
+                                   rep("Susceptible", rg_d3$S[1]))) # t = 0
+rg2 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d3$I[2]),
+                                   rep("Susceptible", rg_d3$S[2]))) # t = 1
+rg3 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d3$I[3]),
+                                   rep("Susceptible", rg_d3$S[3]))) # t = 2
+rg4 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d3$I[4]),
+                                   rep("Susceptible", rg_d3$S[4]))) # t = 3
+rg5 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d3$I[5]),
+                                   rep("Susceptible", rg_d3$S[5]))) # t = 4
+rg6 <- rg %>%
+  add_node_attribute("Infected", c(rep("Infected", rg_d3$I[6]),
+                                   rep("Susceptible", rg_d3$S[6]))) # t = 5
+rg_set <- list(rg1, rg2, rg3, rg4, rg5, rg6)
+plots <- autographs(rg_set, node_color = "Infected")
+for (i in 1:length(plots)) {
+  plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c("red", "blue"))
+}
+plots
    
 
    
 
    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.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    # We will be using the node_is_random() within the seed argument to random select 
 # 4 nodes
 
@@ -348,7 +422,7 @@ 
    Varying seed nodes
    
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    plot(play_diffusion(rg, seeds = node_is_random(rg, 4)))
    
 
    
 
    
@@ -370,14 +444,18 @@ 
    Varying networks
    
 diffusion on the lattice network, one with the first node as seed and
 again one on the last.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    plot(play_diffusion(la, seeds = 1))/
-plot(play_diffusion(la, seeds = 16))
    
+plot(play_diffusion(la, seeds = 16))
+la %>%
+  add_node_attribute("color", c(1, rep(0, 14), 2, rep(0, 16))) %>%
+  autographr(node_color = "color")
    @@ -401,13 +479,20 @@

    Varying networks

    minimum of some measure.
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>">
    -
    plot(play_diffusion(sf, seeds = 10, steps = 10)) / 
+data-lines="0" data-pipe="|>">
+
    sf %>%
+  as_tidygraph() %>%
+  activate(nodes) %>%
+  mutate(degree = ifelse(node_is_max(node_degree(sf)), "max",
+                      ifelse(node_is_min(node_degree(sf)), "min", "others"))) %>%
+  autographr(node_color = "degree") + guides(color = "legend") + labs(color = "degree")
+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))
    
@@ -432,12 +517,13 @@ 
    Varying thresholds
    
 will not lead to any diffusion process unless there are two seeds and
 that they are in another nodes neighbourhood.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    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))/
@@ -458,12 +544,12 @@ 
    Varying thresholds
    
 scale-free network.
    
 
    
+data-lines="0" data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    plot(play_diffusion(sf, seeds = 1, thresholds = 2))
    
 
    
 
    
@@ -480,19 +566,20 @@ 
    Varying thresholds
    
 become infected. Try thresholds of 0.1, 0.25, and 0.5 on two seeds and
 10 steps.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    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 = ____))
    
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    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))
    
@@ -514,20 +601,48 @@ 
    Varying thresholds
    
 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.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    plot(play_diffusion(sf, thresholds = c(rep(____,____), rep(____,____))))/
 plot(play_diffusion(sf, thresholds = c(rep(____,____), rep(____,____))))
    
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    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))))
    
+plot(play_diffusion(sf, thresholds = c(rep(0.25,10), rep(0.1,22))))
+
+# visualise the diffusion within the network in the first 5 steps of infection
+sf_d <- play_diffusion(sf, thresholds = c(rep(0.1,10), rep(0.25,22)))
+sf1 <- sf %>%
+  add_node_attribute("Infected", c(rep("Infected", sf_d$I[1]),
+                                   rep("Susceptible", sf_d$S[1]))) # t = 0
+sf2 <- sf %>%
+  add_node_attribute("Infected", c(rep("Infected", sf_d$I[2]),
+                                   rep("Susceptible", sf_d$S[2]))) # t = 1
+sf3 <- sf %>%
+  add_node_attribute("Infected", c(rep("Infected", sf_d$I[3]),
+                                   rep("Susceptible", sf_d$S[3]))) # t = 2
+sf4 <- sf %>%
+  add_node_attribute("Infected", c(rep("Infected", sf_d$I[4]),
+                                   rep("Susceptible", sf_d$S[4]))) # t = 3
+sf5 <- sf %>%
+  add_node_attribute("Infected", c(rep("Infected", sf_d$I[5]),
+                                   rep("Susceptible", sf_d$S[5]))) # t = 4
+sf6 <- sf %>%
+  add_node_attribute("Infected", c(rep("Infected", sf_d$I[6]),
+                                   rep("Susceptible", sf_d$S[6]))) # t = 5
+sf_set <- list(sf1, sf2, sf3, sf4, sf5, sf6)
+plots <- autographs(sf_set, node_color = "Infected")
+for (i in 1:length(plots)) {
+  plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c("red", "blue"))
+}
+plots
    
 
    
 
    Since the first ten nodes are the first to join the scale-free
 network and are preferentially attached by those who follow, they will
@@ -561,12 +676,12 @@ 
    Running multiple simulations
    
 only 1/2 cases is contagion successful.
    
 
    
+data-lines="0" data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    # Remember, we are looking at the random network from before, "rd", with 
 # a transmissibility parameter of 0.5, 5 times, and 10 steps.
 
@@ -574,7 +689,7 @@ 
    Running multiple simulations
    
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    plot(play_diffusions(rd, transmissibility = 0.5, times = 5, steps = 10))
    
 
    
 
    Note that in this plot the number of new infections is not plotted
@@ -594,12 +709,13 @@ 
    SIR models
    
 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.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    # Remember, we are still looking at the random network, "rd", with a 
 # recovery rate of 20 percent.
 
@@ -607,7 +723,7 @@ 
    SIR models
    
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    plot(play_diffusions(rd, recovery = 0.2))
    
 
    
 
    What we see in these kinds of models is typically a spike in
@@ -618,12 +734,13 @@ 
    SIR models
    
 which should average out these differences and make the results more
 reliable.
    
 
    
+data-diagnostics="1" data-startover="1" data-lines="0"
+data-pipe="|>">
 
 
    
 
    
+data-lines="0" data-pipe="|>">
 
    plot(play_diffusions(rd, recovery = 0.2, times = 100))
    @@ -636,12 +753,13 @@

    SIRS models

    status and become susceptible again. Play a single diffusion so that you can see what’s going on in a particular run.

    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>">
    +data-lines="0" data-pipe="|>"> 
    plot(play_diffusion(rd, recovery = 0.2, waning = 0.05))
    @@ -657,7 +775,7 @@

    SIRS models

    times.

    +data-lines="0" data-pipe="|>"> 
    plot(play_diffusions(rd, recovery = 0.2, waning = 0.05, times = 100))
    @@ -674,16 +792,21 @@

    SIRS models

    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.

    +some latency (\(\sigma\)). +This should also be specified as a proportion, but note that this is +inverted internally. This means that a latency of 0 means that exposure +immediately renders the node infectious. A latency of 0.75 means that it +will take the node approximately 4 days (1/1-0.75 = 1/0.25 = 4) to +become infectious. Play a single diffusion so that you can see what’s +going on in a particular run.

    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>">
    +data-lines="0" data-pipe="|>"> 
    plot(play_diffusion(rd, latency = 0.25, recovery = 0.2))
    @@ -697,9 +820,10 @@

    R-nought

    node remains contagious is 1 divided by the recovery parameter.

    -
    latency <- 0.25
-mean(node_degree(rd, normalized = FALSE))/(1/latency)
    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>"> +
    recovery <- 0.2
+mean(node_degree(rd, normalized = FALSE))/(1/recovery)
    @@ -729,22 +853,24 @@

    Expectations of convergence and consensus

  • 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.
    • +
  • is_aperiodic(): Tests whether network is aperiodic, +meaning there is no integer k > 1 that divides the length of every +cycle of the graph.
    • +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>">
    +data-lines="0" data-pipe="|>"> 
    # By default is_connected() will check whether a directed network
 # is strongly connected.
    +data-lines="0" data-pipe="|>"> 
    is_connected(ison_networkers)
 is_aperiodic(ison_networkers)
    @@ -778,12 +904,13 @@

    Playing the DeGroot learning model

    been distributed. Then play the learning model with these beliefs, and plot the result.

    +data-diagnostics="1" data-startover="1" data-lines="0" +data-pipe="|>">
    +data-lines="0" data-pipe="|>"> 
    beliefs <- rbinom(network_nodes(____), 1, prob = 0.25)
 ____ %>% mutate(____ = beliefs) %>% autographr(node_color = "____")
 netlearn <- play_learning(____, ____)
@@ -791,7 +918,7 @@ 
    Playing the DeGroot learning model
    +data-lines="0" data-pipe="|>"> 
    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)
@@ -957,8 +1084,29 @@ 
    Playing the DeGroot learning model
    
     label = "ring", code = "", opts = list(label = "\"ring\"", 
         exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), 
     engine = "r")), code_check = NULL, error_check = NULL, check = NULL, 
-    solution = structure(c("rg1 <- play_diffusion(rg, seeds = 1)", 
-    "plot(rg1)"), chunk_opts = list(label = "ring-solution")), 
+    solution = structure(c("rg_d <- play_diffusion(rg, seeds = 1)", 
+    "plot(rg_d)", "", "# visualise the diffusion within the network in first 5 steps of infection", 
+    "rg1 <- rg %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d$I[1]),", 
+    "                                   rep(\"Susceptible\", rg_d$S[1])", 
+    "                                   )) # t = 0", "rg2 <- rg %>%", 
+    "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d$I[2]),", 
+    "                                   rep(\"Susceptible\", rg_d$S[2])", 
+    "                                   )) # t = 1", "rg3 <- rg %>%", 
+    "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d$I[3]),", 
+    "                                   rep(\"Susceptible\", rg_d$S[3])", 
+    "                                   )) # t = 2", "rg4 <- rg %>%", 
+    "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d$I[4]),", 
+    "                                   rep(\"Susceptible\", rg_d$S[4])", 
+    "                                   )) # t = 3", "rg5 <- rg %>%", 
+    "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d$I[5]),", 
+    "                                   rep(\"Susceptible\", rg_d$S[5])", 
+    "                                   )) # t = 4", "rg6 <- rg %>%", 
+    "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d$I[6]),", 
+    "                                   rep(\"Susceptible\", rg_d$S[6])", 
+    "                                   )) # t = 4", "rg_set <- list(rg1, rg2, rg3, rg4, rg5, rg6)", 
+    "plots <- autographs(rg_set, node_color = \"Infected\")", 
+    "for (i in 1:length(plots)) {", "  plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c(\"red\", \"blue\"))", 
+    "}", "plots"), chunk_opts = list(label = "ring-solution")), 
     tests = NULL, options = list(eval = FALSE, echo = TRUE, results = "markup", 
         tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, 
         comment = NA, highlight = FALSE, size = "normalsize", 
@@ -1003,8 +1151,8 @@ 
    Playing the DeGroot learning model
    
     label = "ring2", code = "", opts = list(label = "\"ring2\"", 
         exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), 
     engine = "r")), code_check = NULL, error_check = NULL, check = NULL, 
-    solution = structure(c("rg2 <- play_diffusion(rg, seeds = 16)", 
-    "plot(rg2)"), chunk_opts = list(label = "ring2-solution")), 
+    solution = structure(c("rg_d2 <- play_diffusion(rg, seeds = 16)", 
+    "plot(rg_d2)"), chunk_opts = list(label = "ring2-solution")), 
     tests = NULL, options = list(eval = FALSE, echo = TRUE, results = "markup", 
         tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, 
         comment = NA, highlight = FALSE, size = "normalsize", 
@@ -1031,10 +1179,10 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -1070,15 +1218,31 @@ 
    Playing the DeGroot learning model
    
     label = "ring3", code = "", opts = list(label = "\"ring3\"", 
         exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), 
     engine = "r")), code_check = NULL, error_check = NULL, check = NULL, 
-    solution = structure("plot(play_diffusion(rg, seeds = 1:4))", chunk_opts = list(
-        label = "ring3-solution")), tests = NULL, options = list(
-        eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, 
-        tidy.opts = NULL, collapse = FALSE, prompt = FALSE, comment = NA, 
-        highlight = FALSE, size = "normalsize", background = "#F7F7F7", 
-        strip.white = TRUE, cache = 0, cache.path = "diffusion_cache/html/", 
-        cache.vars = NULL, cache.lazy = TRUE, dependson = NULL, 
-        autodep = FALSE, cache.rebuild = FALSE, fig.keep = "high", 
-        fig.show = "asis", fig.align = "default", fig.path = "diffusion_files/figure-html/", 
+    solution = structure(c("rg_d3 <- play_diffusion(rg, seeds = 1:4)", 
+    "plot(rg_d3)", "", "# visualise the diffusion within the network in first 5 steps of infection", 
+    "rg1 <- rg %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d3$I[1]),", 
+    "                                   rep(\"Susceptible\", rg_d3$S[1]))) # t = 0", 
+    "rg2 <- rg %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d3$I[2]),", 
+    "                                   rep(\"Susceptible\", rg_d3$S[2]))) # t = 1", 
+    "rg3 <- rg %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d3$I[3]),", 
+    "                                   rep(\"Susceptible\", rg_d3$S[3]))) # t = 2", 
+    "rg4 <- rg %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d3$I[4]),", 
+    "                                   rep(\"Susceptible\", rg_d3$S[4]))) # t = 3", 
+    "rg5 <- rg %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d3$I[5]),", 
+    "                                   rep(\"Susceptible\", rg_d3$S[5]))) # t = 4", 
+    "rg6 <- rg %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", rg_d3$I[6]),", 
+    "                                   rep(\"Susceptible\", rg_d3$S[6]))) # t = 5", 
+    "rg_set <- list(rg1, rg2, rg3, rg4, rg5, rg6)", "plots <- autographs(rg_set, node_color = \"Infected\")", 
+    "for (i in 1:length(plots)) {", "  plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c(\"red\", \"blue\"))", 
+    "}", "plots"), chunk_opts = list(label = "ring3-solution")), 
+    tests = NULL, options = list(eval = FALSE, echo = TRUE, results = "markup", 
+        tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, 
+        comment = NA, highlight = FALSE, size = "normalsize", 
+        background = "#F7F7F7", strip.white = TRUE, cache = 0, 
+        cache.path = "diffusion_cache/html/", cache.vars = NULL, 
+        cache.lazy = TRUE, dependson = NULL, autodep = FALSE, 
+        cache.rebuild = FALSE, fig.keep = "high", fig.show = "asis", 
+        fig.align = "default", fig.path = "diffusion_files/figure-html/", 
         dev = "png", dev.args = NULL, dpi = 192, fig.ext = "png", 
         fig.width = 6.5, fig.height = 4, fig.env = "figure", 
         fig.cap = NULL, fig.scap = NULL, fig.lp = "fig:", fig.subcap = NULL, 
@@ -1143,10 +1307,10 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -1183,7 +1347,8 @@ 
    Playing the DeGroot learning model
    
         exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), 
     engine = "r")), code_check = NULL, error_check = NULL, check = NULL, 
     solution = structure(c("plot(play_diffusion(la, seeds = 1))/", 
-    "plot(play_diffusion(la, seeds = 16))"), chunk_opts = list(
+    "plot(play_diffusion(la, seeds = 16))", "la %>%", "  add_node_attribute(\"color\", c(1, rep(0, 14), 2, rep(0, 16))) %>%", 
+    "  autographr(node_color = \"color\")"), chunk_opts = list(
         label = "lattice-solution")), tests = NULL, options = list(
         eval = FALSE, echo = TRUE, results = "markup", tidy = FALSE, 
         tidy.opts = NULL, collapse = FALSE, prompt = FALSE, comment = NA, 
@@ -1211,10 +1376,10 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -1250,8 +1415,11 @@ 
    Playing the DeGroot learning model
    
     label = "scale", code = "", opts = list(label = "\"scale\"", 
         exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), 
     engine = "r")), code_check = NULL, error_check = NULL, check = NULL, 
-    solution = structure(c("plot(play_diffusion(sf, seeds = 10, steps = 10)) / ", 
-    "plot(play_diffusion(sf, seeds = node_is_random(sf), steps = 10)) /", 
+    solution = structure(c("sf %>%", "  as_tidygraph() %>%", 
+    "  activate(nodes) %>%", "  mutate(degree = ifelse(node_is_max(node_degree(sf)), \"max\",", 
+    "                      ifelse(node_is_min(node_degree(sf)), \"min\", \"others\"))) %>%", 
+    "  autographr(node_color = \"degree\") + guides(color = \"legend\") + labs(color = \"degree\")", 
+    "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))"
     ), chunk_opts = list(label = "scale-solution")), tests = NULL, 
@@ -1282,22 +1450,22 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -1366,19 +1534,19 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -1444,10 +1612,10 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -1514,10 +1682,10 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -1554,9 +1722,25 @@ 
    Playing the DeGroot learning model
    
         exercise = "TRUE", exercise.setup = "\"create\"", purl = "FALSE"), 
     engine = "r")), code_check = NULL, error_check = NULL, check = NULL, 
     solution = structure(c("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))))"
-    ), chunk_opts = list(label = "rand-solution")), tests = NULL, 
-    options = list(eval = FALSE, echo = TRUE, results = "markup", 
+    "plot(play_diffusion(sf, thresholds = c(rep(0.25,10), rep(0.1,22))))", 
+    "", "# visualise the diffusion within the network in the first 5 steps of infection", 
+    "sf_d <- play_diffusion(sf, thresholds = c(rep(0.1,10), rep(0.25,22)))", 
+    "sf1 <- sf %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", sf_d$I[1]),", 
+    "                                   rep(\"Susceptible\", sf_d$S[1]))) # t = 0", 
+    "sf2 <- sf %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", sf_d$I[2]),", 
+    "                                   rep(\"Susceptible\", sf_d$S[2]))) # t = 1", 
+    "sf3 <- sf %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", sf_d$I[3]),", 
+    "                                   rep(\"Susceptible\", sf_d$S[3]))) # t = 2", 
+    "sf4 <- sf %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", sf_d$I[4]),", 
+    "                                   rep(\"Susceptible\", sf_d$S[4]))) # t = 3", 
+    "sf5 <- sf %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", sf_d$I[5]),", 
+    "                                   rep(\"Susceptible\", sf_d$S[5]))) # t = 4", 
+    "sf6 <- sf %>%", "  add_node_attribute(\"Infected\", c(rep(\"Infected\", sf_d$I[6]),", 
+    "                                   rep(\"Susceptible\", sf_d$S[6]))) # t = 5", 
+    "sf_set <- list(sf1, sf2, sf3, sf4, sf5, sf6)", "plots <- autographs(sf_set, node_color = \"Infected\")", 
+    "for (i in 1:length(plots)) {", "  plots[[i]] <- plots[[i]] + ggplot2::scale_colour_manual(values = c(\"red\", \"blue\"))", 
+    "}", "plots"), chunk_opts = list(label = "rand-solution")), 
+    tests = NULL, options = list(eval = FALSE, echo = TRUE, results = "markup", 
         tidy = FALSE, tidy.opts = NULL, collapse = FALSE, prompt = FALSE, 
         comment = NA, highlight = FALSE, size = "normalsize", 
         background = "#F7F7F7", strip.white = TRUE, cache = 0, 
@@ -1755,10 +1939,10 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -1819,16 +2003,16 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -1907,7 +2091,7 @@ 
    Playing the DeGroot learning model
    
     include = FALSE)), setup = "", chunks = list(list(label = "create", 
     code = "", opts = list(label = "\"create\"", echo = "TRUE", 
         exercise = "TRUE", purl = "FALSE"), engine = "r"), list(
-    label = "r0", code = "latency <- 0.25\nmean(node_degree(rd, normalized = FALSE))/(1/latency)", 
+    label = "r0", code = "recovery <- 0.2\nmean(node_degree(rd, normalized = FALSE))/(1/recovery)", 
     opts = list(label = "\"r0\"", exercise = "TRUE", exercise.setup = "\"create\""), 
     engine = "r")), code_check = NULL, error_check = NULL, check = NULL, 
     solution = NULL, tests = NULL, options = list(eval = FALSE, 
@@ -1927,7 +2111,7 @@ 
    Playing the DeGroot learning model
    
         message = TRUE, render = NULL, ref.label = NULL, child = NULL, 
         engine = "r", split = FALSE, include = TRUE, purl = TRUE, 
         max.print = 1000, label = "r0", exercise = TRUE, exercise.setup = "create", 
-        code = c("latency <- 0.25", "mean(node_degree(rd, normalized = FALSE))/(1/latency)"
+        code = c("recovery <- 0.2", "mean(node_degree(rd, normalized = FALSE))/(1/recovery)"
         ), out.width.px = 624, out.height.px = 384, params.src = "r0, exercise = TRUE, exercise.setup = \"create\"", 
         fig.num = 0, exercise.df_print = "paged", exercise.checker = "NULL"), 
     engine = "r", version = "4"), class = c("r", "tutorial_exercise"
@@ -1938,16 +2122,16 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -2010,10 +2194,10 @@ 
    Playing the DeGroot learning model
    
 
 
@@ -2033,20 +2217,20 @@ 
    Playing the DeGroot learning model
    
 
  
@@ -2111,27 +2295,27 @@ 
    Playing the DeGroot learning model
    From 3a28cd70146a8b8363c5cba8623634f44aa4c158 Mon Sep 17 00:00:00 2001 From: hollway Date: Wed, 8 Nov 2023 11:50:24 +0100 Subject: [PATCH 6/7] Added first drafts of various diffusion measures --- R/measure_diffusion.R | 77 +++++++++++++++++++++++++++++++++++++++++++ man/diffusion.Rd | 75 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 152 insertions(+) create mode 100644 R/measure_diffusion.R create mode 100644 man/diffusion.Rd diff --git a/R/measure_diffusion.R b/R/measure_diffusion.R new file mode 100644 index 00000000..c3d0eb6d --- /dev/null +++ b/R/measure_diffusion.R @@ -0,0 +1,77 @@ +#' Functions to play games on networks +#' @param diff_model A valid network diffusion model. +#' @family measures +#' @name diffusion +#' @references +#' Valente, Tom W. (1995). _Network models of the diffusion of innovations_ +#' (2nd ed.). Cresskill N.J.: Hampton Press. +NULL + +#' @describeIn diffusion Calculates the average transmissibility observed +#' in a diffusion simulation, or the number of new infections over +#' the number of susceptible, over the number of infected +#' @export +network_transmissibility <- function(diff_model){ + out <- diff_model |> + mutate(transmissibility = (I - dplyr::lag(I)/dplyr::lag(S))/ + dplyr::lag(I)) + out <- out$transmissibility + out <- out[!is.infinite(out)] + mean(out, na.rm = TRUE) +} + +#' @describeIn diffusion Calculates the average length nodes remain +#' infected in a compartmental model with recovery +#' @export +node_infection_length <- function(diff_model){ + events <- attr(diff_model, "events") + if(!"R" %in% events$event) stop("Infection length only calculable if there is recovery or removal.") + vapply(seq_len(diff_model$n[1]), + function(x) mean(diff(dplyr::filter(events, nodes == x)$t)), + FUN.VALUE = numeric(1)) +} + +#' @describeIn diffusion Calculates the average length nodes remain +#' infected in a compartmental model with recovery for the network as a whole +#' @export +network_infection_length <- function(diff_model){ + mean(node_infection_length(diff_model)) +} + +#' @describeIn diffusion Calculates the observed reproductive number +#' in a diffusion simulation as the network's transmissibility over +#' the network's average infection length +#' @export +network_reproduction <- function(diff_model){ + network_transmissibility(diff_model)/ + network_infection_length(diff_model) +} + +#' @describeIn diffusion Returns nodes' time of adoption/infection +#' @export +node_adoption_time <- function(diff_model){ + summary(diff_model) |> dplyr::filter(event == "I") |> + dplyr::distinct(nodes, .keep_all = TRUE) |> + dplyr::select(t) |> c() |> unname() |> unlist() +} + +#' @describeIn diffusion Returns nodes' time of adoption/infection +#' @export +node_adopter <- function(diff_model){ + toa <- node_adoption_time(diff_model) + avg <- mean(toa) + sdv <- sd(toa) + ifelse(toa < (avg - sdv), "Early Adopter", + ifelse(toa > (avg + sdv), "Laggard", + ifelse((avg - sdv) < toa & toa <= avg, "Early Majority", + ifelse(avg < toa & toa <= avg + sdv, "Late Majority", "Non-Adopter")))) +} + +#' @describeIn diffusion Infers nodes' thresholds from the amount +#' of exposure they had when they became infected +#' @export +node_thresholds <- function(diff_model){ + summary(diff_model) |> dplyr::filter(event == "I") |> + dplyr::distinct(nodes, .keep_all = TRUE) |> + dplyr::select(exposure) |> c() |> unname() |> unlist() +} \ No newline at end of file diff --git a/man/diffusion.Rd b/man/diffusion.Rd new file mode 100644 index 00000000..308d09e0 --- /dev/null +++ b/man/diffusion.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/measure_diffusion.R +\name{diffusion} +\alias{diffusion} +\alias{network_transmissibility} +\alias{node_infection_length} +\alias{network_infection_length} +\alias{network_reproduction} +\alias{node_adoption_time} +\alias{node_adopter} +\alias{node_thresholds} +\title{Functions to play games on networks} +\usage{ +network_transmissibility(diff_model) + +node_infection_length(diff_model) + +network_infection_length(diff_model) + +network_reproduction(diff_model) + +node_adoption_time(diff_model) + +node_adopter(diff_model) + +node_thresholds(diff_model) +} +\arguments{ +\item{diff_model}{A valid network diffusion model.} +} +\description{ +Functions to play games on networks +} +\section{Functions}{ +\itemize{ +\item \code{network_transmissibility()}: Calculates the average transmissibility observed +in a diffusion simulation, or the number of new infections over +the number of susceptible, over the number of infected + +\item \code{node_infection_length()}: Calculates the average length nodes remain +infected in a compartmental model with recovery + +\item \code{network_infection_length()}: Calculates the average length nodes remain +infected in a compartmental model with recovery for the network as a whole + +\item \code{network_reproduction()}: Calculates the observed reproductive number +in a diffusion simulation as the network's transmissibility over +the network's average infection length + +\item \code{node_adoption_time()}: Returns nodes' time of adoption/infection + +\item \code{node_adopter()}: Returns nodes' time of adoption/infection + +\item \code{node_thresholds()}: Infers nodes' thresholds from the amount +of exposure they had when they became infected + +}} +\references{ +Valente, Tom W. (1995). \emph{Network models of the diffusion of innovations} +(2nd ed.). Cresskill N.J.: Hampton Press. +} +\seealso{ +Other measures: +\code{\link{between_centrality}}, +\code{\link{close_centrality}}, +\code{\link{closure}}, +\code{\link{cohesion}()}, +\code{\link{degree_centrality}}, +\code{\link{eigenv_centrality}}, +\code{\link{features}}, +\code{\link{heterogeneity}}, +\code{\link{hierarchy}}, +\code{\link{holes}} +} +\concept{measures} From b6b87d6b8c06ebc6940838906774c76b7eafad69 Mon Sep 17 00:00:00 2001 From: Jael Tan Date: Wed, 8 Nov 2023 13:11:54 +0100 Subject: [PATCH 7/7] Updated news and version number --- DESCRIPTION | 4 ++-- NEWS.md | 17 +++++++++++++++++ 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4b3389fd..8ad3cc47 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: migraph Title: Multimodal Network Analysis and More -Version: 1.1.5 -Date: 2023-11-02 +Version: 1.1.6 +Date: 2023-11-08 Description: A set of tools for analysing multimodal networks. It includes functions for measuring centrality, centralization, cohesion, closure, constraint and diversity, diff --git a/NEWS.md b/NEWS.md index 68a421c7..b19e687f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,20 @@ +# migraph 1.1.6 + +2023-11-08 + +## Measures + +- Added first drafts of various diffusion measures: `network_transmissability()`, `node_infection_length()`, `network_infection_length()`, `network_reproduction()`, `node_adoption_time()`, `node_adopter()`, `node_thresholds()`. + +## Models + +- Fixed documentation for `play_diffusion()`. +- Fixed bug in labelling in plot results for SIR models. + +## Tutorials + +- Added plots using `autographs()` and elaboration for tutorial 7. + # migraph 1.1.5 2023-11-02