1
$\begingroup$

I have a weighted graph, and I am interested to find k largest edges with unique nodes. Currently, I do it in the following manner

maxMatching[mat_,num_]:=Module[{res={},idxMax,aMax,temp=mat},
Table[idxMax=Nearest[temp["NonzeroValues"]->Automatic,Max[temp],1];
aMax=temp["NonzeroPositions"][[idxMax]];
AppendTo[res,aMax];
temp[[First[Flatten[aMax],1]]]=temp[[First[Flatten[aMax],1]]]*0;
temp[[All,Last[Flatten[aMax],1]]]=temp[[ Last[Flatten[aMax],1]]]*0;
temp
,{num}];
res
]

Any suggestion on how to speed up this calculation in huge matrices are welcome.

Edit: I speed up the calculation in factor ~5 by using a mask matrix and multiplication of the original matrix by the mask matrix.

maxMatching2[mat_, num_] := 
 Module[{res = {}, idxMax, aMax, temp = mat, maskMatrix, pos1, pos2},
  Table[idxMax = 
    Nearest[temp["NonzeroValues"] -> Automatic, Max[temp], 1];
   aMax = temp["NonzeroPositions"][[idxMax]];
   AppendTo[res, aMax];

   pos1 = 
    temp[[First[Flatten[aMax], 1]]][
     "NonzeroPositions"];(*temp1[[First[Flatten[aMax],1]]]*0;//
   AbsoluteTiming*)
   pos2 = temp[[All, Last[Flatten[aMax], 1]]]["NonzeroPositions"];
   rr = Thread[List[First[Flatten[aMax]], Flatten[pos1]]];
   rr2 = Thread[List[Last[Flatten[aMax]], Flatten[pos2]]];
   maskMatrix = 
    SparseArray[Join[rr, rr2] -> 0.0, Dimensions[temp], 1.0];
   temp = temp*maskMatrix
   , num];
  res
  ]

Edit 2 Assume in the following graph g1 I want to find 2 largest edges with unique nodes.

g1 = Graph[
    {1<->2, 2<->3, 3<->4, 4<->5, 4<->6, 5<->6, 6<->7, 6<->8, 7<->8},
    EdgeWeight -> {3, 2, 1, 6, 5, 4, 1, 3, 2},
    EdgeLabels -> "EdgeWeight"
];

enter image description here

The first edge is the largest edge in the graph and the second edge is edge without common nodes.

The result will be the red edges in the graph

enter image description here

$\endgroup$
  • 2
    $\begingroup$ It is not clear to me what is the actual goal. A short example would be useful. $\endgroup$ – Daniel Lichtblau Oct 26 '18 at 15:55
  • $\begingroup$ @DanielLichtblau I added an example $\endgroup$ – Kiril Danilchenko Oct 26 '18 at 17:51
  • $\begingroup$ Thanks. There remains a question. Are you trying to maximize total weight? Or just to have a greedy algorithm that successively selects the next qualified candidate edge at each step? $\endgroup$ – Daniel Lichtblau Oct 26 '18 at 19:43
  • $\begingroup$ @DanielLichtblau Just a greedy algorithm $\endgroup$ – Kiril Danilchenko Oct 27 '18 at 2:08
4
$\begingroup$

Update: a greedy approach:

am = WeightedAdjacencyMatrix[g1];
DeleteDuplicates[am["NonzeroPositions"][[Ordering[-am["NonzeroValues"]]]][[;; ;; 2]], 
  IntersectingQ]

{{4, 5}, {1, 2}, {6, 8}}

Original answer:

