8

I am using

dG[nn_] := Graph[With[{aa = Prime@Range@PrimePi@Floor@Sqrt@nn}, 
With[{bb = Sort[Times @@@ Rest@Subsets[aa]]}, #[[1]] -> #[[2]] & /@
Select[Sort@Subsets[Select[bb, # <= nn &], {2}], 
Divisible[#[[2]], #[[1]]] &]]], DirectedEdges -> False, 
VertexLabels -> "Name", GraphLayout -> "TutteEmbedding"]

dG@70

which produces the pleasingly symmetric

enter image description here

and is great up to nn=120. But since "TutteEmbedding" works for 3-connected planar graphs only, beyond that, (although "HighDimensionalEmbedding" is passable for nn=121), I am not getting the desired effect.

Looking here, I think it might be possible to try to get Mathematica to recognise a graph type & fit it to something from GraphData, but I haven't managed any success via this route so far.

Update

If I forgo the Select[bb,#<= nn &] restriction, the result is symmetric for nn=121, but not very readable:

enter image description here

whereas if I relax the the link to all divisors & settle for a path leading through divisors, the Hasse diagram route seems a better option facGraph[5]:

enter image description here

this is extendable of course to the well-known (partial) divisor graph divGraph[3, 4]:

enter image description here

I am still not sure however, to reinforce the Select[bb,#<= nn &] restriction, even after looking here.

<< Combinatorica`;

facGraph[nn_] := With[{aa = Subsets[Prime@Range[nn]]}, 
ShowLabeledGraph[HasseDiagram[MakeGraph[Subsets[Range[nn]], 
((Intersection[#2, #1] == #1) && (#1 != #2)) &, VertexLabel -> "Name"]], 
Map[Style[#, 10, Black] &, Times @@@ aa], PlotRange -> All, 
EdgeColor -> ColorData[97, "ColorList"][[1]], EdgeStyle -> Thin, 
VertexColor -> White, VertexStyle -> {Disk[1/Length@aa]}, 
VertexLabelPosition -> Center, ImageSize -> (20 Length@aa)]]


divGraph[nn_, depth_] := With[{aa = Flatten[SortBy[# & /@ 
SplitBy[DeleteDuplicates[Flatten[Tuples[Prime@Range[nn], #] & /@
Range@(depth), 1], Sort@#1 == Sort@#2 &], PrimeOmega[Times @@ #] &][[#]], 
Times @@ # &] & /@ Range[depth], 1]}, ShowLabeledGraph[
HasseDiagram[MakeGraph[aa, (Divisible[Times @@ 
#2, Times @@ #1] && Length@#2 == Length@#1 + 1) &, VertexLabel -> "Name"]], 
Map[Style[#, 10, Black] &, Times @@@ aa], PlotRange -> All, 
EdgeColor -> ColorData[97, "ColorList"][[1]], EdgeStyle -> Thin, 
VertexColor -> White, VertexStyle -> {Disk[1/Length@aa]}, 
VertexLabelPosition -> Center, ImageSize -> (20 Length@aa)]]
Community
  • 1
martin
  • 8,678
  • 4
  • 23
  • 70
  • Can you explain what your code is computing? What does the Select[bb, # <= nn &] restriction do exactly? –  May 29 '15 at 12:16
  • @Rahul not a lot - just caps the max element (though I'm not sure I've posted the correct version of the code, now you mention it). Am probably quite happy to settle for the Hasse diagram actually - it is pretty readable, thiough I would have preferred not to use Combinatorica. – martin May 29 '15 at 12:24

2 Answers2

3
facGraph[nn_] := 
 With[{aa = 
    Select[Subsets[Prime@Range@PrimePi@Floor@Sqrt@nn], 
     Times @@ # <= nn &]}, 
  ShowLabeledGraph[
   HasseDiagram[
    MakeGraph[aa, (SubsetQ[#2, #1] && (#1 != #2)) &, 
     VertexLabel -> "Name"]], 
   Map[Style[#, 10, Black] &, Times @@@ aa], PlotRange -> All, 
   EdgeColor -> ColorData[97, "ColorList"][[1]], VertexColor -> White,
    VertexStyle -> {Disk[1/Length@aa]}, VertexLabelPosition -> Center,
    ImageSize -> (20 Length@aa)]]

facGraph[70]

enter image description here

1
ClearAll[hasseG]
hasseG[nn_, o:OptionsPattern[]]:=  With[{aa = 
   Select[Times @@@ Subsets[Prime @ Range @ PrimePi @ Floor @ Sqrt @ nn], # <= nn &]}, 
 TransitiveReductionGraph[RelationGraph[Divisible, aa], o, VertexShapeFunction -> "Name", 
 PerformanceGoal->"Quality", BaseStyle -> Arrowheads[0]]]]

Examples:

hasseG[70]

enter image description here

hasseG[121, EdgeStyle -> Red, ImageSize -> 500]

enter image description here

kglr
  • 394,356
  • 18
  • 477
  • 896