Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
    
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 '13 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. –  PinoAir Apr 14 '13 at 4:40
    
Please see another updated answer. –  Sjoerd C. de Vries Apr 14 '13 at 23:48
    
Well, what do you think? –  Sjoerd C. de Vries Apr 16 '13 at 12:37
add comment

2 Answers 2

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] /. a_ <-> b_ :> a <-> b | 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}]
   ]
]

enter image description here

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

enter image description here

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}]
   ]
]

enter image description here

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}]
    ]
]

enter image description here

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"}
    ]
  ]
]

enter image description here

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

share|improve this answer
    
Could you explain a bit how undirRule works? –  PinoAir Apr 13 '13 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. –  Sjoerd C. de Vries Apr 13 '13 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.) –  Mr.Wizard Apr 13 '13 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. –  Szabolcs Apr 13 '13 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. –  Szabolcs Apr 13 '13 at 23:31
show 13 more comments

EDIT: Easier version based on this package:

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.


Old 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.

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.