How to get all Perfect or Near-Perfect Matchings of a graph

Question

I have found the Perfect Matching's definition in Wiki.

A perfect matching (a.k.a. 1-factor) is a matching which matches all vertices of the graph. That is, every vertex of the graph is incident to exactly one edge of the matching.

Or another samilar definition, Near-Perfect Matching, as follows:

A near-perfect matching is one in which exactly one vertex is unmatched. This can only occur when the graph has an odd number of vertices, and such a matching must be maximum.

I can give some example to illustrate it. In a simple graph

Graph[{1 <-> 4, 1 <-> 5, 1 <-> 6, 2 <-> 4, 2 <-> 5, 2 <-> 6, 3 <-> 6},
  VertexLabels -> "Name", GraphLayout -> "BipartiteEmbedding"]

We can judge it by eye, such as the 3-6, 2-5, 1-4 or 3-6, 2-4, 1-5 is the Perfect Matching. But in some complicated case it will be harder to judge. For example:

Graph[{1 <-> 16, 1 <-> 17, 1 <-> 18, 1 <-> 19, 1 <-> 20, 1 <-> 21, 
  2 <-> 16, 2 <-> 17, 2 <-> 18, 2 <-> 22, 2 <-> 23, 2 <-> 24, 
  3 <-> 16, 3 <-> 19, 3 <-> 20, 3 <-> 22, 3 <-> 23, 3 <-> 25, 
  4 <-> 17, 4 <-> 19, 4 <-> 21, 4 <-> 22, 4 <-> 24, 4 <-> 25, 
  5 <-> 18, 5 <-> 20, 5 <-> 21, 5 <-> 23, 5 <-> 24, 5 <-> 25, 
  6 <-> 16, 6 <-> 17, 6 <-> 18, 6 <-> 26, 6 <-> 27, 6 <-> 28, 
  7 <-> 16, 7 <-> 19, 7 <-> 20, 7 <-> 26, 7 <-> 27, 7 <-> 29, 
  8 <-> 17, 8 <-> 19, 8 <-> 21, 8 <-> 26, 8 <-> 28, 8 <-> 29, 
  9 <-> 18, 9 <-> 20, 9 <-> 21, 9 <-> 27, 9 <-> 28, 9 <-> 29, 
  10 <-> 16, 10 <-> 22, 10 <-> 23, 10 <-> 26, 10 <-> 27, 10 <-> 30, 
  11 <-> 17, 11 <-> 22, 11 <-> 24, 11 <-> 26, 11 <-> 28, 11 <-> 30, 
  12 <-> 18, 12 <-> 23, 12 <-> 24, 12 <-> 27, 12 <-> 28, 12 <-> 30, 
  13 <-> 19, 13 <-> 22, 13 <-> 25, 13 <-> 26, 13 <-> 29, 13 <-> 30, 
  14 <-> 20, 14 <-> 23, 14 <-> 25, 14 <-> 27, 14 <-> 29, 14 <-> 30, 
  15 <-> 21, 15 <-> 24, 15 <-> 25, 15 <-> 28, 15 <-> 29, 15 <-> 30}, 
 GraphLayout -> "BipartiteEmbedding"]

I'm dizzy now. We can use GraphData["PerfectMatching"] to produce some graph with PerfectMatching to give it a try.

Question:

How to get all possible Perfect Matching or Near-Perfect Matching using Mathematica?

Answer 1

There's (almost certainly) no way to do this efficiently, except for small graphs. According to Wikipedia:

The number of matchings in a graph is known as the Hosoya index of the graph. It is #P-complete to compute this quantity, even for bipartite graphs.[13] It is also #P-complete to count perfect matchings, even in bipartite graphs [...]

Where "#P-complete" basically means there is no (known) efficient algorithm. So your chances of enumerating all perfect matchings for anything but a tiny graph aren't high.

But from your comment, that's not really what you want:

If we can find all mach,then we can select that minimal or maximal perfect maching in a weight graph.So if we can do it.I wish find all of it.

That's a bit like sorting a list by enumerating all permutations until you find one that's sorted. Certainly possible for small lists, but not how you would do it in practice.

There are efficient algorithms to find a maximal weighted matching. The easiest way to do it in Mathematica is probably to use linear programming, as I've done here, or to use FindMinimumCostFlow, like this:

