How to find a specific spanning subgraph?

Question

A spanning subgraph is a subgraph that contains all the vertices of the original graph.

Given a graph $G$, I would like to write a function $f$ for finding a spanning 5-regular bipartite connected subgraph of $G$. More specifically, if $G$ does not contain such graphs, $f$ gives False, otherwise $f$ gives True and a subgraph that satisfies the conditions above.

I wrote a piece of code for this. This code seems to work well when the number of edges of $G$ is small.

(* test if a given graph is k-regular*)
kRegularQ[g_, k_] := 
  Max[VertexDegree[g]] == k && Min[VertexDegree[g]] == k;

(*main function*)
FindspanningBiGraph[graph_] := Module[
  {g = graph, Csubsets, gtest, i},
  Csubsets = Subsets[EdgeList@g, {5*VertexCount[g]/2}];
  Do[gtest = Graph[Csubsets[[i]]]; 
   If[kRegularQ[gtest, 5] &&  ConnectedGraphQ[gtest] && 
     BipartiteGraphQ[gtest], Print[{"True", gtest}] && Break[]], {i, 
    Length[Csubsets]}]
  ]

g = CompleteGraph[{6, 6}]
FindspanningBiGraph[g]

First of all, this function is written with some defects that occupy too much memory and run slowly. The Subsets function, in particular, is seems not good when the number of edges of a graph is dense.

Wish there is a better way to handle it. Maybe the iteration will work. However, I have not mastered Mathematica's subset iteration method well. Or there is a better algorithm for this particular problem. After all, these subgraphs are special. The tactics we choose in the search are violent.

Answer 1

As OP points out, one limitation is

Subsets[EdgeList@g,{5*VertexCount[g]/2}]

For example, if g is CompleteGraph[n] then there are Binomial[Binomial[n,2],5*n/2] many such subsets when $n$ is even, which for $n=10$ is equal to $3169870830126$.

OPs problem involves several conditions, but to get started, let us take the problem of listing all subgraphs where the vertex degrees are prescribed, in a more efficient way. For example

subgraphs[CompleteGraph[5],{3,3,2,2,2}]

should return all subgraphs where vertices 1,2,3,4,5 have degrees 3,3,2,2,2 respectively. To remove isomorphic ones, one would use

subgraphs[CompleteGraph[5],{3,3,2,2,2}]//DeleteDuplicates[#,IsomorphicGraphQ]&

Using the code below, the result is

What algorithm? I use the following. Step 1: Choose a subset of the edges starting from vertex 1 (as many as needed). Step 2: Choose a subset of the edges starting from vertex 2 to vertices $>2$ (as many as needed taking into account that we may already have selected an edge from vertex $1$ to vertex $2$). Step 3: Choose a subset of the edges starting from vertex 3 to vertices $>3$ (as many as needed taking into account that we may already have selected edges from vertices $<3$ to vertex $3$). And so on.

In this approach, the choice made at Step 1 influences the choices available in later steps, and so on. Probably there is a clever way to implement this kind of "dependent choice" problem exploiting functionality available in Mathematica, but I came up with the following using recursion:

to[g_]:=Lookup[GroupBy[List@@@EdgeList[g],Min,Max@@@#&],
          Sort[VertexList[g]],{}]-Sort[VertexList[g]];
from[sg_]:=Graph[Join@@MapIndexed[Function[{x,p},
              Map[UndirectedEdge[First[p],#]&,First[p]+x]],sg]];
subgraphs[{},{},{}]:={{}};
subgraphs[el_List,d:{__Integer},max:{__}]:=If[Length[el]===Length[d],
  If[MatchQ[d,{___,_?Negative,___}],{},
    Join@@Map[Function[{s},Map[Join[{s},#]&,subgraphs[Rest[el],
      MapAt[#-1&,Rest[d],Transpose[{s}]],Rest[max]]]],
        Subsets[First[el],{First[d]}]//If[Length[#]>First[max],
          #[[1;;First[max]]],#]&]],Abort[]];
subgraphs[g_Graph,d:{__Integer},max_:{}]:=Map[from,subgraphs[to[g],d,
     If[max==={},ConstantArray[Infinity,Length[d]],max]]];

Examples (now including BipartiteGraphQ).

• The example mentioned by OP is obtained using

Select[subgraphs[CompleteGraph[{6,6}],ConstantArray[5,12]]
  //DeleteDuplicates[#,IsomorphicGraphQ]&,BipartiteGraphQ]

and takes about 1 second, which is much faster than OPs code

Unlike OPs program, this program makes a complete list, therefore we can also conclude that this is the only subgraph that satisfies the criteria, up to isomorphism.

• It also works for CompleteGraph[10] using

Select[subgraphs[CompleteGraph[10],ConstantArray[5,10],
         Join[{1},ConstantArray[Infinity,9]]],BipartiteGraphQ]

This takes about 250 seconds. The result is

The result itself is not very interesting, it is simply CompleteGraph[{5,5}], but the point is that the computation finished in 250 seconds. But note that in this last example, I called subgraphs with three arguments, the third argument being {1,Infinity,...,Infinity}. The point of this is to restrict the search space a little bit. The 1 in this case says that in Step 1 only one choice is made. This is no big deal in the case of CompleteGraph[10] since all those choices are isomorphic.

Note. The code assumed that the vertex labels are numbers.