How to make a graph be a grid layout exactly?

Question

I have a such graph

graph = Graph[{1 <-> 2, 1 <-> 6, 2 <-> 3, 2 <-> 7, 3 <-> 4, 3 <-> 17, 
   4 <-> 5, 4 <-> 9, 5 <-> 10, 6 <-> 7, 7 <-> 17, 7 <-> 12, 17 <-> 9, 
   17 <-> 13, 9 <-> 10, 9 <-> 14, 11 <-> 12, 11 <-> 16, 12 <-> 13, 
   12 <-> 8, 13 <-> 14, 13 <-> 18, 14 <-> 24, 14 <-> 19, 24 <-> 20, 
   16 <-> 8, 16 <-> 21, 8 <-> 18, 8 <-> 22, 18 <-> 19, 18 <-> 23, 
   19 <-> 20, 19 <-> 15, 20 <-> 25, 21 <-> 22, 21 <-> 26, 22 <-> 23, 
   22 <-> 27, 23 <-> 15, 23 <-> 28, 15 <-> 29, 25 <-> 30, 26 <-> 27, 
   27 <-> 28, 28 <-> 29, 29 <-> 30}]

I hope to make it GridEmbedding exactly,which mean all vertex in a regular rectangle shape.Of course if we use VertexCoordinates to specify every position for those vertices,but that will be little troublesome.If I specify a layout of "GridEmbedding" directly,the result always will be depressed like

{PlanarGraph[graph, GraphLayout -> "GridEmbedding"], 
 Graph[graph, GraphLayout -> "GridEmbedding"]}

I even think this is a bug behavior behind method "GridEmbedding".Ok,let's reluctant to sepcify the "Dimension"(Sometimes we don't know the "Dimension" when we deal with a large graph).

Graph[graph, GraphLayout -> {"GridEmbedding", "Dimension" -> {5, 6}}]

It will be more messy.Actually we'd better don't specify the dimension of the grid graph,and a layout like this is expected

---

Update

I'm afraid to make this qeustion too board, but I have to say the current method I have received,include myself try, will fail when we delete the 7 <-> 12 and 17 <-> 13 from graph.

graph = Graph[{1 <-> 2, 1 <-> 6, 2 <-> 3, 2 <-> 7, 3 <-> 4, 3 <-> 17, 
   4 <-> 5, 4 <-> 9, 5 <-> 10, 6 <-> 7, 7 <-> 17, 17 <-> 9, 9 <-> 10, 
   9 <-> 14, 11 <-> 12, 11 <-> 16, 12 <-> 13, 12 <-> 8, 13 <-> 14, 
   13 <-> 18, 14 <-> 24, 14 <-> 19, 24 <-> 20, 16 <-> 8, 16 <-> 21, 
   8 <-> 18, 8 <-> 22, 18 <-> 19, 18 <-> 23, 19 <-> 20, 19 <-> 15, 
   20 <-> 25, 21 <-> 22, 21 <-> 26, 22 <-> 23, 22 <-> 27, 23 <-> 15, 
   23 <-> 28, 15 <-> 29, 25 <-> 30, 26 <-> 27, 27 <-> 28, 28 <-> 29, 
   29 <-> 30}, VertexLabels -> "Name"]

I think the Annealing algorithm can serve here, but I don't know how to implement it.

Answer 1

The basic idea is to transform edge list to lines.

1. Transform edge list to vertex list.
2. Transform vertex list to vertex index list.
3. Transform vertex index list to coordinates.
4. Use these coordinates to draw lines.

In:

xss = {1 <-> 2, 1 <-> 6, 2 <-> 3, 2 <-> 7, 3 <-> 4, 3 <-> 17, 4 <-> 5,
    4 <-> 9, 5 <-> 10, 6 <-> 7, 7 <-> 17, 7 <-> 12, 17 <-> 9, 
   17 <-> 13, 9 <-> 10, 9 <-> 14, 11 <-> 12, 11 <-> 16, 12 <-> 13, 
   12 <-> 8, 13 <-> 14, 13 <-> 18, 14 <-> 24, 14 <-> 19, 24 <-> 20, 
   16 <-> 8, 16 <-> 21, 8 <-> 18, 8 <-> 22, 18 <-> 19, 18 <-> 23, 
   19 <-> 20, 19 <-> 15, 20 <-> 25, 21 <-> 22, 21 <-> 26, 22 <-> 23, 
   22 <-> 27, 23 <-> 15, 23 <-> 28, 15 <-> 29, 25 <-> 30, 26 <-> 27, 
   27 <-> 28, 28 <-> 29, 29 <-> 30};