g = Graph[
   {1 -> 4, 1 -> 5, 1 -> 6, 2 -> 4, 2 -> 5, 2 -> 6, 3 -> 6}, 
   VertexLabels -> "Name", GraphLayout -> "BipartiteEmbedding"];
supplyDemand=If[# <= 3, 1, -1] & /@ VertexList[g];
f = FindMinimumCostFlow[g,
   supplyDemand,
   "OptimumFlowData", EdgeCost -> {1, 2, 3, 4, 5, 6, 7}];

f["CostValue"]

13

f["FlowGraph"]

The intuitive explanation is that you have a road network, linking nodes that "supply" some quantity and nodes that "demand" some quantity. We give the nodes on the "left" side of the bipartite graph a supply of 1, and the nodes on the "right" side a demand of 1 (i.e. a supply of -1). Then we let FindMinimumCostFlow find the lowest-cost flow given some edge weights. And that's your min-weight maximal matching. For a max-weight matching, simply flip the sign of the edge costs.

Answer 2

The IGLargestIndependentVertexSets is what I after,which from Szabolcs's package IGraphM,when the point is less 15 or much less.I mean,the effeciency it very very poor.

g = Graph[{1 <-> 4, 1 <-> 5, 1 <-> 6, 2 <-> 4, 2 <-> 5, 2 <-> 6, 
   3 <-> 6}, VertexLabels -> "Name", 
  GraphLayout -> "BipartiteEmbedding"]

iden = EdgeList[g][[#]] & /@ 
  IGLargestIndependentVertexSets[LineGraph[g]]
HighlightGraph[g, #] & /@ iden

Answer 3

Since the @nikie say this is #P-complete.So I enumerate it to get all of the minimal or maximal perfect maching.Of course,we can get the all possible Perfect Matching or Near-Perfect Matching as this topic by the same method.But the maximal and minimum match is more useful to us.So I post it as a example.Maybe more pretty solution can do this.I'll glad to know that.

Suppose we have a reduced adjacency matrix of a bipartite graph like

list={{3,5,8,10,11},{6,6,5,7,4},{7,5,12,9,6},{5,6,13,10,7},{3,5,7,9,8}};

Custom a function to restore it to be graph

ReducedAdjacencyGraph[list_] := 
 WeightedAdjacencyGraph[
  ArrayFlatten[{{0, list}, {Transpose@list, 0}}] /. 0 -> Infinity, 
  VertexLabels -> "Name", 
  GraphLayout -> {"BipartiteEmbedding", "Rotation" -> 3 Pi/2, 
    "AspectRatio" -> 2}, EdgeLabels -> Placed["EdgeWeight", 0.15], 
  EdgeLabelStyle -> Directive[Red, Italic, 10]]

Get the graph of g

g = ReducedAdjacencyGraph[list]

Enumerating to get all of the maximal perfect maching(Of course the minximal maching can be get with the same method.)

pos = MinimalBy[
  Permanent@Array[tem[#1, #2] &, {5, 5}] /. {Times -> List, 
    tem -> List, Plus -> List}, Total[Extract[list, #]] &]

{{{1,2},{2,3},{3,5},{4,4},{5,1}},{{1,2},{2,3},{3,4},{4,5},{5,1}},{{1,1},{2,3},{3,5},{4,4},{5,2}},{{1,1},{2,3},{3,4},{4,5},{5,2}},{{1,1},{2,5},{3,4},{4,2},{5,3}},{{1,1},{2,4},{3,5},{4,2},{5,3}},{{1,1},{2,5},{3,2},{4,4},{5,3}},{{1,1},{2,4},{3,2},{4,5},{5,3}},{{1,1},{2,3},{3,5},{4,2},{5,4}},{{1,1},{2,3},{3,2},{4,5},{5,4}}}

Use frame to show the position we get

MatrixForm /@ (MapAt[Framed, list, #] & /@ pos)

And we can see these all combination is maximum

Total/@(Extract[list,#]&/@pos)

{29, 29, 29, 29, 29, 29, 29, 29, 29, 29}

Hightlight all combination we get

allCombination = 
  Normal[SparseArray[# -> 1, Dimensions[list]]] & /@ pos;
HighlightGraph[g, ReducedAdjacencyGraph[#], 
   GraphHighlightStyle -> "Thick"] & /@ allCombination