Merge pull request #254 from snlab-ch/develop

v0.12.6

.gitignore

@@ -15,3 +15,5 @@ CRAN-SUBMISSION
 man/figures/unnamed-chunk-1-1.png
 inst/tutorials/community/community_data/*
 inst/tutorials/equivalence/equivalence_data/*
+inst/tutorials/tutorial4/community_data/*
+inst/tutorials/tutorial5/equivalence_data/*

DESCRIPTION

@@ -1,14 +1,14 @@
 Package: migraph
 Title: Tools for Multimodal Network Analysis
-Version: 0.12.5
-Date: 2022-11-02
+Version: 0.12.6
+Date: 2022-11-09
 Description: A set of tools for analysing multimodal networks.
    All functions operate with matrices, edge lists, 
    and 'igraph', 'network', and 'tidygraph' objects,
    and on one-mode, two-mode (bipartite), and sometimes three-mode networks.
    It includes functions for measuring 
    centrality, centralization, cohesion, closure, and constraint,
-   as well as for network block-modelling and regression.
+   as well as for network block-modelling, regression, and diffusion models.
    The package is released as a complement to 
    'Multimodal Political Networks' (2021, ISBN:9781108985000),
    and includes various datasets used in the book in addition to other network data.

NAMESPACE

@@ -89,6 +89,8 @@ S3method(is_weighted,igraph)
 S3method(is_weighted,matrix)
 S3method(is_weighted,network)
 S3method(is_weighted,tbl_graph)
+S3method(mutate,igraph)
+S3method(plot,diff_model)
 S3method(plot,graph_test)
 S3method(plot,matrix)
 S3method(plot,netlm)
@@ -97,6 +99,7 @@ S3method(plot,network_test)
 S3method(plot,node_measure)
 S3method(plot,node_member)
 S3method(plot,tie_measure)
+S3method(print,diff_model)
 S3method(print,graph_measure)
 S3method(print,graph_motif)
 S3method(print,graph_test)
@@ -109,6 +112,7 @@ S3method(print,node_member)
 S3method(print,node_motif)
 S3method(print,tie_mark)
 S3method(print,tie_measure)
+S3method(summary,diff_model)
 S3method(summary,node_measure)
 S3method(summary,node_motif)
 S3method(tidy,netlm)
@@ -375,6 +379,7 @@ export(node_is_cutpoint)
 export(node_is_isolate)
 export(node_is_max)
 export(node_is_min)
+export(node_is_random)
 export(node_kernighanlin)
 export(node_mode)
 export(node_names)
@@ -392,6 +397,7 @@ export(node_transitivity)
 export(node_triad_census)
 export(node_walktrap)
 export(node_weak_components)
+export(play_diffusion)
 export(read_edgelist)
 export(read_nodelist)
 export(read_pajek)

NEWS.md

@@ -1,3 +1,30 @@
+# migraph 0.12.6
+
+## Package
+
+- Changed tutorial naming structure to numeric
+- Made all existing tutorials solution oriented
+- Converted visualisation vignette into tutorial
+  - Added further instruction as to how to change e.g. node_color colors
+- Converted centrality vignette into tutorial
+- Converted regression vignette into tutorial
+  - Added a lot more interactivity to regression tutorial
+- Deleted vignette instructions off of the README
+- Added some core/coreness aspects to topology tutorial
+
+## Manipulations
+
+- `mutate()` now works with igraph objects
+
+## Marks
+
+- Added `node_is_random()` for selecting n nodes at random
+
+## Models
+
+- Added first draft of (SI) `play_diffusion()` model
+  - Added diff_model class, together with print, summary, and plot methods
+
 # migraph 0.12.5
 
 ## Package

R/class_models.R

@@ -0,0 +1,204 @@
+#' @importFrom generics tidy
+#' @export
+generics::tidy
+
+#' @method tidy netlm
+#' @importFrom stats quantile
+#' @export
+tidy.netlm <- function(x, conf.int = FALSE, conf.level = 0.95, ...) {
+
+  result <- dplyr::tibble(term = x$names,
+                          estimate = x$coefficients,
+                          # std.error = NA_real_,
+                          statistic = x$tstat,
+                          p.value = x$pgreqabs)
+
+  if (conf.int) {
+    ci <- apply(x$dist, 2, stats::quantile, c(.025, .975))
+    ci <- cbind(data.frame(term = x$names), t(ci))
+    names(ci) <- c("term", "conf.low", "conf.high")
+    result <- dplyr::left_join(result, ci, by = "term")
+  }
+
+  result
+}
+
+#' @method tidy netlogit
+#' @importFrom stats quantile
+#' @export
+tidy.netlogit <- function(x, conf.int = FALSE, conf.level = 0.95, 
+                          exponentiate = FALSE, ...) {
+
+  result <- dplyr::tibble(term = x$names,
+                          estimate = `if`(exponentiate, 
+                                          exp(x$coefficients), 
+                                          x$coefficients),
+                          # std.error = NA_real_,
+                          statistic = x$tstat,
+                          p.value = x$pgreqabs)
+
+  if (conf.int) {
+    ci <- apply(x$dist, 2, stats::quantile, c(.025, .975))
+    ci <- cbind(data.frame(term = x$names), t(ci))
+    names(ci) <- c("term", "conf.low", "conf.high")
+    result <- dplyr::left_join(result, ci, by = "term")
+  }
+
+  result
+}
+
+#' @importFrom generics glance
+#' @export
+generics::glance
+
+#' @method glance netlm
+#' @export
+glance.netlm <- function(x, ...) {
+
+  mss <- sum((stats::fitted(x) - mean(stats::fitted(x)))^2)
+  rss <- sum(stats::resid(x)^2)
+  qn <- NROW(x$qr$qr)
+  df.int <- x$intercept
+  rdf <- qn - x$rank
+  resvar <- rss/rdf
+  fstatistic <- c(value = (mss/(x$rank - df.int))/resvar, 
+                  numdf = x$rank - df.int, 
+                  dendf = rdf)
+  r.squared <- mss/(mss + rss)
+  adj.r.squared <- 1 - (1 - r.squared) * ((qn - df.int)/rdf)
+  sigma <- sqrt(resvar)
+
+  dplyr::tibble(
+    r.squared = r.squared,
+    adj.r.squared = adj.r.squared,
+    sigma = sigma,
+    statistic = fstatistic["value"],
+    p.value = stats::pf(
+      fstatistic["value"],
+      fstatistic["numdf"],
+      fstatistic["dendf"],
+      lower.tail = FALSE
+    ),
+    df = fstatistic["numdf"],
+    # logLik = as.numeric(stats::logLik(x)),
+    # AIC = stats::AIC(x),
+    # BIC = stats::BIC(x),
+    # deviance = stats::deviance(x),
+    df.residual = stats::df.residual(x),
+    nobs = x$n
+  )
+}
+
+#' @method glance netlogit
+#' @export
+glance.netlogit <- function(x, ...) {
+
+  # mss <- sum((fitted(x) - mean(fitted(x)))^2)
+  # rss <- sum(resid(x)^2)
+  # qn <- NROW(x$qr$qr)
+  # df.int <- x$intercept
+  # rdf <- qn - x$rank
+  # resvar <- rss/rdf
+  # fstatistic <- c(value = (mss/(x$rank - df.int))/resvar, numdf = x$rank - 
+  #                   df.int, dendf = rdf)
+  # r.squared <- mss/(mss + rss)
+  # adj.r.squared <- 1 - (1 - r.squared) * ((qn - df.int)/rdf)
+  # sigma <- sqrt(resvar)
+
+  dplyr::tibble(
+    # r.squared = r.squared,
+    # adj.r.squared = adj.r.squared,
+    # sigma = sigma,
+    # statistic = fstatistic["value"],
+    # p.value = pf(
+    #   fstatistic["value"],
+    #   fstatistic["numdf"],
+    #   fstatistic["dendf"],
+    #   lower.tail = FALSE
+    # ),
+    # df = fstatistic["numdf"],
+    # logLik = as.numeric(stats::logLik(x)),
+    pseudo.r.squared = (x$null.deviance - x$deviance)/(x$null.deviance - x$deviance + 
+                                                         x$df.null),
+    AIC = x$aic,
+    AICc = x$aic + (2*x$rank^2 + 2*x$rank)/(x$n-x$rank-1),
+    BIC = x$bic,
+    chi.squared = 1 - stats::pchisq(x$null.deviance - x$deviance, 
+                                    df = x$df.null - x$df.residual),
+    deviance = x$deviance,
+    null.deviance = x$null.deviance,
+    df.residual = stats::df.residual(x),
+    nobs = x$n
+  )
+}
+
+#' @export
+plot.netlm <- function(x, ...){
+  distrib <- x$dist
+  distrib <- as.data.frame(distrib)
+  names(distrib) <- x$names
+  distrib$obs <- seq_len(nrow(distrib))
+  distrib <- tidyr::pivot_longer(distrib, 
+                                 cols = 1:(ncol(distrib)-1))
+  distrib$coef <- rep(unname(x$coefficients), nrow(x$dist))
+  distrib$tstat <- rep(unname(x$tstat), nrow(x$dist))
+  distrib$name <- factor(distrib$name, x$names)
+  ggplot2::ggplot(distrib, ggplot2::aes(.data$value, .data$name)) + 
+    ggplot2::geom_violin(draw_quantiles = c(0.025, 0.975)) + 
+    ggplot2::theme_minimal() +
+    ylab("") + xlab("Statistic") + 
+    ggplot2::geom_point(aes(x = .data$tstat), size = 2, 
+                        colour = "red") +
+    scale_y_discrete(limits=rev)
+}
+
+#' @export
+plot.netlogit <- function(x, ...){
+  distrib <- x$dist
+  distrib <- as.data.frame(distrib)
+  names(distrib) <- x$names
+  distrib$obs <- seq_len(nrow(distrib))
+  distrib <- tidyr::pivot_longer(distrib, 
+                                 cols = 1:(ncol(distrib)-1))
+  distrib$coef <- rep(unname(x$coefficients), nrow(x$dist))
+  distrib$tstat <- rep(unname(x$tstat), nrow(x$dist))
+  distrib$name <- factor(distrib$name, x$names)
+  ggplot2::ggplot(distrib, ggplot2::aes(.data$value, .data$name)) + 
+    ggplot2::geom_violin(draw_quantiles = c(0.025, 0.975)) + 
+    ggplot2::theme_minimal() +
+    ylab("") + xlab("Statistic") + 
+    ggplot2::geom_point(aes(x = .data$tstat), size = 2, 
+                        colour = "red") +
+    scale_y_discrete(limits=rev)
+}
+
+make_diff_model <- function(out, object) {
+  class(out) <- c("diff_model", class(out))
+  attr(out, "mode") <- node_mode(object)
+  out
+}
+
+#' @export
+print.diff_model <- function(x, ...){
+  print(dplyr::tibble(x))
+}
+
+
+#' @export
+summary.diff_model <- function(object, ...){
+  cum_sum <- NULL
+  ns <- length(attr(object, "mode"))
+  dplyr::count(object, t) %>% 
+    mutate(cum_sum = cumsum(n)) %>% 
+    mutate(percent = cum_sum/ns)
+}
+
+#' @export
+plot.diff_model <- function(x, ...){
+  percent <- NULL
+  y <- summary(x)
+  ggplot2::ggplot(y) + 
+    ggplot2::geom_line(aes(x = t, y = percent)) +
+    ggplot2::theme_minimal() +
+    ggplot2::ylab("Proportion") + ggplot2::xlab("Time")
+}

R/make_play.R

@@ -0,0 +1,37 @@
+#' Functions to play games on networks
+#' @inheritParams is
+#' @param seeds A valid mark vector the length of the
+#'   number of nodes in the network.
+#' @param thresholds A numeric vector indicating the thresholds
+#'   each node has. By default 1.
+#' @param steps The number of steps forward in the diffusion to play.
+#'   By default the number of nodes in the network.
+#' @examples 
+#' play_diffusion(generate_smallworld(15, 0.025))
+#' @export
+play_diffusion <- function(object, 
+                           seeds = 1:2,
+                           thresholds = 1,
+                           steps){
+  n <- network_nodes(object)
+  if(missing(steps)) steps <- n
+  if(length(thresholds)==1) thresholds <- rep(thresholds, n)
+
+  infected <- seeds
+  t = 0
+  events <- data.frame(t = t, nodes = seeds)
+
+  repeat{
+    exposed <- unlist(sapply(igraph::neighborhood(object, nodes = infected),
+                             function(x) setdiff(x, infected)))
+    tabexp <- table(exposed)
+    new <- as.numeric(names(which(tabexp > thresholds[as.numeric(names(tabexp))])))
+    if(length(new)==0) break
+    infected <- c(infected, new)
+    t <- t+1
+    events <- rbind(events, data.frame(t = t, nodes = new))
+    if(length(infected)==n) break
+    if(t==steps) break
+  }
+  make_diff_model(events, object)
+}

R/manip_add.R

@@ -108,3 +108,9 @@ join_ties <- function(object, object2, attr_name){
                        directed = is_directed(object))
 
 }
+
+#' @export
+mutate.igraph <- function(.data, ...){
+  .data %>% as_tidygraph() %>% 
+    mutate(...) %>% as_igraph()
+}

R/mark_nodes.R

@@ -63,6 +63,19 @@ node_is_core <- function(object){
   make_node_mark(out, object)
 }
 
+#' @describeIn mark_nodes Returns a logical vector
+#'   indicating a random selection of nodes as TRUE.
+#' @param size The number of nodes to select (as TRUE).
+#' @examples 
+#' node_is_random(ison_brandes, 2)
+#' @export
+node_is_random <- function(object, size = 1){
+  n <- network_nodes(object)
+  out <- rep(FALSE, n)
+  out[sample.int(n, size)] <- TRUE
+  make_node_mark(out, object)
+}
+
 #' @describeIn mark_nodes Returns logical of which nodes 
 #'   hold the maximum of some measure
 #' @param node_measure An object created by a `node_` measure.