Find k largest edges with unique nodes (kind of maximum weighted matching)

Question

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"
];

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

Answer 1

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]

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

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

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

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

Answer 2

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"
   ]
   

   

   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}

Answer 3

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