2
$\begingroup$

My graph is as follows.

g=Graph[{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12},
{UndirectedEdge[1, 2], UndirectedEdge[1, 3], UndirectedEdge[1, 4], UndirectedEdge[2, 5], 
UndirectedEdge[4, 5], UndirectedEdge[2, 6], UndirectedEdge[2, 7], UndirectedEdge[2, 8], 
UndirectedEdge[3, 8], UndirectedEdge[3, 9], UndirectedEdge[4, 9], UndirectedEdge[5, 10], 
UndirectedEdge[6, 10], UndirectedEdge[9, 10], UndirectedEdge[6, 11], UndirectedEdge[7, 11],
UndirectedEdge[9, 11], UndirectedEdge[7, 12], UndirectedEdge[8, 12], UndirectedEdge[9, 12],
UndirectedEdge[1, 8], UndirectedEdge[2, 3], UndirectedEdge[1, 9], UndirectedEdge[3, 4], 
UndirectedEdge[1, 5], UndirectedEdge[4, 2], UndirectedEdge[2, 10],UndirectedEdge[5, 6], 
UndirectedEdge[2, 11], UndirectedEdge[6, 7], UndirectedEdge[2, 12], UndirectedEdge[7, 8], 
UndirectedEdge[3, 12], UndirectedEdge[8, 9], UndirectedEdge[4, 10], UndirectedEdge[9, 5], 
UndirectedEdge[6, 9], UndirectedEdge[10, 11], UndirectedEdge[7, 9], UndirectedEdge[11, 12]}, 
{EdgeShapeFunction -> {UndirectedEdge[1, 8] -> {"CurvedEdge", "Curvature" -> 3}, 
UndirectedEdge[2, 3] -> {"CurvedEdge", "Curvature" -> 3}}, FormatType -> TraditionalForm, 
GraphHighlight -> {UndirectedEdge[2, 3], UndirectedEdge[2, 10], UndirectedEdge[1, 5], 
UndirectedEdge[8, 9],UndirectedEdge[2, 12], UndirectedEdge[3, 12], UndirectedEdge[2, 11], 
UndirectedEdge[11, 12],UndirectedEdge[1, 8], UndirectedEdge[4, 2], UndirectedEdge[5, 6],
UndirectedEdge[9, 5], UndirectedEdge[1, 9], UndirectedEdge[6, 7], UndirectedEdge[7, 8], UndirectedEdge[6, 9], 
UndirectedEdge[10, 11], UndirectedEdge[7, 9], UndirectedEdge[3, 4], UndirectedEdge[4, 10]}, 
GraphHighlightStyle -> {UndirectedEdge[7, 8] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[5, 6] -> {EdgeStyle -> {{{Dashing[{Small, Small}],
GrayLevel[0], AbsoluteThickness[1]}}}},UndirectedEdge[8, 9] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[6, 9] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[1, 8] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[4, 10] -> {EdgeStyle -> {{{Dashing[{Small, Small}],
GrayLevel[0], AbsoluteThickness[1]}}}},UndirectedEdge[2, 11] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[2, 12] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, 
UndirectedEdge[7, 9] -> {EdgeStyle -> {{{Dashing[{Small, Small}], GrayLevel[0], AbsoluteThickness[1]}}}}, 
UndirectedEdge[4, 2] -> {EdgeStyle -> {{{Dashing[{Small, Small}], GrayLevel[0], AbsoluteThickness[1]}}}},
UndirectedEdge[3, 12] -> {EdgeStyle -> {{{Dashing[{Small, Small}],
GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[2, 3] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, 
UndirectedEdge[11, 12] -> {EdgeStyle -> {{{Dashing[{Small,Small}], GrayLevel[0], AbsoluteThickness[1]}}}}, 
UndirectedEdge[1, 5] -> {EdgeStyle -> {{{Dashing[{Small, Small}], GrayLevel[0], AbsoluteThickness[1]}}}}, 
UndirectedEdge[3, 4] -> {EdgeStyle -> {{{Dashing[{Small, Small}], GrayLevel[0], 
AbsoluteThickness[1]}}}}, UndirectedEdge[1, 9] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[6, 7] -> {EdgeStyle -> {{{Dashing[{Small, Small}], GrayLevel[0], 
AbsoluteThickness[1]}}}}, UndirectedEdge[10, 11] -> {EdgeStyle -> {{{Dashing[{Small, Small}], 
GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[2, 10] -> {EdgeStyle -> {{{Dashing[{Small, 
Small}], GrayLevel[0], AbsoluteThickness[1]}}}}, UndirectedEdge[9, 5] -> {EdgeStyle -> 
{{{Dashing[{Small, Small}], GrayLevel[0], AbsoluteThickness[1]}}}}},GraphLayout -> "TutteEmbedding",
ImageSize -> {871.8329670329658, Automatic}, PlotRange -> 2, VertexCoordinates -> {{-1.8369701987210297*^-16, 1.}, 
{1., 1.2246467991473532*^-16}, {-1., -2.4492935982947064*^-16}, {0.17983821157707894, 0.380956302850689}, {0.5179703755811089, 
0.14286048039806887}, {0.5827152767774986, 4.06048298747889*^-6}, {0.517970375581109, -0.1428538053162018}, 
{6.123233995736766*^-17, -1.}, {0.02156445069733078, 4.005049120137105*^-6}, 
{0.37408336768531275, 0.04762284864339216}, {0.3740833676853128, -0.04761524659469806}, {0.17984494209281332, -0.38094993342236055}}}]

enter image description here

I wanted to search for all subgraphs of g isomorphic to $K_{3,3}$. So I called the function IGLADFindSubisomorphisms inside the IGraphM package.

Needs["IGraphM`"]
HighlightGraph[g, Subgraph[g, #], GraphHighlightStyle -> "Thick"] & /@
  Union[Sort@*Values /@ 
   IGLADFindSubisomorphisms[CompleteGraph[{3, 3}], g]]

![enter image description here

But in many drawn graphs, some edges of a subgraph $K_{3,3}$ that should be highlighted in red are not marked. I guess it's a property modification problem. When I remove all properties of g, all the subgraphs $K_{3,3}$'s are remark red and thick correctly.

g1 = AnnotationDelete[g]
HighlightGraph[g1, Subgraph[g1, #], GraphHighlightStyle -> "Thick"] & /@ 
 Union[Sort@*Values /@ 
   IGLADFindSubisomorphisms[CompleteGraph[{3, 3}], g1]]

enter image description here enter image description here

I would like to ask how to display these subgraphs well without deleting the attributes of the graph g. Because by removing the attributes, the layout of the graph g is disrupted and not conducive to observation.


Edits (Very surprised): I just noticed that even in the graph with the attributes removed, it did not show subgraph $K_{3,3}$ that I wanted. For example, the degree of $v$ in the figure above is $4$ in the red subgraph, not $3$?!

enter image description here

$\endgroup$

2 Answers 2

1
$\begingroup$

You could set custom Style for HighlightGraph:

Multicolumn[
 HighlightGraph[g, Style[#, Thick, Red, EdgeForm[{Red, Thick}]], 
    ImageSize -> 200] & /@ 
  FindIsomorphicSubgraph[g, CompleteGraph[{3, 3}], All], 4]

enter image description here

$\endgroup$
2
  • 1
    $\begingroup$ FindIsomorphicSubgraph does not find all subgraphs. Please see my answer. $\endgroup$
    – Szabolcs
    Commented Oct 12, 2022 at 8:20
  • $\begingroup$ @Szabolcs it's fixed in the upcoming version $\endgroup$
    – halmir
    Commented Oct 18, 2022 at 14:10
3
$\begingroup$

Edits (Very surprised): I just noticed that even in the graph with the attributes removed, it did not show subgraph $K_{3,3}$ that I wanted. For example, the degree of $v$ in the figure above is $4$ in the red subgraph, not $3$?!

This is because you are highlighting subgraphs that are induced by certain vertex sets. There is no induced $K_{3,3}$ in your graph:

In[52]:= sg = CompleteGraph[{3, 3}];

In[53]:= IGLADFindSubisomorphisms[sg, g, "Induced" -> True]
Out[53]= {}

This is how you highlight all not-necessarily-induced matches:

In[56]:= subgraphs = DeleteDuplicatesBy[
   EdgeList[sg] /. IGLADFindSubisomorphisms[sg, g],
   Sort[Sort /@ #] & (* canonicalize undirected edge set, assuming no tagged edges *)
 ];

In[57]:= Length[subgraphs]
Out[57]= 40

In[58]:= 
HighlightGraph[g, Graph[#], GraphHighlightStyle -> "Thick"] & /@ 
 Take[subgraphs, 4]

enter image description here

Notice the difference between Graph[subgraphs[[1]]] and Subgraph[g, VertexList[subgraphs[[1]]]].

It's also good to point out that some of these subgraphs have the same vertices, but different edges. We can get these groups of subgraphs as follows:

Select[GroupBy[subgraphs, Sort@*VertexList], Length[#] > 1 &]

Let's visualize the first group:

HighlightGraph[g, Graph[#], GraphHighlightStyle -> "Thick"] & /@ 
 SelectFirst[GroupBy[subgraphs, Sort@*VertexList], Length[#] > 1 &]

enter image description here

As you point out in the comments, the built-in FindIsomorphicSubgraph appears to miss these, and seems to consider all subgraphs with the same vertex set as identical, even though this is not the case. This must be the reason why it finds only 30:

In[78]:= Length@FindIsomorphicSubgraph[g, sg, All]
Out[78]= 30

As you show in your question, we'd get 30 results if we'd filter this way:

In[80]:= Length@DeleteDuplicatesBy[IGLADFindSubisomorphisms[sg, g], Sort@*Values]
Out[80]= 30

I think you are right and FindIsomorphicSubgraph is buggy. However, FindSubgraphIsomorphism appears to work correctly. All of the following find the same number of subisomorphisms:

In[82]:= 
Length@#[sg, g] & /@ {IGLADFindSubisomorphisms,IGVF2FindSubisomorphisms, FindSubgraphIsomorphism[##, All] &}

Out[82]= {2880, 2880, 2880}

On the FindIsomorphicSubgraph bug

An obvious way to demonstrate the bug in FindIsomorphicSubgraph is FindIsomorphicSubgraph[CompleteGraph[4], CycleGraph[4], All], which returns a single result, even though there are clearly more. FindCycle[CompleteGraph[4], {4}, All] returns three distinct results. I reported this to WRI.

$\endgroup$
2
  • $\begingroup$ Thank you very much. I see. But I have another question. You get 80 $K_{3,3}$s, but the built-in function FindIsomorphicSubgraph[g, CompleteGraph[{3, 3}], All] gets 30. Is the built-in function not searching enough? $\endgroup$
    – licheng
    Commented Oct 12, 2022 at 7:52
  • 1
    $\begingroup$ @licheng I think you're right and FindIsomorphicSubgraph is buggy. I updated the answer. I was also filtering duplicates incorrectly. There are only 40, not 80. I did not canonicalize undirected edges. $\endgroup$
    – Szabolcs
    Commented Oct 12, 2022 at 8:08

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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