6
$\begingroup$

I made a graph that has a given number at each vertex:

Lattice Graph for D_16

I want to place vertex 1 above vertex 2 if value of vertex 1 is larger than of vertex 2. And also, vertices with same value should be located on the same horizontal line.

Above graph satisfies the condition. (I think because of luck.)

But, another graph constructed by the same function does not satisfy it:

Lattice Graph for D_10

Here 5 is not above 2.

How can I implement this condition?

(The height of the gap between 2 and 5 does not need to be exactly 3 times the height gap between 1 and 2.)

==== Editted ====

Here is the code for function makes the graph. (I simplified it.)

LatticeGraph[group_] :=
    Module[{subgroup = (*omitted*), nodes, edges, list},
        nodes = Table[Property[Labeled[i, Placed[subgroup[[i]], Center]],(*VertexStyle Omitted*)], {i, 1, Length[subgroup]}];
        list = {(*Omitted and it's used for generate edges*)}
        edges = {(*Omitted and it was just the list of v1->v2*)};

        Graph[nodes, edges, VertexSize -> Large,EdgeShapeFunction -> GraphElementData["Line"], ImagePadding -> 20]]
$\endgroup$
  • $\begingroup$ How did you make the first one? And the second one? Please provide some code. $\endgroup$ – Öskå Aug 7 '14 at 10:23
  • $\begingroup$ Ok. I will edit my post. $\endgroup$ – Analysis Aug 7 '14 at 10:25
  • 1
    $\begingroup$ Why omitting parts? You should provide the subgroup, list etc who produced the second Graph at least. $\endgroup$ – Öskå Aug 7 '14 at 10:46
  • 1
    $\begingroup$ I think it is not related to this question. you can consider subgroup as the list of values, ex) {10,5,2,2,2,2,2,1} for the second image. and the list of edges are not needed since my condition is just for vertices, not for edges. $\endgroup$ – Analysis Aug 7 '14 at 10:51
  • 1
    $\begingroup$ Your two examples show some regularities that could be exploited to get a simple function, but you need to be more specific about them. For example, no edges between "twin" nodes, no "Mixed Layers" links, etc. $\endgroup$ – Dr. belisarius Aug 7 '14 at 12:24
3
$\begingroup$
vertices = Range[7];
labels = {10, 5, 2, 2, 2, 2, 1};
(* Note: if labels is not already sorted in descending order, 
   use labels = Sort[labels, Greater] -- thanks: @TeakeNutma  *)
labels2 = Thread[vertices -> 
         (Placed[#, Center] & /@ (Rotate[#, 90 Degree] & /@labels))];
vp = Last /@ Tally[labels]; (*thanks: Oska *)
edges = UndirectedEdge @@@ {{1, 2}, {1, 3}, {1, 4}, {1, 5}, 
                            {1, 6}, {2, 7}, {3, 7}, {4, 7}, {5, 7}, {6, 7}};

Rotate[
  Graph[vertices, edges,
        VertexLabels -> labels2,
        VertexSize -> Large,
        GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> vp}], -90 Degree]

enter image description here

Update: To deal with overlapping edges,

Modify vertex coordinates for selected edges:

vertices2 = Range[8];
newedges = UndirectedEdge @@@ {{1, 8}, {8, 7}};
edges2 = Join[edges, newedges] /. {7 -> 8, 8 -> 7};
labels2 = {10, 5, 2, 2, 2, 2, 2, 1};
labels2b =  Thread[vertices2 -> (Placed[#, Center] & /@ 
                                (Rotate[#, 90 Degree] & /@ labels2))];
vp2 = Last /@ Tally[labels2]; 

gA = Graph[vertices2, edges2, VertexLabels -> labels2b, 
          VertexSize -> Large, 
          GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> vp2}];
vc = # /.  MapIndexed[#1 -> #1 + {0, (-1)^(First@#2) .15} &, 
                      Cases[#, {_, 0.}][[2 ;; -2]]] &@GraphEmbedding[gA];
Rotate[SetProperty[gA, VertexCoordinates -> vc], -90 Degree]

enter image description here

Or, keep the VertexCoordinates and use an EdgeShapeFunction to curve selected edges:

esF = Function[{pts}, 
        If[pts[[1, 2]] == pts[[2, 2]] && pts[[2, 1]] - pts[[1, 1]] > 1, 
           BezierCurve[{pts[[1]], {(pts[[1, 1]] + pts[[2, 1]])/2, 
                      pts[[2, 2]] + (-1)^(1 + Round[pts[[1, 1]]]) (#)}, pts[[2]]}], 
           Line[{pts[[1]], pts[[2]]}]]] &;
gB = Graph[vertices2, edges2, VertexLabels -> labels2b, 
          VertexSize -> Large, 
          GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> vp2},
          EdgeShapeFunction -> esF[.3]];
Rotate[gB, -90 Degree]

enter image description here

$\endgroup$
  • $\begingroup$ @Oska, thank you.. I updated with your suggestion using Tally to get vertex partition. Although GraphLayout was introduced in version 8, it was updated substantially in version 9. MapAt also went through some undocumented/silent updates in version 9. $\endgroup$ – kglr Aug 7 '14 at 15:34
  • $\begingroup$ This only works if the labels are in reverse canonical order; e.g. labels = {5, 10, 2, 2, 2, 2, 1} fails. Some sorting should fix this though. $\endgroup$ – Teake Nutma Aug 7 '14 at 15:57
  • $\begingroup$ @TeakeNutma Yes, I added the code for sorting before using this method. $\endgroup$ – Analysis Aug 7 '14 at 16:02
  • $\begingroup$ @TeakeNutma, thank you. Will update with your suggestion. $\endgroup$ – kglr Aug 7 '14 at 16:17
  • $\begingroup$ You would be faster to directly do labels=Sort[labels,Greater]. I guess it wouldn't cost too much computing time. $\endgroup$ – Öskå Aug 7 '14 at 16:24
4
$\begingroup$

What you are looking for is a kind of Hasse diagram. Unfortunately, there is no GraphLayout that does exactly what you want out of the box. (Although kguler has shown in his answer you can coax "MultipartiteEmbedding" into the desired behaviour).

However, it still can also be done with specifying the option VertexCoordinates of Graph. This requires us to compute appropriate coordinates of all vertices based on their label. It's a bit of work, but perfectly doable nonetheless.

Since you haven't given the necessary details of your graph generating function, I'll be using your second example with an additional "2" vertex:

vertices = Thread @ Labeled[Range[8], {10, 2, 2, 2, 2, 5, 1, 2}];
edges    = UndirectedEdge @@@ {
    {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, {1, 8},
    {2, 7}, {3, 7}, {4, 7}, {5, 7}, {6, 7}, {7, 8}
}

We need to determine the vertex coordinates from their labels. For this you can write a custom function (which is what I did in the first draft of this answer), but you can also use the power of the Combinatorica package:

Block[{$ContextPath},
  << Combinatorica`;
]

coordinates = Sequence @@@ Extract[
  Combinatorica`HasseDiagram @ Combinatorica`MakeGraph[vertices, Last@#1 < Last@#2 &], 
  2
]
{{0., 4.}, {-1.5, 2.}, {-0.5, 2.}, {0.5, 2.}, {1.5, 2.}, {0., 3.}, {0., 1.}}

Finally, these coordinates can then be plugged into Graph as an argument for VertexCoordinates to get the desired result:

Graph[vertices, edges, VertexCoordinates -> coordinates]

Mathematica graphics

There is overlap in some of the edges; this can be fixed by simply adding a random perturbation to the x-coordinates of the vertices::

perturbedcoordinates = coordinates /. {x_Real, y_Real} :> {x + RandomReal[{-1, 1}/3], y}

Graph[vertices, edges, VertexCoordinates -> perturbedcoordinates]

Mathematica graphics

$\endgroup$
  • $\begingroup$ I like the new one :D $\endgroup$ – Öskå Aug 7 '14 at 13:27
  • $\begingroup$ @Öskå Thanks; I also like it much better than my first version (and that's why I changed it :). $\endgroup$ – Teake Nutma Aug 7 '14 at 13:28
  • $\begingroup$ I wonder how you found the Combinatorica`HasseDiagram @ Combinatorica`MakeGraph:D $\endgroup$ – Öskå Aug 7 '14 at 13:34
  • $\begingroup$ @Öskå Well, it's also in the A of the Q&A I linked to, but I initially found it here. The Combinatorica docs are a bit sparse unfortunately. $\endgroup$ – Teake Nutma Aug 7 '14 at 13:40
  • $\begingroup$ It is apparently useful :) $\endgroup$ – Öskå Aug 7 '14 at 13:43

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.