Finding Kuratowski subdivisions of nonplanar graphs

Here is a (roughly?) quadratic algorithm (in the number of edges) making use of PlanarGraphQ as a black box. The strategy is to delete as many edges as possible while keeping the graph nonplanar. Each iteration of the While loop does the following: it removes edges starting from the last one until the graph becomes planar, then puts the last edge removed at the start of the edge list. This edge cannot be removed without making the graph planar. Doing the loop collects such unremovable edges until there is no other edge left to look at. Note that PlanarGraphQ is called Length[EdgeList[g]] times. The Unsubdivide function simply contracts vertices of degree 2 to get either $K_5$ or $K_{3,3}$ as an output. It's not entirely clear what information you want to keep at the end (e.g. the list of vertices in an edge of the contracted graph) so I've not kept anything (other than vertex names).

ClearAll[KuratowskiSubgraph, UnSubdivide];
Module[{edges, nfound, pos},
  KuratowskiSubgraph[g_Graph] := (
     edges = DeleteDuplicatesBy[EdgeList[g], Sort];
     nfound = 0;
     While[nfound < Length[edges],
      pos = SelectFirst[Range[Length[edges] - 1, nfound, -1],
        PlanarGraphQ[Graph[edges[[;; #]]]] &];
      edges = Join[{edges[[pos + 1]]}, edges[[;; pos]]];
      nfound += 1];
     Graph[edges]);
  ];
UnSubdivide[g_Graph] :=
  Graph[Fold[#1 /. {el1___, UndirectedEdge[a___, #2, b___],
        el2___, UndirectedEdge[c___, #2, d___], el3___} :>
       {el1, el2, el3, UndirectedEdge[a, b, c, d]} &,
    EdgeList[g],
    Select[VertexList[g], VertexDegree[g, #] == 2 &]]];

On the example you gave,

g = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 5, 2 <-> 6, 3 <-> 7, 
   4 <-> 8, 5 <-> 9, 6 <-> 10, 7 <-> 11, 8 <-> 12, 9 <-> 13, 
   10 <-> 14, 11 <-> 14, 12 <-> 14, 13 <-> 14, 2 <-> 3, 3 <-> 4, 
   4 <-> 5, 10 <-> 11, 11 <-> 12, 12 <-> 13, 6 <-> 8, 7 <-> 9}]
g2 = KuratowskiSubgraph[g]
g3 = UnSubdivide[g2]

gives $K_{3,3}$ with vertices 1,3,6 connected to vertices 2,4,14. Looking at InputForm[g2] we can see what edges of the original graph connect 1 to 14 for instance: 1-5-9-13-14.

IGraph/M now has functionality to work with planar graphs. Raspberry Pi support is still missing in release 0.3.100, but it will be re-added soon.

g = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 5, 2 <-> 6, 3 <-> 7, 
   4 <-> 8, 5 <-> 9, 6 <-> 10, 7 <-> 11, 8 <-> 12, 9 <-> 13, 
   10 <-> 14, 11 <-> 14, 12 <-> 14, 13 <-> 14, 2 <-> 3, 3 <-> 4, 
   4 <-> 5, 10 <-> 11, 11 <-> 12, 12 <-> 13, 6 <-> 8, 7 <-> 9}]

Check that the graph is not planar:

IGPlanarQ[g]
(* False *)

We can find a Kuratowski subgraph as a set of edges:

kuratowski = IGKuratowskiEdges[g]
(* {11 \[UndirectedEdge] 12, 10 \[UndirectedEdge] 11, 
 8 \[UndirectedEdge] 12, 7 \[UndirectedEdge] 9, 
 7 \[UndirectedEdge] 11, 6 \[UndirectedEdge] 10, 
 5 \[UndirectedEdge] 9, 4 \[UndirectedEdge] 5, 4 \[UndirectedEdge] 8, 
 3 \[UndirectedEdge] 4, 3 \[UndirectedEdge] 7, 2 \[UndirectedEdge] 6, 
 1 \[UndirectedEdge] 5, 1 \[UndirectedEdge] 3, 1 \[UndirectedEdge] 2} *)

If the graph were planar, the result would have been {}.

Highlight it in the original graph:

HighlightGraph[g, Graph[kuratowski]]

Is this homeomorphic to $K_{3,3}$ or to $K_5$? Let's reduce it:

IGSmoothen[Graph[kuratowski]]

It has 6 vertices, so it must be $K_{3,3}$. Let's make that a bit more obvious using an appropriate visualization:

IGLayoutBipartite[%]

Finally, let us also do an explicit test using IGHomeomorphicQ.

IGHomeomorphicQ[Graph[kuratowski], CompleteGraph[{3, 3}]]
(* True *)

---

As a side note, IGraph/M can also work with combinatorial embeddings of non-planar graphs.

Generate an embedding from the particular drawing of this graph:

emb = IGCoordinatesToEmbedding[g]
(* <|1 -> {4, 5, 2, 3}, 2 -> {3, 1, 6}, 3 -> {7, 4, 1, 2}, 
 4 -> {5, 1, 3, 8}, 5 -> {9, 1, 4}, 6 -> {10, 8, 2}, 7 -> {9, 3, 11}, 
 8 -> {12, 4, 6}, 9 -> {5, 7, 13}, 10 -> {14, 11, 6}, 
 11 -> {14, 12, 7, 10}, 12 -> {13, 8, 11, 14}, 13 -> {9, 12, 14}, 
 14 -> {13, 12, 11, 10}|> *)

The embedding is not planar:

IGPlanarQ[emb]
(* False *)

We can find the faces of this particular embedding:

IGFaces[emb]
(* {{1, 4, 5}, {1, 5, 9, 13, 14, 10, 6, 2}, {1, 2, 3}, {1, 3, 
  4}, {2, 6, 8, 4, 3, 7, 9, 5, 4, 8, 12, 13, 9, 7, 11, 12, 8, 6, 10, 
  11, 7, 3}, {10, 14, 11}, {11, 14, 12}, {12, 14, 13}} *)

It has 8 faces, which means that it can be drawn on a surface of genus 2 (according to Euler's formula):

genus[emb_?IGEmbeddingQ] := (2 + Total[Length /@ emb]/2 - Length[emb] - Length@IGFaces[emb])/2

genus[emb]
(* 2 *)

Of course, this doesn't prove that there isn't an embedding on a surface of smaller genus.

Also, we could have figured this out from looking at a 3D drawing of the graph:

Graph3D[g, VertexLabels -> Automatic]

From this 3D visualization it's clear that removing 3 <-> 4 and 11 <-> 12 would make a drawing on a spherical surface possible (which is the same as planarity).

IGPlanarQ@EdgeDelete[g, {3 <-> 4, 11 <-> 12}]
(* True *)