12
$\begingroup$

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

Mathematica graphics

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

Mathematica graphics

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

Mathematica graphics

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

Mathematica graphics

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

$\endgroup$
  • 1
    $\begingroup$ Is this not the same as your older question? mathematica.stackexchange.com/q/129156/12 $\endgroup$ – Szabolcs Apr 26 '17 at 16:55
  • $\begingroup$ @Szabolcs For specifing what I want to get ,I have edited it.. $\endgroup$ – yode Apr 26 '17 at 23:46
  • 1
    $\begingroup$ kglr, in a comment to my answer, has pointed out that your last update specifically invalidates that answer. I am quite upset that you did not have courtesy to take the trouble to inform me of this update. $\endgroup$ – m_goldberg Apr 27 '17 at 19:49
  • $\begingroup$ Anyone can help to check it is a bug behavoir of "GridEmbedding" or not?Then I can decide to add a bug tag. $\endgroup$ – yode Apr 28 '17 at 7:14
10
$\begingroup$

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:

enter image description here

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: enter image description here

$\endgroup$
  • 1
    $\begingroup$ Your method provide a very good thinking,which even astonish me.Thanks very much.And If I have a spare time,I will refine a method based on your thinking.. $\endgroup$ – yode Apr 28 '17 at 9:30
  • $\begingroup$ And I note you directly use Quotient[n - 1, 5].Could we get that $5$ by code method just by your xss? $\endgroup$ – yode Apr 28 '17 at 10:25
  • $\begingroup$ I planned to do that. :) $\endgroup$ – UnchartedWorks Apr 28 '17 at 11:29
  • $\begingroup$ It's done. I used your method to get the dimension. :) $\endgroup$ – UnchartedWorks Apr 28 '17 at 12:51
  • $\begingroup$ That is not a good solution,I will update it in future. $\endgroup$ – yode Apr 28 '17 at 13:10
5
$\begingroup$

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

Mathematica graphics

$\endgroup$
  • $\begingroup$ What if the starting grid were 2 by 10, or some other oblong shape? Then spiral embedding will not tell you the dimensions. Assuming that only edges are missing from the grid, not vertices, the grid size may be any of {#, vc/#} & /@ Select[Divisors[vc], # <= Sqrt[vc] &], where vc = VertexCount[graph. $\endgroup$ – Szabolcs May 9 '17 at 12:31
  • $\begingroup$ @Szabolcs Do you have any example about the spiral embedding fail to judge that dimension? $\endgroup$ – yode May 9 '17 at 13:14
  • $\begingroup$ For example, use graph = GridGraph[{2, 10}] and run the code from this post. There are 20 nodes in this graph. These nodes could be arranged either in a 4 by 5 grid or a 2 by 10 grid. $\endgroup$ – Szabolcs May 9 '17 at 13:17
  • $\begingroup$ @UnchartedWorks This is why I have not accept your answer all the time(though I am very like it.). I don't realize the question metioned by Szabolcs, but I don't very trust my method to get that dimension,which haunt me around.. $\endgroup$ – yode May 9 '17 at 13:26
5
$\begingroup$

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

source

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

graph

$\endgroup$
5
$\begingroup$

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

Mathematica graphics

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

Mathematica graphics

$\endgroup$
4
$\begingroup$

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

Mathematica graphics

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

$\endgroup$
  • $\begingroup$ vc can be Max[Length@*Union /@ Transpose[ GraphEmbedding[ Graph[graph, GraphLayout -> "DiscreteSpiralEmbedding"]]]]? $\endgroup$ – yode May 8 '17 at 2:09
  • $\begingroup$ @yode It was not clear to me if you are assuming that only edges can be deleted from the graph, or also vertices. If only edges are missing, then you can find the possible grid sizes like in here: mathematica.stackexchange.com/a/145440/12 $\endgroup$ – Szabolcs May 9 '17 at 12:37
  • $\begingroup$ @yode, I think it's indeed the best answer so far. It can even accept symbolic vertices. As Szabolcs said, this is a (sub)isomorphism problem. It's a surprise that you didn't choose this as the accepted answer. $\endgroup$ – UnchartedWorks May 10 '17 at 16:09
  • $\begingroup$ @UnchartedWorks Busy days, and I'm trying to make myself answer still. But I will always accept one answer. $\endgroup$ – yode May 10 '17 at 16:23
  • $\begingroup$ @UnchartedWorks The problem with this answer is that it relies on an external tool. It cannot be used in Mathematica Online. kglr's answer is less efficient, but it uses only builtin functions. $\endgroup$ – Szabolcs May 10 '17 at 16:52
1
$\begingroup$

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:

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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