5
$\begingroup$

Consider the weighted graph 'net1':

g1 = {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};

w1 = {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};

net1 = Graph[g1, EdgeWeight -> w1, EdgeLabels -> "EdgeWeight",VertexShapeFunction -> "Name"]

How to find 'n' nodes where all distances between them are greater than 'k'.

Such calculations have to be done for large networks, e.g.

data = Table[i <-> RandomInteger[{0, i - 1}], {i, 1, 200000}];
net = Graph[data, EdgeWeight -> Table[RandomInteger[{1, 20}], Length[data]]];
$\endgroup$
  • 1
    $\begingroup$ If an answer solves your problem please accept it. If no answer works, clarify. I noticed that after 2 years on this site, you did not accept a single answer and did not answer several of the comments asking for clarifications on unclear questions. $\endgroup$ – Szabolcs Apr 17 at 15:07
7
$\begingroup$

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.

$\endgroup$
6
$\begingroup$
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}

$\endgroup$
  • $\begingroup$ Unfortunately, in the list of nodes (VertexList [data]) there are no nodes that give your out put :( $\endgroup$ – ralph Apr 17 at 14:25

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.