This solution is obsolete, Use this solution for better and faster results.
Instead of iterating over all possible subgraphs, I use linear optimization to find cheap, separated components covering all the groups that with some post-processing can be connected.
There are some limitations, as I couldn't formulate ConnectedGraphQ
in a linear constraint. So the optimization finds separate components that are close to each other but not connected.
Since optimization find seperated paths, it ignores the cost of connecting them. In the post-processing, we'll find the cheapest path to connect these components but this does not guarantee the best solution.
It supports only undirected graphs, but I think with some modification, it can support other types too. You might find some corner cases where the input is not a connected graph.
Arguments:
- Graph
- grouping:
{{1, 2, 3}, {4, 5, 6}, ...}
(groups can overlap)
- K: Does not have a clear definition but pushes the optimization to find components close to each other (sometimes you can get better results if you play with it).
Outpus:
{cost, edges}

Testing the kglr's first example (SimpleGraph
applied) clearly shows the limitation as the best answer costs 9
but ours costs 14
(k=1
). As for the timing, it took us less than .007 seconds
to find which is pretty fast.
On the kglr's second example we can get 6
for k=2
, while k=3
gives 9
.
We could test it on larger graphs like one with 300 vertices and 1000 edges and it costs us less than a second!
RandomSeed[10];
graph3 =
RandomGraph[{300, 1000}, EdgeWeight -> RandomReal[{1, 30}, 1000]];
groupings3 = Partition[RandomSample@Range[300], 10];
Result
AbsoluteTiming@
First@FindMinimumCoveringSpanningTree[graph3, groupings3, 1]
(* Out: {0.306789, 367.896} *)
Next question is how much good are the answers? I think is highly dependant on the context and you need to test it on your data. If you found it don't forget to comment it below.
Code
I tried to pick informative names and named the main function FindMinimumCoveringSpanningTree
! I haven't read papers about this algorithm, if nobody mentioned it before, notify me to change it to my personal name ;)
ClearAll[FindMinimumCoveringSpanningTree, FindEdgesToConnectEdges,
CreateSparseArrayFromIndexedList,
FindShortestPathFromDistanceMatrix];
(* Find the shortest path connecting one vertex from verticesSet1 to \
another vertex from verticesSet2 *)
FindShortestPathFromDistanceMatrix[distanceMatrix_, verticesSet1_,
verticesSet2_] := Block[{temp, minimumPath},
temp =
Catenate@
Outer[{#1, #2, distanceMatrix[[#1, #2]]} &, verticesSet1,
verticesSet2];
minimumPath = Quiet@TakeSmallestBy[temp, Last, 1];
If[minimumPath === {} || Head[minimumPath] === TakeSmallestBy,
Return@{}];
minimumPath[[1, ;; 2]]
]
(* Tries to connect the edges by finding the minimum path,will return \
immediate if it could not connect the first component to the rest *)
FindEdgesToConnectEdges[graph_Graph, edges_] :=
Block[{distanceMatrix = GraphDistanceMatrix[graph], addedEdges = {},
components, otherComponenets, otherComponentsVertices,
mainComponentVertices, minimumPath},
components = ConnectedGraphComponents[edges];
Do[
mainComponentVertices = VertexList[First@components];
otherComponentsVertices =
DeleteDuplicates@Catenate[VertexList /@ Rest[components]];
minimumPath =
FindShortestPathFromDistanceMatrix[distanceMatrix,
mainComponentVertices, otherComponentsVertices];
If[minimumPath =!= {},
minimumPath =
UndirectedEdge @@@
Partition[
FindShortestPath[graph, minimumPath[[1]], minimumPath[[2]]], 2,
1];
addedEdges = Join[addedEdges, minimumPath];
components = ConnectedGraphComponents@Join[edges, addedEdges];,
Return[Join[edges, addedEdges]];
];
, Length@components - 1
];
Join[edges, addedEdges]
]
CreateSparseArrayFromIndexedList[lists_ : {{__Integer} ..},
size_List] :=
SparseArray[
Catenate@Table[Thread[{i, lists[[i]]}], {i, Length[lists]}] -> 1,
size]
FindMinimumCoveringSpanningTree[graph_Graph,
groupings_ : {{__Integer} ..}, k_Integer?Positive] :=
Block[{edgeList = EdgeList[graph], edgeCount = EdgeCount[graph],
edgeWeight = AnnotationValue[graph, EdgeWeight],
groupingsCount = Length[groupings], edgeListAsList,
kLevelEdgeConnection, groupingEdgeIndices, coverKLevel, x,
coverGroupings, edgeIndex, vertexEdgeIndexAssociation,
findEdgeIndexFromVertex, answer, result, coverKLevelReward},
edgeIndex = PositionIndex@edgeList;
edgeListAsList = List @@@ edgeList;
vertexEdgeIndexAssociation =
Merge[{GroupBy[edgeList, First], GroupBy[edgeList, Last]},
Catenate@Lookup[edgeIndex, Flatten@Join@#] &];
(* Find all the edge indices based on a vertex *)
findEdgeIndexFromVertex =
EdgeIndex[graph,
Cases[edgeList,
First[#] \[UndirectedEdge] _ | _ \[UndirectedEdge] First[#] |
Last[#] \[UndirectedEdge] _ | _ \[UndirectedEdge] Last[#]]] &;
(* Find K-level edges connected to each edge *)
kLevelEdgeConnection =
Function[x,
Nest[DeleteDuplicates@
Catenate@Lookup[vertexEdgeIndexAssociation, #, Nothing] &, x,
k]] /@ (List @@@ edgeList);
(* Find all the edge indices related to each grouping *)
groupingEdgeIndices = findEdgeIndexFromVertex /@ groupings;
(* Optimization constraint-If an edge is selected,edges to K-
Level should also be picked *)
coverKLevel =
CreateSparseArrayFromIndexedList[
kLevelEdgeConnection, {edgeCount, edgeCount}];
(* Optimization constraint-If an edge is selected,statisfy the K-
th Level requirement *)
coverKLevelReward =
Function[x,
Rest@NestList[
DeleteDuplicates@
Complement[
Catenate@
Lookup[vertexEdgeIndexAssociation, #, Nothing], #] &, x,
k]] /@ (List @@@ edgeList);
coverKLevelReward = -Transpose@
CreateSparseArrayFromIndexedList[#, {edgeCount, edgeCount}] & /@
Transpose[coverKLevelReward];
(* Optimization constraint-
selected edges should cover all the groupings *)
coverGroupings = ConstantArray[0, {groupingsCount, edgeCount}];
Do[coverGroupings[[i, groupingEdgeIndices[[i]]]] = 1;, {i,
groupingsCount}];
answer =
LinearOptimization[
x . edgeWeight, {1 \[VectorGreaterEqual] x \[VectorGreaterEqual]
0, (x . coverKLevel) +
Total[coverKLevelReward . x] \[VectorLessEqual] 0,
coverGroupings . x \[VectorGreaterEqual] 1},
x \[Element] Vectors[edgeCount, Integers],
"PrimalMinimizerVector"];
If[FreeQ[answer, Indeterminate],
result =
FindEdgesToConnectEdges[graph,
edgeList[[Catenate@Position[answer, 1]]]];
(* The result may have mutliple edges betwen nodes,
using FindSpanningTree will fixed,
subgraph was used to get EdgeWeight *)Block[{tempGraph = result},
{Total@AnnotationValue[{graph, EdgeList@tempGraph}, EdgeWeight],
tempGraph}
]
, {0, {}}
]
]