#' Affiliation network wedges
#'
#' Each clustering coefficient can be defined as the proportion of "wedges" that
#' are "closed", for suitable definitions of both terms. These functions count
#' the "wedges", and among them the "closed" ones, centered at a given actor
#' node in a given affiliation network.
#'
#' @rdname wedges
#' @family wedge functions
#' @param Q An actor node in the network.
#' @export
indequ_wedges <-
function(graph, Q) {
# Identify secondary neighbors of Q
n1 <- setdiff(neighborhood(graph, 1, Q)[[1]], Q)
# If there aren't at least two, return zeroes
if(length(n1) < 2) return(c(0, 0))
# Identify primary neighborhoods of secondary neighbors of Q
n1n1 <- lapply(neighborhood(graph, 1, n1), setdiff, c(Q, n1))
# Array the 2-paths centered at Q
# (Note that these are indices of n1, not vertex ids)
p <- utils::combn(1:length(n1), 2)
# Across the pairs (X, Y) list the numbers of wedges and closed wedges
wedgelist <- do.call(cbind, lapply(1:ncol(p), function(j) {
# The first node X must have a nonempty neighborhood besides Q
# and at least one neighbor not tied to Y (= n1[p[2, j]])
Ps <- setdiff(n1n1[[p[1, j]]], n1n1[[p[2, j]]])
if(length(Ps) == 0) return(c(0, 0))
# Across all choices of P from the non-Q primary neighbors of X
# that are not tied to Y
do.call(cbind, lapply(Ps, function(P) {
# Y must have a nonempty nbhd besides Q and P,
# from which R, which cannot be tied to X, is to be drawn
Rs <- setdiff(n1n1[[p[2, j]]], c(P, n1n1[[p[1, j]]]))
if(length(Rs) == 0) return(c(0, 0))
# Which Rs produce 4-paths (P, X, Q, Y, R) that are closed
# by events Z that are not tied to Q?
Rw <- which(sapply(Rs, function(R) {
length(setdiff(
intersect(neighborhood(graph, 1, P)[[1]],
neighborhood(graph, 1, R)[[1]]),
n1)) > 0
}))
c(length(Rs), length(Rw))
}))
}))
rowSums(wedgelist)
}
#' @rdname wedges
#' @export
indequ.wedges <- indequ_wedges
#' @rdname wedges
#' @export
indstr_wedges <-
function(graph, Q) {
# Identify nodes of separation (exactly) 1 and 2 from Q
n1 <- setdiff(neighborhood(graph, 1, Q)[[1]], Q)
n2 <- setdiff(neighborhood(graph, 2, Q)[[1]], c(n1, Q)) # rm Q?
# Require at least two nodes of separation 2 for a wedge
if(length(n2) < 2) return(c(0, 0))
# Identify secondary neighbors of primary neighbors P of Q (excluding P)
n2n1 <- lapply(n2,
function(P) setdiff(neighborhood(graph, 1, P)[[1]], P))
# Identify indexes of pairs (P, R) of nodes in n2
p <- utils::combn(1:length(n2), 2)
# Remove pairs (P, R) with no pairwise exclusive secondary neighbors
p <- as.matrix(p[, sapply(1:dim(p)[2], function(j) {
(0 < length(setdiff(intersect(n2n1[[p[1, j]]], n1),
n2n1[[p[2, j]]])) *
length(setdiff(intersect(n2n1[[p[2, j]]], n1),
n2n1[[p[1, j]]])))
})], nr = 2)
# Require at least two nodes of separation 2 for a wedge
if(dim(p)[2] == 0) return(c(0, 0))
# Identify which of these pairs share a neighbor not shared with Q
cl <- sapply(1:dim(p)[2], function(j) {
0 < length(setdiff(intersect(n2n1[[p[1, j]]], n2n1[[p[2, j]]]), n1))
})
# Return the counts
c(length(cl), sum(cl))
}
#' @rdname wedges
#' @export
indstr.wedges <- indstr_wedges
#' @rdname wedges
#' @export
injact_wedges <-
function(graph, Q) {
# Identify nodes of separation (exactly) 1 and 2 from Q
n1 <- setdiff(neighborhood(graph, 1, Q)[[1]], Q)
n2 <- setdiff(neighborhood(graph, 2, Q)[[1]], c(n1, Q))
# Require at least two nodes of separation 2 for a wedge
if(length(n2) < 2) return(c(0, 0))
# Identify pairs (P, R) of nodes in n2
p <- utils::combn(n2, 2)
# Identify which of these pairs form wedges & which of these are closed
wedgelist <- sapply(1:dim(p)[2], function(j) {
# Secondary neighbors of P and of R
pn1 <- neighborhood(graph, 1, p[1:2, j])
# Common neighbors of P and R
tn1 <- do.call(intersect, pn1)
# If only one secondary links either to Q then no wedges exist
if(length(intersect(n1, unique(unlist(pn1)))) == 1) c(0, 0) else
# Otherwise one wedge, closed iff Hall criterion is met
c(1, as.numeric(hallCriterion(list(intersect(n1, pn1[[1]]),
intersect(n1, pn1[[2]]),
tn1))))
})
return(rowSums(wedgelist))
}
#' @rdname wedges
#' @export
injact.wedges <- injact_wedges
#' @rdname wedges
#' @export
injequ_wedges <-
function(graph, Q) {
# Identify secondary neighbors of Q
n1 <- setdiff(neighborhood(graph, 1, Q)[[1]], Q)
# If there aren't at least two, return zeroes
if(length(n1) < 2) return(c(0, 0))
# Identify primary neighborhoods of secondary neighbors of Q
n1n1 <- lapply(neighborhood(graph, 1, n1), setdiff, c(Q, n1))
# Array the 2-paths centered at Q
# (Note that these are indices of n1, not vertex ids)
p <- utils::combn(1:length(n1), 2)
# Across the pairs (X, Y) list the numbers of wedges and closed wedges
wedgelist <- do.call(cbind, lapply(1:ncol(p), function(j) {
# The first node X must have a nonempty neighborhood besides Q
if(length(n1n1[[p[1, j]]]) == 0) return(c(0, 0))
# Across all choices of P from the non-Q primary neighbors of X
do.call(cbind, lapply(n1n1[[p[1, j]]], function(P) {
# The second node Y must have a nonempty nbhd besides Q and P
Rs <- setdiff(n1n1[[p[2, j]]], P)
if(length(Rs) == 0) return(c(0, 0))
# Which Rs produce 4-paths (P, X, Q, Y, R) that are closed?
Rw <- which(sapply(Rs, function(R) {
length(setdiff(intersect(neighborhood(graph, 1, P)[[1]],
neighborhood(graph, 1, R)[[1]]),
n1[p[, j]])) > 0
}))
return(c(length(Rs), length(Rw)))
}))
}))
rowSums(wedgelist)
}
#' @rdname wedges
#' @export
injequ.wedges <- injequ_wedges
#' @rdname wedges
#' @export
injstr_wedges <-
function(graph, Q) {
# Identify nodes of separation (exactly) 1 and 2 from Q
n1 <- setdiff(neighborhood(graph, 1, Q)[[1]], Q)
n2 <- setdiff(neighborhood(graph, 2, Q)[[1]], c(n1, Q))
# Identify events attended by these actors
n2n1 <- lapply(neighborhood(graph, 1, n2), setdiff, y = n2)
# Require at least two nodes of separation 2 for a wedge
if(length(n2) < 2) return(c(0, 0))
# Identify pairs (P, R) of nodes in n2
p <- utils::combn(length(n2), 2)
# Count the structurally distinct wedges (0 thru 4) for each pair (P, R)
# and the number of these that are closed
wedgelist <- sapply(1:ncol(p), function(j) {
# Whether P and Q share an exclusive event
pq <- length(setdiff(intersect(n1, n2n1[[p[1, j]]]),
n2n1[[p[2, j]]])) > 0
# Whether Q and R share an exclusive event
qr <- length(setdiff(intersect(n1, n2n1[[p[2, j]]]),
n2n1[[p[1, j]]])) > 0
# How many events P, Q, and R share
pqr <- length(intersect(intersect(n1, n2n1[[p[1, j]]]),
n2n1[[p[2, j]]]))
# If revelant, whether P and R share an exclusive event
pr <- if(pq + qr + pqr < 2) 0 else
(length(setdiff(intersect(n2n1[[p[1, j]]], n2n1[[p[2, j]]]), n1)) >
0)
# Counts
Ws <- c(pq * qr, c(pq, qr) * (pqr > 0), pqr > 1)
Ts <- c(pr + pqr > 0, rep(pr | (pqr > 1), 2), pr | (pqr > 2))
return(c(sum(Ws), sum(Ws * Ts)))
})
rowSums(wedgelist)
}
#' @rdname wedges
#' @export
injstr.wedges <- injstr_wedges
# Test for the existence of a system of distinct representatives for a finite
# set.
# \url{www.encyclopediaofmath.org/index.php/System_of_different_representatives}
hallCriterion <- function(lst) {
all(sapply(0:(2 ^ length(lst) - 1),
function(i) {
w <- which(intToBits(i) == 1)
length(unique(unlist(lst[w]))) >= length(w)
}))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.