Is there something akin to "SubgraphIsomorphismQ" in Mathematica 9?

Question

Provided two unlabeled graphs, $G$ and $H$, I would like to test where $H$ is a subgraph of $G$. In other words, I'd like to test whether we can prune some fixed number of vertices or edges from $G$ to transform it into the graph $H$.

Is there an implementation for something like this in Mathematica 9, or perhaps available elsewhere? Efficiency, within reason, doesn't matter too much to me.

NOTE - I can somewhat tolerate false-positives, but no false negatives.

Answer 1

I'll first introduce an auxiliary function, FindSubgraph, that I will use to define the function SubgraphIsomorphismQ the OP asks for. It finds the shortest subgraph of the main graph that is isoporphic to a graph you specify.

This is the second version of this function. This one is slower, but repairs a problem with my original concept. The description of the older version (provided below) remains mostly valid, apart from the part about sorting.

The function basically sets up a matching pattern for the anonymous edges in the edge list of the subgraph that is to be found. The reason they are 'anonymous' is that we are looking for 'unlabeled' graphs (note that the original question didn't have this requirement; an answer to that question is given at the very bottom of this post).

Interesting in the implementation is that I used two layers of abstract labeling of the pattern. First we have anonymous labeling of the vertex pairs in a pattern, and this pattern is anonymously labeled as well to be able to refer to the results of the match. I also used an (undefined) function with the Orderless attribute to force Mathematica to try to find matching edges in any possible order.

ClearAll[FindSubgraph];

FindSubgraph[big_?UndirectedGraphQ, small_?UndirectedGraphQ] :=
 Module[{vl = VertexList[small], 
         el = EdgeList[small] /. UndirectedEdge[ a_, b_] :> UndirectedEdge[a,b] | UndirectedEdge[b,a], 
         v, pv, e, pe, f},
  SetAttributes[f, Orderless];
  v = Table[Unique[], {Length@vl}];
  pv = Pattern[#, _] & /@ v;
  e = Table[Unique[], {Length@el}];
  f @@ EdgeList[big] /.
   (f @@ Riffle[MapThread[Pattern, {e, el}] /. Thread[vl -> pv], ___, {1, -1, 2}]) -> e
 ]

Note that the use of Riffle here is merely a remnant of my previous version. However, I kept it this way as it is also a convenient way to insert the maximum number of ___ patterns that may be necessary. Due to the Orderless function, riffling the ___ isn't necessary anymore (but it doesn't do harm either).

This following two tests were reasonably fast:

bmg = GraphData["BrinkmannGraph"];

HighlightGraph[bmg, 
   FindSubgraph[
     bmg, 
     Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 5 <-> 6, 6 <-> 7, 7 <-> 1}]
   ]
]

HighlightGraph[bmg, 
  FindSubgraph[
    bmg, 
    Graph[{"ape" <-> "nut", "nut" <-> "mouse", "mouse" <-> "dad", 
           "dad" <-> "sheep", "sheep" <-> "goat", "goat" <-> "ape"}
    ]
  ]
]

but this one took like 20 minutes:

fg = GraphData[{"Fullerene", {26, 1}}];

HighlightGraph[fg, 
   FindSubgraph[
     fg, 
     Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 5 <-> 6, 6 <-> 7, 7 <-> 8, 8 <-> 1}]
   ]
]

Older version

I'll first introduce a function that tries to find the shortest subgraph of a graph that contains all the edges of a given second graph (in isomorphical sense). I take it for given that the graphs are undirected (I could use UndirectedGraph to make sure they are).

ClearAll[FindSubgraph];
FindSubgraph[big_?UndirectedGraphQ, small_?UndirectedGraphQ] :=
 Module[{vl = VertexList[small], el = EdgeList[small], v, pv, e, pe},
  v = Table[Unique[], {Length@vl}];
  pv = Pattern[#, _] & /@ v;
  e = Table[Unique[], {Length@el}];
  Graph[
   Sort[Sort /@ EdgeList[big]] /.
    Riffle[
      MapThread[Pattern, {e, Sort[Sort /@ el]}] /. Thread[vl -> pv],
      ___, 
      {1, -1, 2}
    ] -> e
  ]
]

It's a bit (too?) complicated, so I'll explain a bit what's going on here.

Fist step is sorting all the edge lists in canonical order. I sort both the edges and the vertices making up the edges. Since we have undirected graphs, this doesn't change the graphs in principle. The reason for this is to prepare for pattern matching.

Second step is converting each edge in the small graph into a pattern of the form $100:_$50<->$51. All the vertices are replaced by a unique pattern (like $50<->$51, the /.Thread[vl -> pv]) does that). This takes care of the 'unlabeling' of the graph (makes it independent of the actual names of the vertices). The MapThread[Pattern part takes care of naming this pattern.

Riffle is used to generate the final pattern by mixing in BlankNullSequence (___). The end result is a pattern like {___,$100:_$50<->$51,___,$101:_$51<->$52,___}

What follows is a simple replacement with /.. By default, Mathematica tries to find the shortest match and the replacement returns the corresponding edges in the big graph as a Graph.

Test

bmg = GraphData["BrinkmannGraph"];

HighlightGraph[bmg, 
    FindSubgraph[
      bmg, 
      Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 5 <-> 6, 6 <-> 7, 7 <-> 1}]
    ]
]

Let's show that this really finds an isomorphic graph, without need for explicitly using labels from the big graph:

HighlightGraph[bmg, 
  FindSubgraph[
    bmg, 
    Graph[{"ape" <-> "nut", "nut" <-> "mouse", "mouse" <-> "dad", 
           "dad" <-> "sheep", "sheep" <-> "goat", "goat" <-> "ape"}
    ]
  ]
]

With this function in place, it is easy to find the SubgraphIsomorphismQ function:

SubgraphIsomorphismQ[big_?UndirectedGraphQ, small_?UndirectedGraphQ] :=
   Length[EdgeList@FindSubgraph[big, small]] == Length[EdgeList@small]

Test

SubgraphIsomorphismQ[bmg, Graph[{1 <-> 2, 2 <-> 3, 3 <-> 1}]]

False

(indeed, there is no loop with three nodes)

SubgraphIsomorphismQ[bmg, Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4}]]

True

Szabolcs' example from the comments:

SubgraphIsomorphismQ[Graph[{1 <-> 2, 2 <-> 3, 1 <-> 3, 3 <-> 4}], Graph[{1 <-> 2, 1 <-> 4}]]

True

---

Older stuff: labeled graphs only

SubgraphQ[bigGraph_, smallGraph_] := 
 With[{undirRule = UndirectedEdge[a__] :> UndirectedEdge @@ Sort[{a}]},
   Intersection[EdgeList[bigGraph] /. undirRule, EdgeList[smallGraph] /. undirRule] 
           ===  Sort[EdgeList[smallGraph] /. undirRule]
  ]

g = CompleteGraph[5];
h = Subgraph[g, {1, 2, 3}]

SubgraphQ[g, h]

True

SubgraphQ[h, g]

False

Answer 2

2015 Update:

IGraph/M has three different functions for this: IGSubisomoprhicQ (generic), IGVF2SubisomorphicQ and IGLADSubisomorphicQ. The last one can also check for induced subgraphs (i.e. you can only remove vertices, but not edges).

Demo:

IGLADSubisomorphicQ[CycleGraph[5], GraphData[{"Fullerene", {26, 1}}]]
(* True *)

IGLADSubisomorphicQ[CycleGraph[5], 
 GraphData[{"Fullerene", {26, 1}}], "Induced" -> True]
(* True *)

IGLADGetSubisomorphism[CycleGraph[5], GraphData[{"Fullerene", {26, 1}}]]
(* {<|1 -> 1, 2 -> 7, 3 -> 18, 4 -> 12, 5 -> 6|>} *)

To get a specific mapping, use IGGetSubisomorphism. To get multiple or all mappings, use IGVF2FindIsomorphisms or IGLADFindSubisomorphisms.

---

Older version

A solution based on IGraphR:

In[23]:= IGraph["graph.subisomorphic.vf2"][GraphData[{"Fullerene", {26, 1}}], CycleGraph[5]]

Out[23]= RObject[{{True}, 
  {1., 2., 0., 0., 0., 0., 5., 3., 0., 0., 0.,
    0., 4., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.}, 
  {1., 2., 8., 13., 7.}}, 
 RAttributes["names" :> {"iso", "map12", "map21"}]]

Note that you also get back one possible mapping.

---

Oldest version

You can use RLink in Mathematica 9 to access this functionality in the igraph library.

First, start R separately from Mathematica and run install.packages("igraph").

Then start Mathematica and connect to the external R version. On OS X I did this:

<< RLink`
SetEnvironment["DYLD_LIBRARY_PATH" -> "/Library/Frameworks/R.framework/Resources/lib"]
InstallR["RHomeLocation" -> "/Library/Frameworks/R.framework/Resources"]

Load igraph:

REvaluate["library(igraph)"]

Make the function convenient to call from Mathematica (this is for undirected ones only, but you can easily fix it up to work for both):

Clear[subisomophicQ]
subisomophicQ[g1_?GraphQ, g2_?GraphQ] := 
 Extract[RFunction["function (e1,e2) {
        g1 <- graph.edgelist(e1, directed=F);
        g2 <- graph.edgelist(e2, directed=F);
        graph.subisomorphic.vf2(g1,g2,NULL,NULL,NULL,NULL)  
    }"][List @@@ EdgeList[g1], List @@@ EdgeList[g2]], {1, 1, 1}]

Try it:

subisomorphicQ[GraphData[{"Fullerene", {26, 1}}], CycleGraph[5]]

(* ==> True *)

If you remove the Extract part, you'll also get the precise mapping between the bigger and smaller graphs.