ClearAll[f]
f = Module[{dm = Array[a, {1, 1} VertexCount[#], 1], constraints1, 
      constraints2, constraints3, objective},
  constraints1 = Join @@ Join[Thread[0 <= # <= 1] & /@ dm, 
      Thread[0 <= # <= 1] & /@ Transpose[dm]];
  constraints2 = 0 <= Total[{#, Reverse /@ #}, 2] <= 1 & /@ dm;
  constraints3 = {Total[dm, 2] == #2};
  constraints4 = DeleteCases[Thread[Join@@dm ==Join@@(dm  Unitize[am])], True];
  objective = Total[dm WeightedAdjacencyMatrix[#], 2];
  Maximize[{objective, ## & @@ 
   Join[constraints1, constraints2, constraints3, constraints4]}, Join @@ dm, Integers]]&;

Examples:

edges = Property[#, EdgeWeight -> #2] & @@@ 
   Thread[{{1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 4 <-> 6, 5 <-> 6, 
      6 <-> 7, 6 <-> 8, 7 <-> 8}, {3, 2, 1, 6, 5, 4, 1, 3, 2}}];
g1 = Graph[Range[8], edges, EdgeLabels -> "EdgeWeight", 
  VertexLabels -> Placed["Name", Center], VertexSize -> Large, ImageSize -> Large]

enter image description here

f[g1, 3] /. r : Rule[_, 1] :> Style[r, Red, Bold]

enter image description here

HighlightGraph[g1, Style[f[g1, 3][[2]] /. 
  Rule[a[b_, c_], 1] :> UndirectedEdge[b, c], {Red, Thickness[.02]}]]

enter image description here

HighlightGraph[g1, Style[f[g1, 2][[2]] /. 
   Rule[a[b_, c_], 1] :> UndirectedEdge[b, c], {Red, Thickness[.02]}]]

enter image description here

 HighlightGraph[g1, Style[f[g1, 4][[2]] /. 
   Rule[a[b_, c_], 1] :> UndirectedEdge[b, c], {Red, Thickness[.02]}]] 

enter image description here

$\endgroup$
  • $\begingroup$ Thank you for the answer. Your greedy approach is what I am looking for, but unfortunately, it runs slowly, too. My input is a graph that has a few thousands of nodes and millions of edges. In my approach, the execution converges after ~ 5 hours, and your solution still runs (3+ hours). I am looking to speed up this calculation $\endgroup$ – Kiril Danilchenko Oct 27 '18 at 8:51
1
$\begingroup$

Interpretation

I can interpret the optimization problem in 2 ways:

  1. Find the maximum total weight, even if it means that the largest weight is not included. Consider the following graph:

    Graph[
        {1<->2, 2<->3, 3<->4, 4<->5},
        EdgeWeight -> {4, 6, 4, 1},
        EdgeLabels -> "EdgeWeight"
    ]
    

    enter image description here

    For this graph, the maximum total weight is $4+4$ and not $6+1$.

  2. Use a greedy algorithm, at each step selecting one of the largest weights. If there are multiple weights that can be chosen, then consider all possibilities choices for each step. Choose the possibility that produces the most large weight edges. For example, if one possibility produces the edge weights: $$6, 5, 3$$ and a different possibility produces the edge weights $$6, 6, 1$$ then the answer would be latter possibility, even though the former possibility has a larger total weight.

First Interpretation

For the first interpretation (the only one I will consider) you can use LinearProgramming:

MaxWeightEdges[g_, k_] := With[{i = IncidenceMatrix[g]},
    Quiet[
        LinearProgramming[
            -PropertyValue[g, EdgeWeight],
            Join[
                {Table[1, EdgeCount[g]]},
                i
            ],
            Join[
                {{k, -1}},
                Table[{1, -1}, Length[i]]
            ],
            Table[{0, 1}, EdgeCount[g]],
            Integers
        ],
        LinearProgramming::lpip
    ]
]

For your example:

g1 = Graph[
    {1<->2, 2<->3, 3<->4, 4<->5, 4<->6, 5<->6, 6<->7, 6<->8, 7<->8},
    EdgeWeight -> {3, 2, 1, 6, 5, 4, 1, 3, 2},
    EdgeLabels -> "EdgeWeight"
];

MaxWeightEdges[g1, 2]
MaxWeightEdges[g1, 3]

{1, 0, 0, 1, 0, 0, 0, 0, 0}

{1, 0, 0, 1, 0, 0, 0, 1, 0}

$\endgroup$
0
$\begingroup$

Motivated by the @kglr greedy approach, I speed up my calculation in the following manner:

resTest = {};
    dataBaseOfNodes = 
  Association[
   Table[i -> 1, {i, 1, 
     Length@DeleteDuplicates[Flatten[am ["NonzeroPositions"]]]}]];
sortedEdgeList = 
   am["NonzeroPositions"][[Ordering[-am ["NonzeroValues"]]]][[;; ;;2]];

k = 4;
Table[If[dataBaseOfNodes[First[sortedEdgeList [[j]]]]*
        dataBaseOfNodes[First[sortedEdgeList [[j]]]] == 1 && 
      Length[resTest] < k, AppendTo[resTest, sortedEdgeList [[j]]]; 
     dataBaseOfNodes[First[sortedEdgeList [[j]]]] = 0; 
     dataBaseOfNodes[First[sortedEdgeList [[j]]]] = 0;, 
     Nothing[];];, {j, 1, Length@sortedEdgeList }]; // AbsoluteTiming 
$\endgroup$

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.