How to find 'n' nodes where all distances between them are greater than 'k'?
How to find 'n' nodes where all distances between them are greater than 'k'.
This is a clique problem.
For this example, let
n=5
k=10
First, we build a graph that connects all nodes where the distance is >= k.
am = UnitStep[GraphDistanceMatrix[net1] - k];
kDistGraph = AdjacencyGraph[VertexList[net1], am];
Then we find (maximal) cliques of size n
or greater (Mathematica can only find maximal cliques so we must allow for larger ones).
FindClique[kDistGraph, {n, Infinity}]
(* {{4798, 2641, 2310, 4721, 961, 4336, 3238, 2401, 2, 3042, 2277, 1895}} *)
Take any size-n
subset of this and it is a valid solution to your problem.
data = {4798 <-> 2641, 4798 <-> 2310, 4798 <-> 4721, 2310 <-> 1942, 2310 <-> 961,
4721 <-> 4507, 4721 <-> 4779, 4779 <-> 4336, 4779 <-> 3238, 4336 <-> 3277,
4336 <-> 3514, 3277 <-> 2923, 2923 <-> 2772, 2923 <-> 2401, 2772 <-> 2, 2772 <-> 2771,
3514 <-> 3042, 3514 <-> 2739, 3042 <-> 3007, 3042 <-> 1655, 2739 <-> 2277,
2739 <-> 1895, 2 <-> 5, 2 <-> 3, 3277 <-> 100, 5 <-> 6, 5 <-> 7, 5 <-> 8, 5 <-> 9};
ws = {10, 20, 20, 4, 35, 3, 4, 6, 17, 7, 13, 2, 2, 7, 2, 1, 3, 5, 3, 6, 4, 6, 2, 1, 1, 1, 1, 1, 1};
m = Max[List @@@ data]; (* Last node index *)
k = 8;
n = 25;
Linear programming can be used. Below there is $m+1$ zero/one-variables indicating which nodes are included.
The constraint matrix contains a row for each node. If the first node is too close to 8 other nodes, then the first row contains 8 off-diagonal entries equal to 1, and the diagonal-entry is 8. In that way the dot-product between the row and the parameter is greater than 8 if and only if the first node conflicts with another included node.
There is one additional row in which all entries are 1. This makes sure that the number of included elements is exactly n
.
mat = SparseArray[Catenate[{{#, #2} -> 1, {#2, #} -> 1} & @@@
(1 + List @@@ Pick[data, UnitStep[k - ws], 1])], {m + 1, m + 1}];
rowSums = Total[mat, {2}];
mat2 = Append[mat + DiagonalMatrix[SparseArray[rowSums]], ConstantArray[1, m + 1]];
Pick[Range[0, m],
LinearProgramming[
ConstantArray[0, m + 1],
mat2,
Append[Thread[{rowSums, -1}], {n, 0}],
ConstantArray[{0, 1}, m + 1],
Integers], 1]
{0, 1, 4, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 4786, 4787, 4788, 4789, 4790, 4791, 4792}