Merge pull request #293 from stocnet/develop

v1.3.3
stocnet · Mar 7, 2024 · d58d036 · d58d036
2 parents 4082e57 + a484ecd
commit d58d036
Show file tree

Hide file tree

Showing 23 changed files with 454 additions and 57 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: migraph
 Title: Many Network Measures, Motifs, Members, and Models
-Version: 1.3.2
-Date: 2024-01-25
+Version: 1.3.3
+Date: 2024-03-06
 Description: A set of tools for analysing multimodal networks.
    It includes functions for measuring 
    centrality, centralization, cohesion, closure, constraint and diversity,
@@ -18,7 +18,7 @@ License: MIT + file LICENSE
 Language: en-GB
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.3.0
+RoxygenNote: 7.3.1
 Depends:
     R (>= 3.6.0),
     manynet

diff --git a/NAMESPACE b/NAMESPACE
@@ -136,6 +136,9 @@ export(node_automorphic_equivalence)
 export(node_betweenness)
 export(node_bridges)
 export(node_brokerage_census)
+export(node_brokering)
+export(node_brokering_activity)
+export(node_brokering_exclusivity)
 export(node_closeness)
 export(node_components)
 export(node_constraint)

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,25 @@
+# migraph 1.3.3
+
+2024-01-25
+
+## Measures
+
+- Added `node_brokering_activity()` and `node_brokering_exclusivity()` from Hamilton et al (2020)
+- `node_degree()` now returns strength centrality (alpha = 1) for weighted networks by default
+- `node_redundancy()` now works for weighted onemode and twomode networks (closed #292)
+  - Matrix operations bring an approximately sixfold speed increase compared to vapply
+- `node_effsize()` now works for weighted onemode and twomode networks
+  - Matrix operations bring an approximately sixfold speed increase compared to vapply
+- `network_equivalency()` now normalises weighted twomode networks (closed #291)
+
+## Members
+
+- Added `node_brokering()` for identifying brokering roles from brokering activity and exclusivity
+- `node_roulette()` now optimises group diversity based on historical interactions (Lai and Hao 2016)
+  - Added more documentation about maximally diverse grouping problem
+  - Matrix operations bring an approximately threefold speed increase compared to vapply
+  - Perturbation helpers can be used also for blockmodelling (closed #38)
+
 # migraph 1.3.2
 
 2024-01-25

diff --git a/R/measure_centrality.R b/R/measure_centrality.R
@@ -9,7 +9,7 @@
 #'   or weighted degree/strength of nodes in a weighted network; 
 #'   there are several related shortcut functions:
 #'     - `node_deg()` returns the unnormalised results.
-#'     - `node_indegree()` returns the `direction = 'out'` results.
+#'     - `node_indegree()` returns the `direction = 'in'` results.
 #'     - `node_outdegree()` returns the `direction = 'out'` results.
 #'   - `node_multidegree()` measures the ratio between types of ties in a multiplex network.
 #'   - `node_posneg()` measures the PN (positive-negative) centrality of a signed network.
@@ -90,7 +90,7 @@ NULL
 #' @rdname degree_centrality 
 #' @importFrom manynet as_igraph
 #' @export
-node_degree <- function (.data, normalized = TRUE, alpha = 0,
+node_degree <- function (.data, normalized = TRUE, alpha = 1,
                          direction = c("all","out","in")){
 
   if(missing(.data)) {expect_nodes(); .data <- .G()}

diff --git a/R/measure_closure.R b/R/measure_closure.R
@@ -80,7 +80,11 @@ node_transitivity <- function(.data) {
                     .data)
 }
 
-#' @rdname closure 
+#' @rdname closure
+#' @section Equivalency: 
+#'   The `network_equivalency()` function calculates the Robins and Alexander (2004) 
+#'   clustering coefficient for two-mode networks.
+#'   Note that for weighted two-mode networks, the result is divided by the average tie weight.
 #' @examples
 #' network_equivalency(ison_southern_women)
 #' @export
@@ -96,6 +100,7 @@ network_equivalency <- function(.data) {
          sum(twopaths *
              (matrix(indegrees, c, c) - twopaths)))
     if (is.nan(output)) output <- 1
+    if(manynet::is_weighted(.data)) output <- output / mean(mat[mat>0])
   } else stop("This function expects a two-mode network")
   make_network_measure(output, .data)
 }

diff --git a/R/measure_holes.R b/R/measure_holes.R
@@ -62,39 +62,73 @@ node_bridges <- function(.data){
 #' Borgatti, Steven. 1997. 
 #' “\href{http://www.analytictech.com/connections/v20(1)/holes.htm}{Structural Holes: Unpacking Burt’s Redundancy Measures}” 
 #' _Connections_ 20(1):35-38.
+#' 
+#' Burchard, Jake, and Benjamin Cornwell. 2018. 
+#' “Structural Holes and Bridging in Two-Mode Networks.” 
+#' _Social Networks_ 55:11–20. 
+#' \doi{10.1016/j.socnet.2018.04.001.}
 #' @examples 
 #' node_redundancy(ison_adolescents)
 #' node_redundancy(ison_southern_women)
 #' @export
 node_redundancy <- function(.data){
-  g <- manynet::as_igraph(.data)
-  .inc <- NULL
-  out <- vapply(igraph::V(g), function(ego){
-    n = igraph::neighbors(g, ego)
-    t = length(igraph::E(g)[.inc(n) & !.inc(ego)])
-    n = length(n)
-    2 * t / n
-  }, FUN.VALUE = numeric(1))
+  if(manynet::is_twomode(.data)){
+    mat <- manynet::as_matrix(.data)
+    out <- c(.redund2(mat), .redund2(t(mat)))
+  } else {
+    out <- .redund(manynet::as_matrix(.data))
+  }
   make_node_measure(out, .data)
 }
 
+.redund <- function(.mat){
+  n <- nrow(.mat)
+  qs <- .twopath_matrix(.mat > 0)
+  piq <- .mat/rowSums(.mat)
+  mjq <- .mat/matrix(do.call("pmax",data.frame(.mat)),n,n)
+  out <- rowSums(qs * piq * mjq)
+  out
+}
+
+.redund2 <- function(.mat){
+  sigi <- .mat %*% t(.mat)
+  diag(sigi) <- 0
+  vapply(seq.int(nrow(sigi)), 
+         function(x){
+           xvec <- sigi[x,] #> 0
+           if(manynet::is_weighted(.mat)){
+             wt <- colMeans((.mat[x,] > 0 * t(.mat[xvec > 0,])) * t(.mat[xvec > 0,]) + .mat[x,]) * 2  
+           } else wt <- 1
+           sum(colSums(xvec > 0 & t(sigi[xvec > 0,])) * xvec[xvec > 0] / 
+                 (sum(xvec) * wt))
+         }, FUN.VALUE = numeric(1))
+}
+
 #' @rdname holes 
 #' @examples 
 #' node_effsize(ison_adolescents)
 #' node_effsize(ison_southern_women)
 #' @export
 node_effsize <- function(.data){
-  g <- manynet::as_igraph(.data)
-  .inc <- NULL
-  out <- vapply(igraph::V(g), function(ego){
-    n = igraph::neighbors(g, ego)
-    t = length(igraph::E(g)[.inc(n) & !.inc(ego)])
-    n = length(n)
-    n - 2 * t / n
-  }, FUN.VALUE = numeric(1))
+  if(manynet::is_twomode(.data)){
+    mat <- manynet::as_matrix(.data)
+    out <- c(rowSums(manynet::as_matrix(manynet::to_mode1(.data))>0), 
+             rowSums(manynet::as_matrix(manynet::to_mode2(.data))>0)) - node_redundancy(.data)
+  } else {
+    mat <- manynet::as_matrix(.data)
+    out <- rowSums(mat>0) - .redund(mat)
+  }
   make_node_measure(out, .data)
 }
 
+.twopath_matrix <- function(.data){
+  .data <- manynet::as_matrix(.data)
+  qs <- .data %*% t(.data)
+  diag(qs) <- 0
+  qs
+}
+
+
 #' @rdname holes 
 #' @examples 
 #' node_efficiency(ison_adolescents)

diff --git a/R/member_cliques.R b/R/member_cliques.R
@@ -0,0 +1,128 @@
+#' Clique partitioning algorithms
+#' 
+#' @description 
+#'   These functions create a vector of nodes' memberships in
+#'   cliques:
+#'   
+#'   - `node_roulette()` assigns nodes to maximally diverse groups.
+#'   
+#' @section Maximally diverse grouping problem: 
+#'   This well known computational problem is a NP-hard problem
+#'   with a number of relevant applications, 
+#'   including the formation of groups of students that have encountered
+#'   each other least or least recently.
+#'   Essentially, the aim is to return a membership of nodes in cliques
+#'   that minimises the sum of their previous (weighted) ties:
+#'   
+#'   \deqn{\sum_{g=1}^{m} \sum_{i=1}^{n-1} \sum_{j=i+1}^{n} x_{ij} y_{ig} y_{jg}}
+#'   
+#'   where \eqn{y_{ig} = 1} if node \eqn{i} is in group \eqn{g}, and 0 otherwise.
+#'   
+#'   \eqn{x_{ij}} is the existing network data.
+#'   If this is an empty network, the function will just return cliques.
+#'   To run this repeatedly, one can join a clique network of the membership result
+#'   with the original network, using this as the network data for the next round.
+#' 
+#'   A form of the Lai and Hao (2016) iterated maxima search (IMS) is used here.
+#'   This performs well for small and moderately sized networks.
+#'   It includes both weak and strong perturbations to an initial solution
+#'   to ensure that a robust solution from the broader state space is identified.
+#'   The user is referred to Lai and Hao (2016) and Lai et al (2021) for more details.
+#' @inheritParams cohesion
+#' @name cliques
+#' @family memberships
+NULL
+
+#' @rdname cliques
+#' @param num_groups An integer indicating the number of groups desired.
+#' @param group_size An integer indicating the desired size of most of the groups.
+#'   Note that if the number of nodes is not divisible into groups of equal size,
+#'   there may be some larger or smaller groups.
+#' @param times An integer of the number of search iterations the algorithm should complete.
+#'   By default this is the number of nodes in the network multiplied by the number of groups.
+#'   This heuristic may be insufficient for small networks and numbers of groups,
+#'   and burdensome for large networks and numbers of groups, but can be overwritten.
+#'   At every 10th iteration, a stronger perturbation of a number of successive changes,
+#'   approximately the number of nodes divided by the number of groups,
+#'   will take place irrespective of whether it improves the objective function.
+#' @references
+#' Lai, Xiangjing, and Jin-Kao Hao. 2016. 
+#' “Iterated Maxima Search for the Maximally Diverse Grouping Problem.” 
+#' _European Journal of Operational Research_ 254(3):780–800. 
+#' \doi{10.1016/j.ejor.2016.05.018}.
+#' 
+#' Lai, Xiangjing, Jin-Kao Hao, Zhang-Hua Fu, and Dong Yue. 2021. 
+#' “Neighborhood Decomposition Based Variable Neighborhood Search and Tabu Search for Maximally Diverse Grouping.” 
+#' _European Journal of Operational Research_ 289(3):1067–86. 
+#' \doi{10.1016/j.ejor.2020.07.048}.
+#' @export
+node_roulette <- function(.data, num_groups, group_size, times = NULL){
+  if(missing(num_groups) & missing(group_size)){
+    stop(paste("Either `num_groups` must indicate number of groups desired",
+               "or `group_size` must indicate the desired average size of groups."))
+  }
+  n <- manynet::network_nodes(.data)
+  my_vec <- sample(seq.int(n))
+  # Initial partition
+  if(!missing(num_groups)){
+    out <- cut(seq_along(my_vec), num_groups, labels = FALSE)[my_vec]
+  } else {
+    out <- ceiling(seq_along(my_vec) / group_size)[my_vec]
+  }
+  if(is.null(times)) times <- n * max(out)
+  # Get fitness
+  mat <- manynet::as_matrix(.data)
+  fit <- sum(.to_cliques(out) * mat)
+  soln <- out
+  for(t in seq.int(times)){
+    soln <- .weakPerturb(soln)
+    new_fit <- sum(.to_cliques(soln) * mat)
+    if(new_fit < fit){
+      out <- soln
+      fit <- new_fit
+    } 
+    if(t %% 10) soln <- .strongPerturb(soln)
+  }
+  make_node_member(out, .data)
+}
+
+.to_cliques <- function(member){
+  (member == t(matrix(member, length(member), length(member))))*1
+}
+
+.weakPerturb <- function(soln){
+  gsizes <- table(soln)
+  evens <- all(gsizes == max(gsizes))
+  if(evens){
+    soln <- .swapMove(soln)
+  } else {
+    if(stats::runif(1)<0.5) soln <- .swapMove(soln) else 
+      soln <- .oneMove(soln)
+  }
+  soln
+}
+
+.swapMove <- function(soln){
+  from <- sample(seq.int(length(soln)), 1)
+  to <- sample(which(soln != soln[from]), 1)
+  soln[c(to,from)] <- soln[c(from,to)]
+  soln
+}
+
+.oneMove <- function(soln){
+  gsizes <- table(soln)
+  maxg <- which(gsizes == max(gsizes))
+  from <- sample(which(soln %in% maxg), 1)
+  soln[from] <- sample(which(gsizes != max(gsizes)), 1)
+  soln
+}
+
+.strongPerturb <- function(soln, strength = 1){
+  times <- ceiling(strength * length(soln)/max(soln))
+  for (t in seq.int(times)){
+    soln <- .weakPerturb(soln)
+  }
+  soln
+}
+
+
diff --git a/R/member_components.R b/R/member_components.R
@@ -62,23 +62,5 @@ node_strong_components <- function(.data){
                  .data)
 }
 
-#' @rdname components
-#' @param num_groups An integer indicating the number of groups desired
-#' @param group_size An integer indicating the desired size of most of the groups
-#' @export
-node_roulette <- function(.data, num_groups, group_size){
-  if(missing(num_groups) & missing(group_size)){
-    stop(paste("Either `num_groups` must indicate number of groups desired",
-               "or `group_size` must indicate the desired average size of groups."))
-  }
-  n <- manynet::network_nodes(.data)
-  my_vec <- sample(seq.int(n))
-  if(!missing(num_groups)){
-    out <- cut(seq_along(my_vec), num_groups, labels = FALSE)[my_vec]
-  } else {
-    out <- ceiling(seq_along(my_vec) / group_size)[my_vec]
-  }
-  make_node_member(out, .data)
-}