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

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.

• Is your question "Does MMA have a built-in implementation of UnlabeledSubgraphQ?" or "How can I implement such a function?" If it is the latter, then you'll need to show some original effort.
– VF1
Apr 14, 2013 at 4:12
• @VF1 My original question was: "Does MMA 9 have an implementation? The answer is no. I'm now asking for outside implementations, not for someone to implement an algorithm from the literature. There are multiple non-trivial to implement solutions in the literature. Apr 14, 2013 at 4:40
• Well, what do you think? Apr 16, 2013 at 12:37
• Please see the update to my answer. Oct 28, 2015 at 14:45

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[
___,
{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

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;
h = Subgraph[g, {1, 2, 3}]

SubgraphQ[g, h]


True

SubgraphQ[h, g]


False

• Could you explain a bit how undirRule works? Apr 13, 2013 at 21:29
• @PinoAir It sorts the vertices in undirected edges in canonical order so that there is no difference between 1 <->2 and 2<->1. If you don't do this you might not recognize two vertices as the same just because their nodes are ordered differently. I don't do this for directed edges as I assume that order matters there. Apr 13, 2013 at 21:56
• I believe you should be able to write: undirRule = a_UndirectedEdge :> Sort[a] -- Sort works on heads besides List. (Sorry for the non-vote but I cannot test this as you know.) Apr 13, 2013 at 22:45
• @Sjoerd Unfortunately this is incorrect, unless you consider the graphs to be labelled (but in that case isomorphism is not an issue). Consider: big = Graph[{1 <-> 2, 2 <-> 3, 1 <-> 3, 3 <-> 4}], small = Graph[{1 <-> 2, 1 <-> 4}]. small is clearly a subgraph of big in the usual unlabelled sense, but the function says it isn't. Apr 13, 2013 at 23:30
• @PinoAir You should clarify if you mean the labelled or unlabelled case. When talking about isomorphism, people usually mean the unlabelled case as the labelled one is trivial. Apr 13, 2013 at 23:31

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, GraphData[{"Fullerene", {26, 1}}]]
(* True *)

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

(* {<|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:= IGraph["graph.subisomorphic.vf2"][GraphData[{"Fullerene", {26, 1}}], CycleGraph]

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


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]

(* ==> True *)


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