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$
5
  • $\begingroup$ How did you make the first one? And the second one? Please provide some code. $\endgroup$
    – Öskå
    Commented Aug 7, 2014 at 10:23
  • $\begingroup$ Ok. I will edit my post. $\endgroup$
    – Analysis
    Commented Aug 7, 2014 at 10:25
  • 1
    $\begingroup$ Why omitting parts? You should provide the subgroup, list etc who produced the second Graph at least. $\endgroup$
    – Öskå
    Commented Aug 7, 2014 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
    Commented Aug 7, 2014 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$ Commented Aug 7, 2014 at 12:24

2 Answers 2

5
$\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$
7
  • $\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
    Commented Aug 7, 2014 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$ Commented Aug 7, 2014 at 15:57
  • $\begingroup$ @TeakeNutma Yes, I added the code for sorting before using this method. $\endgroup$
    – Analysis
    Commented Aug 7, 2014 at 16:02
  • $\begingroup$ @TeakeNutma, thank you. Will update with your suggestion. $\endgroup$
    – kglr
    Commented Aug 7, 2014 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å
    Commented Aug 7, 2014 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$
7
  • $\begingroup$ I like the new one :D $\endgroup$
    – Öskå
    Commented Aug 7, 2014 at 13:27
  • $\begingroup$ @Öskå Thanks; I also like it much better than my first version (and that's why I changed it :). $\endgroup$ Commented Aug 7, 2014 at 13:28
  • $\begingroup$ I wonder how you found the Combinatorica`HasseDiagram @ Combinatorica`MakeGraph:D $\endgroup$
    – Öskå
    Commented Aug 7, 2014 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$ Commented Aug 7, 2014 at 13:40
  • $\begingroup$ It is apparently useful :) $\endgroup$
    – Öskå
    Commented Aug 7, 2014 at 13:43

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.