graph = Graph[xss, VertexLabels -> "Name"]

(* thanks for yode's code to get the dimension*)

spiralGraph = Graph[xss, GraphLayout -> "DiscreteSpiralEmbedding"];
dimension = Length@*Union /@ Transpose[GraphEmbedding[spiralGraph]];
r = Last @ dimension; (* row *)

rules = xss // Map[First] // DeleteDuplicates // {#, Sort[#]} & // 
  MapThread[Rule, #] & (*Vertex \[Rule] Index Rules*) 

List @@@ (xss /. rules) // UndirectedEdge @@@ # & // 
 Graph[#, VertexLabels -> "Name"] &

vertexIndexToCoordinate[n_] := {Quotient[n - 1, r], 
  r - 1 - Mod[n - 1, r]}
List @@@ (xss /. rules) // Map[vertexIndexToCoordinate, #, {2}] & // 
  Line // Graphics

Out:

Updated: 2017-05-09

Appendix

I was asked to solve some more general cases which my method is not covered. There are some constraints,

1. Only edges are known and the corresponding graph's dimension is unknown.
2. Vertices could be numbers/symbols/strings.

I came up a new method to do the grid graph layout.

Limitations

1. In this new method, vertices are natural numbers only. Regarding symbols/strings/other numbers, It could use natural numbers to substitute original vertices, once the layout is done and then replace natural numbers with the original vertices.

2. The maximum unknown graph dimension is {100,100}, the dimension search algorithm could be improved later or or just simply change the maximum dimension parameter.

Test Data

Test data are generated random edge list using random dimension.

(*Random dimension*)
dimension = RandomInteger[{4, 10}, {2}]

(*Random edges*)
xss = Module[{g = GridGraph[dimension], n},
  n = RandomInteger[{Floor[EdgeCount[g]/2], EdgeCount[g] - 6}];
  RandomSample[EdgeList[g], n]]

Implementation

In:

subGridGraphQ[graphEdges_, gridgraphEdges_] := Module[{},
  Intersection[graphEdges, gridgraphEdges] == graphEdges]

sortUndirectedEdges[es_] := 
 es // Map[Sort[List @@ #] &] // SortBy[#, First] & // 
  UndirectedEdge @@@ # &

gridGraphDimentions[m_, n_] := 
  gridGraphDimentions[m, n] = Array[{#1, #2} &, {m, n}] // Catenate;

graphDimension[g_] := Module[{graphEdges, gridGraphQ, dimentions},
  gridGraphQ[graphEdges_, m_, n_] := 
   m > 1 && n > 1 && (m n >= max) && 
    subGridGraphQ[graphEdges, EdgeList@GridGraph[{m, n}]];
  sortUndirectedEdges[es_] := 
   es // Map[Sort[List @@ #] &] // SortBy[#, First] & // 
    UndirectedEdge @@@ # &;
  graphEdges = EdgeList@g // sortUndirectedEdges;
  max = graphEdges // List @@@ # & // Join // Max;
  dimentions = gridGraphDimentions[100, 100];
  dimentions // Select[gridGraphQ[xss, First@#, Last@#] &] // First]

gridGraphLayout[edges_] := Module[{dimension},
  xss = edges // sortUndirectedEdges;

  (*Search for dimension*)
  dimension = graphDimension[Graph[xss]];
  Print["Dimension: " ~~ ToString[dimension]];

  gg = GridGraph[dimension];

  (*Get missing edges *)
  missingEdges = Complement[EdgeList@gg, xss];

  (*Use missing edges to do Grid Layout*)

  EdgeList @@ gg // 
    Graph[#, 
      GraphLayout -> {"GridEmbedding", "Dimension" -> dimension}, 
      VertexLabels -> "Name"] & // 
   HighlightGraph[#, missingEdges, GraphHighlightStyle -> "White"] &]

(*Random dimension*)
dimension = RandomInteger[{4, 10}, {2}]

(*Random edges*)
xss = Module[{g = GridGraph[dimension], n},
  n = RandomInteger[{Floor[EdgeCount[g]/2], EdgeCount[g] - 6}];
  RandomSample[EdgeList[g], n]]

(*Original Graph*)
Graph[xss]
(*Graph using GridGraph Layout*)
gridGraphLayout[xss]

Out:

Answer 2

Firstly,we should judge the dimension of the original graph by "DiscreteSpiralEmbedding" after using PlanarGraph to redraw it.Of course we should check it with real weight and height.

spiralGraph = Graph[graph, GraphLayout -> "DiscreteSpiralEmbedding"];
dim = Length@*Union /@ Transpose[GraphEmbedding[spiralGraph]];
size = PlanarGraph[graph, GraphLayout -> "GridEmbedding"] //
      GraphEmbedding // CoordinateBounds // Transpose // Last;
graphDim = If[GreaterEqual @@ dim && GreaterEqual @@ size, dim, Reverse[dim]]

{6, 5}

Pre-generate the coordinates of layout

gridPos = Tuples[MapThread[Subdivide, {size, graphDim - 1}]];

Build a function to match the curent vertex coordinates with the final coordinates and make a rule for replace the old coordinates with new coordinates

vertexToGrid[pts1_, pts2_] := 
 Module[{g, len = Length[pts1]}, g = RelationGraph[True &, pts1, pts2];
  Rule @@@ FindMinimumCostFlow[g, 
    Flatten[{Array[1 &, len], Array[-1 &, len]}], "EdgeList", 
    EdgeCost -> EuclideanDistance @@@ EdgeList[g]]]

coorRule = Dispatch[vertexToGrid[GraphEmbedding[graph], gridPos]];

Draw the final grid graph

Graph[graph, VertexCoordinates -> 
  Thread[VertexList[graph] -> (GraphEmbedding[graph] /. coorRule)]]

Answer 3

Using the method in this answer to get a mapping to order the vertices appropriately:

gg = GridGraph[{5, 6}, VertexLabels->"Name"];

isomorphisms = DeleteCases[ FindGraphIsomorphism[graph, #] & /@ 
  (EdgeDelete[gg, #] & /@ Subsets[EdgeList[gg], {EdgeCount[gg]-EdgeCount[graph]}]), {}];
vmap = First@MinimalBy[Join@@DeleteCases[Normal @ isomorphisms, Rule[x_, x_], 3], Length];

and use the modified vertex list as the first argument in Graph

Graph[VertexList @ gg /. vmap, EdgeList[graph], 
   VertexLabels -> "Name", GraphLayout -> {"GridEmbedding", "Dimension" -> {5, 6}}]

or, alternatively,

Graph[VertexList@gg /. vmap, EdgeList[graph], 
    VertexLabels -> "Name", VertexCoordinates -> GraphEmbedding[gg]]

to get

Update: This approach also works when we delete the 7 <-> 12 and 17 <-> 13 from graph

graphb= EdgeDelete[graph,{7 <-> 12,17 <-> 13}];

Graph[VertexList@gg /. vmap, EdgeList[graphb], 
  VertexLabels->"Name", VertexCoordinates -> GraphEmbedding[gg]]

Answer 4

yode's solution is interesting, but rather complex. Much too complex, in fact, for me to have ever thought up anything like it. But I did think that even my simple mind could work out a solution, and I have. Of course, because it is the work of a simple mind, it's a simple solution.

I was not interested in the part of problem concerned with finding what yode defines as graphDim. I will assume yode's result.

The code proceeds in three steps.

1. Extracting the vertex coordinates from the graph and making a set of rules that maps the vertex numbers to the coordinates.

2. Sorting the rules by the x-coordinate of the coordinate pair, partitioning the rules into columns, and then sorting the columns by y-coordinate.

3. Making new rules that force the vertices to lie on an integer lattice by replacing each vertex coordinate with its array index in the rule array and finally flattening the array back into a list or rules.

Here is source graph that I used.

g = Graph[{1 <-> 2, 1 <-> 6, 2 <-> 3, 2 <-> 7, 3 <-> 4, 3 <-> 17, 
   4 <-> 5, 4 <-> 9, 5 <-> 10, 6 <-> 7, 7 <-> 17, 7 <-> 12, 17 <-> 9, 
   17 <-> 13, 9 <-> 10, 9 <-> 14, 11 <-> 12, 11 <-> 16, 12 <-> 13, 
   12 <-> 8, 13 <-> 14, 13 <-> 18, 14 <-> 24, 14 <-> 19, 24 <-> 20, 
   16 <-> 8, 16 <-> 21, 8 <-> 18, 8 <-> 22, 18 <-> 19, 18 <-> 23, 
   19 <-> 20, 19 <-> 15, 20 <-> 25, 21 <-> 22, 21 <-> 26, 22 <-> 23, 
   22 <-> 27, 23 <-> 15, 23 <-> 28, 15 <-> 29, 25 <-> 30, 26 <-> 27, 
   27 <-> 28, 28 <-> 29, 29 <-> 30}, VertexLabels -> "Name"]

This makes the lattice graph.

Module[{graphDim, coordRules, ruleGrid, newRules},
  graphDim = {6, 5};
  coordRules = Thread[Rule[VertexList[g], GraphEmbedding[g]]];
  ruleGrid = 
    SortBy[#[[2, 2]] &] /@ 
      Partition[SortBy[coordRules, #[[2, 1]] &], Last[graphDim]];
  newRules = Flatten @ MapIndexed[#1[[1]] -> #2 &, ruleGrid, {2}];
  Graph[EdgeList[g], VertexLabels -> "Name", VertexCoordinates -> newRules]]

Answer 5

I think that, in general, this is a hard problem.

That means that perhaps it is not such a bad idea to map it to other hard problems for which we already have existing implementations: subgraph isomorphism. This is implemented by IGraph/M.

Let us try to map the vertices of graph to a big grid graph like this:

vc = VertexCount[graph];
big = GridGraph[{vc, vc}];

<< IGraphM`

SetProperty[graph, 
 VertexCoordinates -> 
  Normal[GraphEmbedding[big][[#]] & /@ 
    First@IGVF2GetSubisomorphism[graph, big]]
 ]

There may of course be more solutions: you can find them using IGVF2FindSubisomorphisms.

Answer 6

To layout the graph as a grid, we can replace the graph's coordinates with the coordinates of the same dimension grid graph.

In:

xss = {1 <-> 2, 1 <-> 6, 2 <-> 3, 2 <-> 7, 3 <-> 4, 3 <-> 17, 4 <-> 5,
    4 <-> 9, 5 <-> 10, 6 <-> 7, 7 <-> 17, 7 <-> 12, 17 <-> 9, 
   17 <-> 13, 9 <-> 10, 9 <-> 14, 11 <-> 12, 11 <-> 16, 12 <-> 13, 
   12 <-> 8, 13 <-> 14, 13 <-> 18, 14 <-> 24, 14 <-> 19, 24 <-> 20, 
   16 <-> 8, 16 <-> 21, 8 <-> 18, 8 <-> 22, 18 <-> 19, 18 <-> 23, 
   19 <-> 20, 19 <-> 15, 20 <-> 25, 21 <-> 22, 21 <-> 26, 22 <-> 23, 
   22 <-> 27, 23 <-> 15, 23 <-> 28, 15 <-> 29, 25 <-> 30, 26 <-> 27, 
   27 <-> 28, 28 <-> 29, 29 <-> 30};

graph = Graph[xss]
gg = GridGraph[{5, 6}]

normalCoordinates[graph_, gridgraph_] := Module[{gcs, ggcs},
  sortByX[xys_] := SortBy[xys, First];
  sortByY[xyss_] := Map[SortBy[#, Last] &, xyss];
  sortCoordinatesByXY[g_] :=  
   GraphEmbedding@g // sortByX // Partition[#, 5] & // sortByY // 
    Catenate;

  gcs = sortCoordinatesByXY[graph]; (*graph coordinates*)

  ggcs = sortCoordinatesByXY[
    gridgraph]; (*grid graph coordinates*)

  positions = 
   gcs // Map[Position[GraphEmbedding@graph, #] &] // Flatten;
  rules = MapThread[Rule, {positions, ggcs}];
  ReplacePart[GraphEmbedding@graph, rules]
  ]
cs = normalCoordinates[graph, gg];
Graph[xss, VertexCoordinates -> cs]

Out: