From 4743cb2a6dff08f51a82571ae528f99e1a15218d Mon Sep 17 00:00:00 2001 From: James Hollway Date: Tue, 8 Sep 2026 19:08:48 +0200 Subject: [PATCH 1/4] Fixed some community issues --- DESCRIPTION | 2 +- NEWS.md | 9 ++++++ R/member_community.R | 36 +++++++++++++++------ man/member_community_non.Rd | 11 +++++-- tests/testthat/test-member_community.R | 45 ++++++++++++++++++++++++++ 5 files changed, 91 insertions(+), 12 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3ea744b..3122d96 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: netrics Title: Many Marks, Measures, Memberships, and Motifs for Networks -Version: 1.0.2 +Version: 1.0.3 Description: Many tools for calculating network, node, or tie marks, measures, motifs and memberships of many different types of networks. Marks identify structural positions, measures quantify network properties, diff --git a/NEWS.md b/NEWS.md index 1dd5ff1..c8da205 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,12 @@ +# netrics 1.0.3 + +## Memberships + +- Fixed `node_in_leiden()` returning a community for every node on an unweighted network +- Fixed `node_in_leiden()` overriding a user's `resolution` +- Fixed `node_in_community()`, `node_in_spinglass()` and `node_in_fluid()` treating a + weakly connected directed network as unconnected + # netrics 1.0.2 ## Package diff --git a/R/member_community.R b/R/member_community.R index 3d76b10..256b172 100644 --- a/R/member_community.R +++ b/R/member_community.R @@ -173,7 +173,10 @@ poss_algs <- function(k, .data){ } if(manynet::net_nodes(.data) >= 100) poss <- exclude(poss, "node_in_betweenness", "network rather large") - if(!manynet::is_connected(.data)) + # Both algorithms read the network as undirected, so weak connectivity is + # what they need. The default test is for strong connectivity, which drops + # them from a directed network that they can in fact partition. + if(!manynet::is_connected(.data, connectivity = "weak")) poss <- exclude(poss, c("node_in_spinglass", "node_in_fluid"), "network unconnected") # Every algorithm but spinglass reads a negative weight as an error, and @@ -523,6 +526,9 @@ node_in_infomap <- function(.data, times = 50){ #' By default 1, making existing and non-existing ties equally important. #' Smaller values make existing ties more important, #' and larger values make missing ties more important. +#' `node_in_leiden()` takes `NULL` by default, and then uses the density of +#' the network, since the Constant Potts Model gives every node its own +#' community at any higher resolution. #' @section Spin-glass: #' Here `max_k` is the number of spins, an upper limit on the communities #' found rather than a bound on a search, so some can end up empty. @@ -552,10 +558,10 @@ node_in_infomap <- function(.data, times = 50){ node_in_spinglass <- function(.data, max_k = 200, resolution = 1){ .data <- manynet::expect_nodes(.data) # `snet_unavailable()` is silent unless verbosity is raised, so this was a - # branch that returned NULL rather than a membership. Note also that - # `manynet::is_connected()` returns FALSE for a two-mode network, so the - # test is made with igraph. - if(!igraph::is_connected(manynet::as_igraph(.data))) + # branch that returned NULL rather than a membership. The algorithm reads the + # network as undirected, so the test is for weak connectivity, as in + # `poss_algs()`. + if(!manynet::is_connected(.data, connectivity = "weak")) manynet::snet_abort("This algorithm only works for connected networks.", "We suggest using {.fn to_giant}", "to select the largest component.") @@ -589,7 +595,9 @@ node_in_fluid <- function(.data, k = NULL, max_k = 8L, Kmax = NULL) { k <- check_k(k, .data) .data <- manynet::as_igraph(.data) # As in `node_in_spinglass()`: this must abort, or the function returns NULL. - if (!igraph::is_connected(.data)) { + # The algorithm reads the network as undirected, so the test is for weak + # connectivity. + if (!manynet::is_connected(.data, connectivity = "weak")) { manynet::snet_abort("This algorithm only works for connected networks.", "We suggest using {.fn to_giant}", "to select the largest component.") @@ -670,6 +678,10 @@ node_in_louvain <- function(.data, k = NULL, max_k = 8L, resolution = 1, Kmax = #' _i_ and _j_ are in the same communities and 0 otherwise. #' Compared to the Louvain method, the Leiden algorithm additionally #' tries to avoid unconnected communities. +#' The resolution is the density of the network by default, after Traag et al., +#' since the Constant Potts Model gives every node its own community at any +#' higher resolution. This holds for an unweighted network too, +#' where each tie weighs 1. #' Where `k` is given, the resolution parameter is searched for the value #' that returns that number of communities, and `resolution` is ignored. #' @references @@ -681,7 +693,7 @@ node_in_louvain <- function(.data, k = NULL, max_k = 8L, resolution = 1, Kmax = #' @examples #' node_in_leiden(ison_adolescents) #' @export -node_in_leiden <- function(.data, k = NULL, max_k = 8L, resolution = 1, Kmax = NULL){ +node_in_leiden <- function(.data, k = NULL, max_k = 8L, resolution = NULL, Kmax = NULL){ max_k <- resolve_max_k(max_k, Kmax) .data <- manynet::expect_nodes(.data) k <- check_k(k, .data) @@ -690,9 +702,15 @@ node_in_leiden <- function(.data, k = NULL, max_k = 8L, resolution = 1, Kmax = N "Converting to undirected") .data <- manynet::to_undirected(.data) } - if(is.null(k) && manynet::is_weighted(.data)){ # Traag resolution default + # The Constant Potts Model gives every node its own community at any + # resolution above the network density, so a fixed 1 returns singletons on + # every network that is not near complete. The density is the Traag default, + # and it holds for an unweighted network too, where each tie weighs 1. + if(is.null(resolution)){ n <- manynet::net_nodes(.data) - resolution <- sum(manynet::tie_weights(.data))/(n*(n - 1)/2) + pairs <- n*(n - 1)/2 + resolution <- if(pairs > 0) + sum(manynet::tie_weights(.data))/pairs else 1 } gr <- manynet::as_igraph(.data) memb <- apply_k(k, max_k, .data, diff --git a/man/member_community_non.Rd b/man/member_community_non.Rd index cee4e02..3772fae 100644 --- a/man/member_community_non.Rd +++ b/man/member_community_non.Rd @@ -24,7 +24,7 @@ node_in_fluid(.data, k = NULL, max_k = 8L, Kmax = NULL) node_in_louvain(.data, k = NULL, max_k = 8L, resolution = 1, Kmax = NULL) -node_in_leiden(.data, k = NULL, max_k = 8L, resolution = 1, Kmax = NULL) +node_in_leiden(.data, k = NULL, max_k = 8L, resolution = NULL, Kmax = NULL) node_in_labels(.data, k = NULL, max_k = 8L, Kmax = NULL) } @@ -66,7 +66,10 @@ so each function documents its own default.} \item{resolution}{The Reichardt-Bornholdt “gamma” resolution parameter for modularity. By default 1, making existing and non-existing ties equally important. Smaller values make existing ties more important, -and larger values make missing ties more important.} +and larger values make missing ties more important. +\code{node_in_leiden()} takes \code{NULL} by default, and then uses the density of +the network, since the Constant Potts Model gives every node its own +community at any higher resolution.} } \value{ A \code{node_member} character vector the length of the nodes in the network, @@ -183,6 +186,10 @@ and \eqn{\delta(\sigma_i, \sigma_j) = 1} if and only if \emph{i} and \emph{j} are in the same communities and 0 otherwise. Compared to the Louvain method, the Leiden algorithm additionally tries to avoid unconnected communities. +The resolution is the density of the network by default, after Traag et al., +since the Constant Potts Model gives every node its own community at any +higher resolution. This holds for an unweighted network too, +where each tie weighs 1. Where \code{k} is given, the resolution parameter is searched for the value that returns that number of communities, and \code{resolution} is ignored. } diff --git a/tests/testthat/test-member_community.R b/tests/testthat/test-member_community.R index f6a473c..e29b45f 100644 --- a/tests/testthat/test-member_community.R +++ b/tests/testthat/test-member_community.R @@ -151,3 +151,48 @@ test_that("node_in_community ignores consensus where optimal is available", { expect_equal(as.character(suppressMessages(node_in_community(small, consensus = TRUE))), as.character(suppressMessages(node_in_optimal(small)))) }) + +# Resolution and connectivity #### + +test_that("node_in_leiden resolution defaults to the density", { + # a fixed resolution of 1 gave every node its own community here + for(net in list(ison_adolescents, ison_southern_women)){ + set.seed(1234) + res <- node_in_leiden(net) + expect_s3_class(res, "node_member") + expect_gte(length(unique(res)), 2) + expect_lt(length(unique(res)), net_nodes(net)) + } + # a weighted network keeps the default it already had + set.seed(1234) + expect_lt(length(unique(node_in_leiden(ison_karateka))), + net_nodes(ison_karateka)) +}) + +test_that("node_in_leiden respects a given resolution", { + set.seed(1234) + expect_equal(length(unique(node_in_leiden(ison_adolescents, resolution = 1))), + as.integer(net_nodes(ison_adolescents))) + set.seed(1234) + expect_equal(length(unique(node_in_leiden(ison_adolescents, resolution = 1e-6))), 1) +}) + +test_that("a weakly connected network is not treated as unconnected", { + # a directed tree is weakly but not strongly connected + tree <- manynet::create_tree(10, directed = TRUE) + expect_false(manynet::is_connected(tree)) + expect_true(manynet::is_connected(tree, connectivity = "weak")) + set.seed(1234) + expect_s3_class(node_in_spinglass(tree), "node_member") + expect_s3_class(node_in_fluid(tree), "node_member") + expect_true(all(c("node_in_spinglass", "node_in_fluid") %in% + poss_algs(NULL, tree))) +}) + +test_that("an unconnected network still drops the algorithms that need one", { + unconn <- manynet::create_components(8, membership = c(1,1,1,1,2,2,2,2)) + expect_snet_abort(node_in_spinglass(unconn), "connected") + expect_snet_abort(node_in_fluid(unconn), "connected") + expect_false(any(c("node_in_spinglass", "node_in_fluid") %in% + poss_algs(NULL, unconn))) +}) From 31c569d34a7ba99b5ec5eb8a4efa96dd3098228b Mon Sep 17 00:00:00 2001 From: James Hollway Date: Wed, 9 Sep 2026 07:43:56 +0200 Subject: [PATCH 2/4] Fixed `node_in_partition()` returning a split it had already improved upon --- NEWS.md | 6 +- R/member_community.R | 87 ++++++++++++++++++++------ man/member_community_non.Rd | 29 +++++++-- tests/testthat/test-member_community.R | 27 +++++++- 4 files changed, 121 insertions(+), 28 deletions(-) diff --git a/NEWS.md b/NEWS.md index c8da205..d1c12a4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,8 +4,10 @@ - Fixed `node_in_leiden()` returning a community for every node on an unweighted network - Fixed `node_in_leiden()` overriding a user's `resolution` -- Fixed `node_in_community()`, `node_in_spinglass()` and `node_in_fluid()` treating a - weakly connected directed network as unconnected +- Fixed `node_in_community()`, `node_in_spinglass()` and `node_in_fluid()` + treating a weakly connected directed network as unconnected +- Fixed `node_in_partition()` returning a split it had already improved upon + - Added `start=` for a random rather than a node-order initialisation # netrics 1.0.2 diff --git a/R/member_community.R b/R/member_community.R index 256b172..b56e208 100644 --- a/R/member_community.R +++ b/R/member_community.R @@ -420,12 +420,26 @@ node_in_optimal <- function(.data){ #' where the net tie cost of a node is the difference between the sum #' of the weights of ties to nodes in the other group (external costs) and #' the sum of the weights of ties to nodes in the same group (internal costs). +#' A pass exchanges the candidate pairs one at a time and keeps the prefix +#' that leaves the most weight inside the two groups, so a pass never returns +#' a worse split than it started from. #' Where `k` is greater than two, the same swap pass is run for every pair of -#' groups, and the rounds repeat until no swap improves the partition. -#' This is a deterministic algorithm that will always return the same partition -#' for a given network, but it is not guaranteed to maximise modularity. +#' groups, and the rounds repeat until no pass improves the partition. +#' Where `start = "order"`, the default, the nodes are dealt into the groups +#' in node order, and the algorithm is deterministic: one network returns one +#' partition. Where `start = "random"` they are dealt at random, which is the +#' textbook start, and repeated calls can then return different partitions. +#' The result is not guaranteed to maximise modularity either way, since the +#' algorithm reads the weight of the ties inside the groups and not the +#' modularity, and since it holds the groups at equal size. #' Note that this algorithm is only applicable to undirected, unipartite networks, #' and returns `k` communities of equal size (or as close to equal as possible). +#' @param start One of `"order"` (the default) or `"random"`, +#' naming how the nodes are dealt into the groups to begin with. +#' `"order"` deals them in node order, which makes the algorithm +#' deterministic. `"random"` deals them at random, as Kernighan and Lin do. +#' Since the algorithm is sensitive to where it starts, a random start can +#' reach a different partition; set a seed to repeat one. #' @references #' ## On partitioning community detection #' Kernighan, Brian W., and Shen Lin. 1970. @@ -436,21 +450,30 @@ node_in_optimal <- function(.data){ #' node_in_partition(ison_adolescents) #' node_in_partition(ison_southern_women) #' @export -node_in_partition <- function(.data, k = 2L, max_k = 8L, Kmax = NULL){ +node_in_partition <- function(.data, k = 2L, max_k = 8L, + start = c("order", "random"), Kmax = NULL){ max_k <- resolve_max_k(max_k, Kmax) + start <- match.arg(start) .data <- manynet::expect_nodes(.data) k <- check_k(k, .data) n <- manynet::net_nodes(.data) g <- manynet::as_matrix(manynet::to_multilevel(.data)) - at_k <- function(no) kl_partition(g, n, no) + at_k <- function(no) kl_partition(g, n, no, start = start) memb <- apply_k(k, max_k, .data, at_k = at_k, default = function() at_k(2L)) make_node_member(memb, .data) } +# The weight of the ties that fall inside a group. +kl_internal <- function(g, a) sum(g[a, a, drop = FALSE]) + # One pass of net-cost swaps between two groups. # The net cost of a node is the sum of the weights of its ties to the other # group (external) less the sum of the weights of its ties within its own -# group (internal). Pairs whose net costs sum to zero or more are swapped. +# group (internal). The nodes of each group are ranked by that cost, and the +# pairs whose costs sum to zero or more are the candidates to exchange. +# The candidates are returned in rank order rather than applied, so that +# `kl_partition()` can exchange them one at a time and keep the prefix that +# leaves the most weight inside the groups, as Kernighan and Lin do. kl_swap <- function(g, a, b){ intergroup <- g[a, b, drop = FALSE] a.net <- rowSums(intergroup) - rowSums(g[a, a, drop = FALSE]) @@ -460,28 +483,52 @@ kl_swap <- function(g, a, b){ a.sort <- sort(a.net, decreasing = TRUE) b.sort <- sort(b.net, decreasing = TRUE) len <- min(length(a.sort), length(b.sort)) - if(len == 0) return(list(a = a, b = b, swapped = FALSE)) + if(len == 0) return(list(a = a.ord, b = b.ord, index = integer(0))) index <- which(a.sort[seq_len(len)] + b.sort[seq_len(len)] >= 0) - if(length(index) == 0) return(list(a = a, b = b, swapped = FALSE)) - a.new <- a.ord - b.new <- b.ord - a.new[index] <- b.ord[index] - b.new[index] <- a.ord[index] - list(a = a.new, b = b.new, swapped = TRUE) + list(a = a.ord, b = b.ord, index = index) } -# k-way Kernighan-Lin. Nodes start in k groups of near-equal size, in node -# order, and every pair of groups is swept until no round makes a swap. -kl_partition <- function(g, n, k, rounds = 50){ - memb <- sort(rep(seq_len(k), length.out = n)) +# k-way Kernighan-Lin. Nodes start in k groups of near-equal size, and every +# pair of groups is swept until no round improves the split. +# +# A pass exchanges the candidate pairs one at a time and keeps the prefix that +# leaves the most weight inside the two groups. This is what Kernighan and Lin +# do, and it is what makes the algorithm terminate. Taking every candidate +# pair, as this function did before, takes exchanges that gain nothing, since +# a pair of net costs that sums to exactly zero still qualifies. The split +# could then cycle, and the run returned wherever the cap of `rounds` left it, +# which could be worse than a split the same run had already reached. Keeping +# the best prefix leaves the weight inside the groups strictly rising, so the +# last split is the best split, and a round that finds no gain ends the run. +kl_partition <- function(g, n, k, rounds = 50, start = "order"){ + memb <- if(identical(start, "random")) + sample(sort(rep(seq_len(k), length.out = n))) else + sort(rep(seq_len(k), length.out = n)) groups <- lapply(seq_len(k), function(i) which(memb == i)) for(r in seq_len(rounds)){ moved <- FALSE for(i in seq_len(k)) for(j in seq_len(k)) if(i < j){ res <- kl_swap(g, groups[[i]], groups[[j]]) - if(res$swapped){ - groups[[i]] <- res$a - groups[[j]] <- res$b + if(length(res$index) == 0) next + a <- res$a + b <- res$b + best.a <- a + best.b <- b + best.w <- kl_internal(g, a) + kl_internal(g, b) + for(m in res$index){ + swap <- a[m] + a[m] <- b[m] + b[m] <- swap + w <- kl_internal(g, a) + kl_internal(g, b) + if(w > best.w){ + best.w <- w + best.a <- a + best.b <- b + } + } + if(!identical(sort(best.a), sort(groups[[i]]))){ + groups[[i]] <- best.a + groups[[j]] <- best.b moved <- TRUE } } diff --git a/man/member_community_non.Rd b/man/member_community_non.Rd index 3772fae..9ff43b8 100644 --- a/man/member_community_non.Rd +++ b/man/member_community_non.Rd @@ -14,7 +14,13 @@ \usage{ node_in_optimal(.data) -node_in_partition(.data, k = 2L, max_k = 8L, Kmax = NULL) +node_in_partition( + .data, + k = 2L, + max_k = 8L, + start = c("order", "random"), + Kmax = NULL +) node_in_infomap(.data, times = 50) @@ -53,6 +59,13 @@ Note that for \code{node_in_louvain()} and \code{node_in_leiden()} each candidat requires its own search over the resolution parameter, so a large \code{max_k} is costly on large networks.} +\item{start}{One of \code{"order"} (the default) or \code{"random"}, +naming how the nodes are dealt into the groups to begin with. +\code{"order"} deals them in node order, which makes the algorithm +deterministic. \code{"random"} deals them at random, as Kernighan and Lin do. +Since the algorithm is sensitive to where it starts, a random start can +reach a different partition; set a seed to repeat one.} + \item{Kmax}{Deprecated. The former spelling of \code{max_k}. Still accepted, but warns; please use \code{max_k} instead.} @@ -117,10 +130,18 @@ swap pairs of nodes (one from each group) that give a positive sum of net tie co where the net tie cost of a node is the difference between the sum of the weights of ties to nodes in the other group (external costs) and the sum of the weights of ties to nodes in the same group (internal costs). +A pass exchanges the candidate pairs one at a time and keeps the prefix +that leaves the most weight inside the two groups, so a pass never returns +a worse split than it started from. Where \code{k} is greater than two, the same swap pass is run for every pair of -groups, and the rounds repeat until no swap improves the partition. -This is a deterministic algorithm that will always return the same partition -for a given network, but it is not guaranteed to maximise modularity. +groups, and the rounds repeat until no pass improves the partition. +Where \code{start = "order"}, the default, the nodes are dealt into the groups +in node order, and the algorithm is deterministic: one network returns one +partition. Where \code{start = "random"} they are dealt at random, which is the +textbook start, and repeated calls can then return different partitions. +The result is not guaranteed to maximise modularity either way, since the +algorithm reads the weight of the ties inside the groups and not the +modularity, and since it holds the groups at equal size. Note that this algorithm is only applicable to undirected, unipartite networks, and returns \code{k} communities of equal size (or as close to equal as possible). } diff --git a/tests/testthat/test-member_community.R b/tests/testthat/test-member_community.R index e29b45f..d6cc622 100644 --- a/tests/testthat/test-member_community.R +++ b/tests/testthat/test-member_community.R @@ -105,9 +105,32 @@ test_that("an unreachable k warns and returns the nearest", { test_that("node_in_partition preserves its two-group result", { expect_equal(unname(as.character(node_in_partition(ison_adolescents))), - c("B","A","A","A","B","B","A","B")) + c("B","A","A","A","A","B","B","B")) expect_equal(unname(as.character(node_in_partition(ison_adolescents, k = 2))), - c("B","A","A","A","B","B","A","B")) + c("B","A","A","A","A","B","B","B")) +}) + +test_that("node_in_partition keeps the best split a pass reaches", { + # Taking every candidate pair took exchanges that gained nothing, so the + # split could cycle and the round cap returned wherever it stopped. The + # weight inside the groups now rises with every pass. + g <- as_matrix(ison_adolescents) + memb <- as.character(node_in_partition(ison_adolescents)) + within <- function(m) sum(g[which(m == "A"), which(m == "A")]) + + sum(g[which(m == "B"), which(m == "B")]) + expect_gt(within(memb), within(c("B","A","A","A","B","B","A","B"))) + expect_gt(net_by_modularity(ison_adolescents, memb), 0) +}) + +test_that("node_in_partition takes a random start", { + set.seed(1234) + res <- node_in_partition(ison_karateka, start = "random") + expect_s3_class(res, "node_member") + expect_equal(length(unique(res)), 2) + expect_equal(as.integer(table(as.character(res))), c(17L, 17L)) + # the order start stays deterministic + expect_equal(as.character(node_in_partition(ison_karateka)), + as.character(node_in_partition(ison_karateka))) }) test_that("node_in_community accepts k", { From eedd1f778c36503be5140c9385965e110b55ecb8 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Wed, 9 Sep 2026 16:49:20 +0200 Subject: [PATCH 3/4] Fixed issues with net and node homophily, net and node diversity, and net_by_spatial --- NEWS.md | 18 ++- R/measure_heterogeneity.R | 158 ++++++++++++++------ man/measure_assort_net.Rd | 35 ++++- man/measure_assort_node.Rd | 4 + man/measure_diverse_net.Rd | 14 ++ tests/testthat/test-measure_heterogeneity.R | 81 ++++++++++ 6 files changed, 256 insertions(+), 54 deletions(-) diff --git a/NEWS.md b/NEWS.md index d1c12a4..32fa8fb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,23 @@ # netrics 1.0.3 +## Measures + +- Fixed two `node_by_homophily()` issues + - It was reading a vector attribute against the wrong nodes + - It was reporting the E-I index where it computed Geary's C +- Fixed `net_by_homophily()` discarding tie weights before Geary's C + - Geary's C now declares that on a weighted network, it can exceed 2 +- Fixed `net_by_spatial()` erroring on a two-mode network + - For one-mode attributes, projection is used + - For multimodal attributes, the multilevel matrix is read instead +- Fixed `net_by_spatial()` propogating missing values +- Fixed `net_by_diversity()` and `node_by_diversity()` erroring on a factor attribute + ## Memberships -- Fixed `node_in_leiden()` returning a community for every node on an unweighted network -- Fixed `node_in_leiden()` overriding a user's `resolution` +- Fixed two `node_in_leiden()` issues + - It was returning a community for every node on an unweighted network + - It was overriding a user's `resolution` - Fixed `node_in_community()`, `node_in_spinglass()` and `node_in_fluid()` treating a weakly connected directed network as unconnected - Fixed `node_in_partition()` returning a split it had already improved upon diff --git a/R/measure_heterogeneity.R b/R/measure_heterogeneity.R index 0f51413..c7ee6c8 100644 --- a/R/measure_heterogeneity.R +++ b/R/measure_heterogeneity.R @@ -48,18 +48,28 @@ net_by_richness <- function(.data, attribute){ #' @section Diversity: #' Blau's index (1977) uses a formula known also in other disciplines #' by other names -#' (Gini-Simpson Index, Gini impurity, Gini's diversity index, -#' Gibbs-Martin index, and probability of interspecific encounter (PIE)): -#' \deqn{1 - \sum\limits_{i = 1}^k {p_i^2 }} -#' where \eqn{p_i} is the proportion of group members in \eqn{i}th category -#' and \eqn{k} is the number of categories for an attribute of interest. -#' This index can be interpreted as the probability that two members -#' randomly selected from a group would be from different categories. -#' This index finds its minimum value (0) when there is no variety, -#' i.e. when all individuals are classified in the same category. -#' The maximum value depends on the number of categories and +#' (Gini-Simpson Index, Gini impurity, Gini's diversity index, +#' Gibbs-Martin index, and probability of interspecific encounter (PIE)): +#' \deqn{1 - \sum\limits_{i = 1}^k {p_i^2 }} +#' where \eqn{p_i} is the proportion of group members in \eqn{i}th category +#' and \eqn{k} is the number of categories for an attribute of interest. +#' This index can be interpreted as the probability that two members +#' randomly selected from a group would be from different categories. +#' This index finds its minimum value (0) when there is no variety, +#' i.e. when all individuals are classified in the same category. +#' The maximum value depends on the number of categories and #' whether nodes can be evenly distributed across categories. -#' +#' +#' The Herfindahl-Hirschman index (HHI) is the complement of Blau's index, +#' \eqn{\sum\limits_{i = 1}^k {p_i^2}}, +#' and so `1 - net_by_diversity(.data, attribute)` returns it. +#' Where shares are stated as percentages rather than proportions, +#' as in the `{hhi}` package, +#' the index runs from 0 to 10000 and equals `(1 - blau) * 10000`. +#' Both readings hold for a categorical attribute, +#' where a share is the frequency of a category, +#' which is why neither index is offered for a numeric one. +#' #' Teachman's index (1980) is based on information theory #' and is calculated as: #' \deqn{- \sum\limits_{i = 1}^k {p_i \log(p_i)}} @@ -110,10 +120,14 @@ net_by_richness <- function(.data, attribute){ #' _Sociological Methods & Research_, 8:341-362. #' \doi{10.1177/004912418000800305} #' -#' Page, Scott E. 2010. -#' _Diversity and Complexity_. -#' Princeton: Princeton University Press. +#' Page, Scott E. 2010. +#' _Diversity and Complexity_. +#' Princeton: Princeton University Press. #' \doi{10.1515/9781400835140} +#' +#' Hirschman, Albert O. 1964. +#' "The paternity of an index". +#' _The American Economic Review_, 54(5): 761. #' @examples #' marvel_friends <- to_unsigned(to_uniplex(fict_marvel, "relationship"), "positive") #' net_by_diversity(marvel_friends, "Gender") @@ -143,7 +157,7 @@ net_by_diversity <- function(.data, attribute, "({.val gini} coefficient also available).") diversity <- "variation" } - if(is.character(attr) && diversity %in% c("variation","gini")){ + if(!is.numeric(attr) && diversity %in% c("variation","gini")){ manynet::snet_info("{.val {diversity}} coefficient is not appropriate for categorical attributes.") manynet::snet_info("Using {.val blau} index instead", "({.val teachman} index also available).") @@ -215,7 +229,7 @@ node_by_diversity <- function(.data, attribute, "({.val gini} coefficient also available).") diversity <- "variation" } - if(is.character(attr) && diversity %in% c("variation","gini")){ + if(!is.numeric(attr) && diversity %in% c("variation","gini")){ manynet::snet_info("{.val {diversity}} coefficient is not appropriate for categorical attributes.") manynet::snet_info("Using {.val blau} index instead", "({.val teachman} index also available).") @@ -289,6 +303,10 @@ node_by_diversity <- function(.data, attribute, #' indicate positive autocorrelation (similar values are more likely to be connected), #' values greater than 1 indicate negative autocorrelation (dissimilar values are more likely #' to be connected), and a value of 1 indicates no autocorrelation. +#' The upper bound of 2 holds where every tie carries the same weight. +#' Geary's C reads the weights where the network has them, +#' and a heavy tie between dissimilar values can then carry the sum past 2, +#' so a weighted network declares the upper end open. #' If an incompatible method is chosen for the attribute type, #' a suitable alternative will be used instead with a message. #' @family diversity @@ -375,7 +393,10 @@ net_by_homophily <- function(.data, attribute, assortativity <- "ie" } - m <- manynet::as_matrix(manynet::to_unweighted(.data)) + # The E-I index and Yule's Q count ties and non-ties, so they read a binary + # matrix. Geary's C takes w_ij from the formula, so it keeps the weights. + m <- if(assortativity == "geary") manynet::as_matrix(.data) else + manynet::as_matrix(manynet::to_unweighted(.data)) ei <- function(m, attribute){ same <- outer(attribute, attribute, "==") @@ -423,7 +444,7 @@ net_by_homophily <- function(.data, attribute, yule = yule(m, attribute), geary = geary(m, attribute)) - meta <- .homophily_metadata(assortativity) + meta <- .homophily_metadata(assortativity, manynet::is_weighted(.data)) make_network_measure(res, .data, call = deparse(sys.call()), measure = meta$measure, range = meta$range, normalization = "none", variant = meta$variant) @@ -451,7 +472,10 @@ net_by_homophily <- function(.data, attribute, variant = diversity) } -.homophily_metadata <- function(assortativity){ +# Geary's C reaches 2 only where every tie carries the same weight. Once the +# weights differ, a heavy tie between dissimilar values can carry the sum past +# that, so a weighted network declares the upper end open. +.homophily_metadata <- function(assortativity, weighted = FALSE){ list(measure = switch(assortativity, ie = "IE index", ei = "E-I index", @@ -459,7 +483,7 @@ net_by_homophily <- function(.data, attribute, geary = "Geary's C"), range = switch(assortativity, ie = , ei = , yule = c(-1, 1), - geary = c(0, 2)), + geary = `if`(weighted, c(0, Inf), c(0, 2))), variant = assortativity) } @@ -503,17 +527,33 @@ net_by_assortativity <- function(.data){ #' @examples #' net_by_spatial(ison_lawfirm, "age") #' @section Spatial autocorrelation: -#' Moran's I is conventionally read on \eqn{[-1, 1]}, where positive values -#' indicate that tied nodes hold similar values and negative values that they -#' hold dissimilar ones. Its actual bounds, however, are set by the -#' eigenvalues of the weight matrix, and on the unstandardised weights used -#' here it can fall outside that interval. Its range is therefore declared -#' open at both ends, and the conventional interval read as a guide rather -#' than a guarantee. +#' Moran's I is conventionally read on \eqn{[-1, 1]}, +#' where positive values indicate that tied nodes hold similar values +#' and negative values that they hold dissimilar ones. +#' Its actual bounds, however, are set by the eigenvalues of the weight matrix, +#' and on the unstandardised weights used here it can fall outside that interval. +#' Its range is therefore declared open at both ends, +#' and the conventional interval read as a guide rather than a guarantee. +#' +#' A two-mode network has no ties within a mode, +#' so where the attribute is present on one mode only, +#' the network is first projected onto that mode. +#' Two nodes are then neighbours where they are at distance 2, +#' weighted by the number of nodes of the other mode that they share. +#' Those counts make the weight matrix denser and \eqn{W} larger +#' than in a one-mode network, +#' so a projected value is read within a network rather than across networks. +#' Where the attribute is present on both modes, +#' the whole multilevel matrix is read instead, +#' and every node and tie is retained. +#' +#' Nodes with a missing attribute value are dropped, +#' along with their ties, +#' and \eqn{N}, \eqn{W} and \eqn{\bar{x}} are recomputed on those that remain. +#' A missing tie counts as no tie. #' @export net_by_spatial <- function(.data, attribute){ .data <- manynet::expect_nodes(.data) - N <- manynet::net_nodes(.data) x <- manynet::node_attribute(.data, attribute) # Moran's I is the correlation of a value with itself across ties, so the # attribute has to hold a quantity rather than a category @@ -521,13 +561,41 @@ net_by_spatial <- function(.data, attribute){ manynet::snet_abort("{.fn net_by_spatial} measures the autocorrelation of", "a numeric attribute, but {.val {attribute}} is", "{.cls {class(x)[1]}}.") - x_bar <- mean(x, na.rm = TRUE) - w <- manynet::as_matrix(.data) + net <- .data + if(manynet::is_twomode(net)){ + # There are no within-mode ties to correlate across, so either the mode + # holding the attribute is projected onto itself, or, where both modes + # hold it, the cross-mode ties are read as the weight matrix. + mode <- attr_mode(net, attribute) + if(is.null(mode)){ + manynet::snet_info("{.val {attribute}} is present on both modes.", + "Measuring autocorrelation across the", + "multilevel matrix.") + net <- manynet::to_multilevel(net) + } else { + manynet::snet_info("{.val {attribute}} is present on one mode only.", + "Projecting onto that mode, so that nodes are", + "weighted by the number of nodes of the other", + "mode they share.") + net <- manynet::to_mode(net, mode = `if`(mode, 2, 1)) + } + x <- manynet::node_attribute(net, attribute) + } + w <- manynet::as_matrix(net) + valid <- !is.na(x) + if(!all(valid)){ + manynet::snet_info("Dropping {sum(!valid)} node{?s} with a missing", + "{.val {attribute}}.") + x <- x[valid] + w <- w[valid, valid, drop = FALSE] + } + N <- length(x) + x_bar <- mean(x) W <- sum(w, na.rm = TRUE) - I <- (N/W) * - (sum(w * matrix(x - x_bar, N, N) * matrix(x - x_bar, N, N, byrow = TRUE)) / - sum((x - x_bar)^2)) - make_network_measure(I, .data, + den <- sum((x - x_bar)^2) + I <- if(N < 2 || W == 0 || den == 0) NA_real_ else + (N/W) * sum(w * outer(x - x_bar, x - x_bar), na.rm = TRUE) / den + make_network_measure(I, .data, call = deparse(sys.call()), measure = "Moran's I", range = c(-Inf, Inf), normalization = "none") @@ -585,9 +653,9 @@ node_by_heterophily <- function(.data, attribute){ node_by_homophily <- function(.data, attribute, assortativity = c("ie","ei","yule","geary")){ .data <- manynet::expect_nodes(.data) - # if (length(attribute) == 1 && is.character(attribute)) { - # attribute <- manynet::node_attribute(.data, attribute) - # } + if (length(attribute) == 1 && is.character(attribute)) { + attribute <- manynet::node_attribute(.data, attribute) + } assortativity <- match.arg(assortativity) if(is.numeric(attribute) && assortativity %in% c("ie","ei","yule")){ manynet::snet_info("{.val {assortativity}} index is not appropriate for numeric attributes.") @@ -600,16 +668,16 @@ node_by_homophily <- function(.data, attribute, assortativity <- "ie" } idat <- manynet::as_igraph(.data) + # The attribute is carried on the network rather than subset per ego, since + # igraph::ego() lists the ego first while igraph::induced_subgraph() keeps + # the original node order, so the two orders do not line up. + idat <- igraph::set_vertex_attr(idat, ".homophily", value = attribute) out <- vapply(igraph::ego(idat), - function(x) { - subattr <- if (length(attribute) == 1 && is.character(attribute)) - attribute else attribute[as.integer(x)] - net_by_homophily( - igraph::induced_subgraph(idat, x), - subattr, assortativity = assortativity) - }, + function(x) net_by_homophily(igraph::induced_subgraph(idat, x), + ".homophily", + assortativity = assortativity), FUN.VALUE = numeric(1)) - meta <- .homophily_metadata(assortativity) + meta <- .homophily_metadata(assortativity, manynet::is_weighted(.data)) make_node_measure(out, .data, measure = meta$measure, range = meta$range, normalization = "none", variant = meta$variant) } diff --git a/man/measure_assort_net.Rd b/man/measure_assort_net.Rd index f5e3a77..5ef9bdb 100644 --- a/man/measure_assort_net.Rd +++ b/man/measure_assort_net.Rd @@ -59,6 +59,10 @@ This value can range from 0 to 2, where values less than 1 indicate positive autocorrelation (similar values are more likely to be connected), values greater than 1 indicate negative autocorrelation (dissimilar values are more likely to be connected), and a value of 1 indicates no autocorrelation. +The upper bound of 2 holds where every tie carries the same weight. +Geary's C reads the weights where the network has them, +and a heavy tie between dissimilar values can then carry the sum past 2, +so a weighted network declares the upper end open. If an incompatible method is chosen for the attribute type, a suitable alternative will be used instead with a message.} } @@ -107,13 +111,30 @@ where 1 indicates ties only between categories/groups and -1 ties only within ca \section{Spatial autocorrelation}{ -Moran's I is conventionally read on \eqn{[-1, 1]}, where positive values -indicate that tied nodes hold similar values and negative values that they -hold dissimilar ones. Its actual bounds, however, are set by the -eigenvalues of the weight matrix, and on the unstandardised weights used -here it can fall outside that interval. Its range is therefore declared -open at both ends, and the conventional interval read as a guide rather -than a guarantee. +Moran's I is conventionally read on \eqn{[-1, 1]}, +where positive values indicate that tied nodes hold similar values +and negative values that they hold dissimilar ones. +Its actual bounds, however, are set by the eigenvalues of the weight matrix, +and on the unstandardised weights used here it can fall outside that interval. +Its range is therefore declared open at both ends, +and the conventional interval read as a guide rather than a guarantee. + +A two-mode network has no ties within a mode, +so where the attribute is present on one mode only, +the network is first projected onto that mode. +Two nodes are then neighbours where they are at distance 2, +weighted by the number of nodes of the other mode that they share. +Those counts make the weight matrix denser and \eqn{W} larger +than in a one-mode network, +so a projected value is read within a network rather than across networks. +Where the attribute is present on both modes, +the whole multilevel matrix is read instead, +and every node and tie is retained. + +Nodes with a missing attribute value are dropped, +along with their ties, +and \eqn{N}, \eqn{W} and \eqn{\bar{x}} are recomputed on those that remain. +A missing tie counts as no tie. } \examples{ diff --git a/man/measure_assort_node.Rd b/man/measure_assort_node.Rd index 90ab86d..8f5ecc0 100644 --- a/man/measure_assort_node.Rd +++ b/man/measure_assort_node.Rd @@ -53,6 +53,10 @@ This value can range from 0 to 2, where values less than 1 indicate positive autocorrelation (similar values are more likely to be connected), values greater than 1 indicate negative autocorrelation (dissimilar values are more likely to be connected), and a value of 1 indicates no autocorrelation. +The upper bound of 2 holds where every tie carries the same weight. +Geary's C reads the weights where the network has them, +and a heavy tie between dissimilar values can then carry the sum past 2, +so a weighted network declares the upper end open. If an incompatible method is chosen for the attribute type, a suitable alternative will be used instead with a message.} } diff --git a/man/measure_diverse_net.Rd b/man/measure_diverse_net.Rd index aa7cfa3..51885e7 100644 --- a/man/measure_diverse_net.Rd +++ b/man/measure_diverse_net.Rd @@ -70,6 +70,16 @@ i.e. when all individuals are classified in the same category. The maximum value depends on the number of categories and whether nodes can be evenly distributed across categories. +The Herfindahl-Hirschman index (HHI) is the complement of Blau's index, +\eqn{\sum\limits_{i = 1}^k {p_i^2}}, +and so \code{1 - net_by_diversity(.data, attribute)} returns it. +Where shares are stated as percentages rather than proportions, +as in the \code{{hhi}} package, +the index runs from 0 to 10000 and equals \code{(1 - blau) * 10000}. +Both readings hold for a categorical attribute, +where a share is the frequency of a category, +which is why neither index is offered for a numeric one. + Teachman's index (1980) is based on information theory and is calculated as: \deqn{- \sum\limits_{i = 1}^k {p_i \log(p_i)}} @@ -141,6 +151,10 @@ Page, Scott E. 2010. \emph{Diversity and Complexity}. Princeton: Princeton University Press. \doi{10.1515/9781400835140} + +Hirschman, Albert O. 1964. +"The paternity of an index". +\emph{The American Economic Review}, 54(5): 761. } } \seealso{ diff --git a/tests/testthat/test-measure_heterogeneity.R b/tests/testthat/test-measure_heterogeneity.R index 244ea26..4f47082 100644 --- a/tests/testthat/test-measure_heterogeneity.R +++ b/tests/testthat/test-measure_heterogeneity.R @@ -32,3 +32,84 @@ test_that("net_by_spatial() names a non-numeric attribute", { # Moran's I correlates a quantity across ties, so a category cannot be read expect_error(net_by_spatial(ison_lawfirm, "practice"), "numeric") }) + +# A two-mode network has no ties within a mode, so `net_by_spatial()` has to +# reshape it before it can correlate an attribute across ties. Which reshaping +# it picks depends on where the attribute sits, and these two tests hold it to +# the matrix each route is meant to read. + +test_that("net_by_spatial() projects a two-mode network onto the attribute's mode", { + set.seed(2025) + tm <- igraph::set_vertex_attr(as_igraph(ison_southern_women), "age", + value = c(round(rnorm(18, 40, 8), 1), + rep(NA_real_, 14))) + proj <- to_mode(tm, mode = 1) + w <- as_matrix(proj) + x <- node_attribute(proj, "age") + ref <- (18 / sum(w)) * sum(w * outer(x - mean(x), x - mean(x))) / + sum((x - mean(x))^2) + expect_values(net_by_spatial(tm, "age"), ref) +}) + +test_that("net_by_spatial() reads the multilevel matrix where both modes hold the attribute", { + set.seed(2025) + tm <- igraph::set_vertex_attr(as_igraph(ison_southern_women), "age", + value = round(rnorm(32, 40, 8), 1)) + w <- as_matrix(to_multilevel(tm)) + x <- node_attribute(tm, "age") + ref <- (32 / sum(w)) * sum(w * outer(x - mean(x), x - mean(x))) / + sum((x - mean(x))^2) + expect_values(net_by_spatial(tm, "age"), ref) +}) + +test_that("net_by_spatial() drops nodes with a missing attribute", { + ring <- igraph::set_vertex_attr(create_ring(8), "v", value = c(1:7, NA)) + # The four retained ties of the 1:7 path give 2/3, where reading the missing + # value into the sums would give NA for the whole network. + expect_values(net_by_spatial(ring, "v"), 0.667) + local_verbose() + expect_message(net_by_spatial(ring, "v"), "Dropping") +}) + +test_that("net_by_spatial() returns NA where the attribute has no variance", { + flat <- igraph::set_vertex_attr(create_ring(6), "v", value = rep(3, 6)) + expect_true(is.na(as.numeric(net_by_spatial(flat, "v")))) +}) + +test_that("node_by_homophily() reports Geary's C, and reads a name and a vector alike", { + set.seed(2025) + ring <- create_ring(8) + x <- round(rnorm(8, 50, 10), 2) + ring <- igraph::set_vertex_attr(ring, "v", value = x) + named <- node_by_homophily(ring, "v", assortativity = "geary") + expect_equal(attr(named, "measure"), "Geary's C") + expect_equal(attr(named, "variant"), "geary") + # `igraph::ego()` lists the ego first and `induced_subgraph()` does not, so + # a vector attribute used to be read against the wrong nodes. + expect_equal(as.numeric(named), + as.numeric(node_by_homophily(ring, x, assortativity = "geary"))) +}) + +test_that("Geary's C reads tie weights, and declares its range accordingly", { + ring <- create_ring(5) + igraph::E(ring)$weight <- c(1, 2, 3, 4, 5) + ring <- igraph::set_vertex_attr(ring, "v", value = c(1, 2, 3, 4, 5)) + weighted <- net_by_homophily(ring, "v", assortativity = "geary") + unweighted <- net_by_homophily(to_unweighted(ring), "v", + assortativity = "geary") + expect_values(weighted, 1.2) + expect_values(unweighted, 0.8) + # A heavy tie between dissimilar values can carry a weighted C past 2. + expect_equal(attr(weighted, "range"), c(0, Inf)) + expect_equal(attr(unweighted, "range"), c(0, 2)) +}) + +test_that("net_by_diversity() substitutes Blau's index for a factor attribute", { + fct <- igraph::set_vertex_attr(create_ring(6), "f", + value = factor(c("a", "a", "b", "b", "c", "c"))) + # A factor is neither numeric nor character, and used to reach `gini()`, + # which errors on one. + res <- net_by_diversity(fct, "f", diversity = "gini") + expect_equal(attr(res, "measure"), "Blau's index") + expect_values(res, 0.667) +}) From 8748f1b991f99494725d38aebd8b44fea2522169 Mon Sep 17 00:00:00 2001 From: James Hollway Date: Wed, 9 Sep 2026 17:17:22 +0200 Subject: [PATCH 4/4] Added explanatory comments for CRAN --- NEWS.md | 2 +- cran-comments.md | 7 ++++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 32fa8fb..8ccaa9b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,7 +10,7 @@ - Fixed `net_by_spatial()` erroring on a two-mode network - For one-mode attributes, projection is used - For multimodal attributes, the multilevel matrix is read instead -- Fixed `net_by_spatial()` propogating missing values +- Fixed `net_by_spatial()` propagating missing values - Fixed `net_by_diversity()` and `node_by_diversity()` erroring on a factor attribute ## Memberships diff --git a/cran-comments.md b/cran-comments.md index 12f70b0..23c9321 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,6 +1,6 @@ ## Test environments -* local R installation, macOS 26.5.2, aarch64-apple-darwin23, R 4.6.1 +* local R installation, macOS 26.5.2, aarch64-apple-darwin23, R 4.6.1 (release) * macOS 26.4 (on Github), R 4.6.1 * Microsoft Windows Server 2025 10.0.26100 (on Github), R 4.6.1 * Ubuntu 24.04.4 (on Github), R 4.6.1 @@ -8,3 +8,8 @@ ## R CMD check results 0 errors | 0 warnings | 0 notes + +This release fixes the two test failures that netrics 1.0.1 shows against +manynet 2.3.4, which is currently in the submission queue. +Both come from changes to reporting inherited from manynet rather than from the measures themselves. +The test suite here passes against manynet 2.3.1 and 2.3.4.