4
$\begingroup$

There's a cool visualization of set of all partition over 4 elements ordered by refinement, which makes it a lattice. Can Mathematica be used to generate these kinds of visualizations automatically? This lattice is used when converting between moments and cumulants, also known as Möbius inversion.

A related question dealt with visualizing individual entries in the lattice -- Generating set partition diagrams

enter image description here

$\endgroup$
6
$\begingroup$

The function refinementQ[x, y] returns True if partition y is a refinement of partition x:

ClearAll[refinementQ, oneElementRefinementQ]

refinementQ[x_, y_] := And @@ (Function[i, Or @@ (SubsetQ[#, i] & /@ x)] /@ y);

oneElementRefinementQ[x_, y_] := And[Length[y] == 1 + Length[x], refinementQ[x, y]]


partitions4 = SortBy[{Length@# &, Min[Length /@ #] &}]@(Sort /@ partition[Range @ 4]);

We can use oneElementRefinementQ with RelationGraph with built-in layout "MultipartiteEmbedding":

RelationGraph[oneElementRefinementQ, partitions4, 
  GraphLayout -> {"MultipartiteEmbedding",  
     "VertexPartition" -> Tally[Length /@ partitions4][[All, -1]]},
  VertexSize -> Large, ImageSize -> 600, 
  EdgeShapeFunction -> "Line", 
  VertexShapeFunction -> (Inset[Framed[
   subsetsPlot["Point", .1, 14, AbsolutePointSize[9], 
         AbsoluteThickness[9]][4, #2], RoundingRadius -> 10, 
       Background -> White], #, {0, 0}, Scaled[.15]] &)]

enter image description here

Alternatively, we can use VertexCoordinates with custom coordinates:

vCoords = ScalingTransform[{1, 1/2}]@RotationTransform[-Pi/2]@
    GraphEmbedding[CompleteGraph[Length /@ GatherBy[partitions4, Length]]];

RelationGraph[oneElementRefinementQ, partitions4, 
 ImageSize -> 700, 
 VertexCoordinates -> vCoords, VertexSize -> Large, 
 EdgeShapeFunction -> "Line", 
 VertexShapeFunction -> 
     (Inset[Framed[subsetsPlot[][4, #2], RoundingRadius -> 20, 
        Background -> White], #, {0, 0}, Scaled[.15]] &)]

enter image description here

Use vCoords2 instead of vCoords where

vCoords2 = Join @@ MapIndexed[
    Thread[{If[# == 1, {0}, Subdivide[-1, 1, # - 1]], (1 - #2[[1]])/2}] &,
    Length /@ GatherBy[partitions4, Length]]

to get

enter image description here

Replace subsetsPlot[] with subsetsPlot["Text"] to get:

enter image description here

partitions5 = SortBy[{Length@# &, Min[Length /@ #] &}]@(Sort /@ 
     partition[Range@5]);

vCoords = ScalingTransform[{3/2, 1}] @ RotationTransform[-Pi/2]@
    GraphEmbedding[CompleteGraph[Length /@ GatherBy[partitions5, Length]]];

RelationGraph[oneElementRefinementQ, partitions5,  
 ImageSize -> 800, VertexCoordinates -> vCoords, VertexSize -> Large, 
 EdgeShapeFunction -> "Line", 
 VertexShapeFunction -> 
      (Inset[Framed[subsetsPlot["Point", .1, 14, AbsolutePointSize[4], 
        AbsoluteThickness[6]][5, #2], RoundingRadius -> 5, 
      Background -> White, FrameMargins -> -5], #, {0, 0}, Scaled[.05]] &)]

enter image description here

Use

vCoords2 = Join @@ MapIndexed[
    Thread[{If[# == 1, {0}, Subdivide[-1, 1, # - 1]], (1 - #2[[1]])/(5 - 2)}] &, 
    Length /@ GatherBy[partitions5, Length]]

instead of vCoords to get

enter image description here

Appendix: Functions from Generating set partition diagrams (subsetsPlot slightly modified):

ClearAll[partition, boX, bloB, subsetsPlot]

partition[{x_}] := {{{x}}}
partition[{r__, x_}] := Join @@ (ReplaceList[#, {{b___, {S__}, a___} :> 
   {b, {S, x}, a}, {S__} :> {S, {x}}}] & /@ partition[{r}])

boX[a : {_, _}, e_] := a + # & /@ Tuples[{-e, e}, {2}]
boX[a : {{_, _} ..}, e_] := Flatten[boX[#, e] & /@ a, 1]

bloB[x_, e_] := Switch[Length @ x, 1, Point@x, 2, Line@x, _, 
  FilledCurve[BSplineCurve[#, SplineClosed -> True] & @@ 
    ConvexHullMesh[boX[x, e]]["FaceCoordinates"]]]

subsetsPlot[vshape : ("Point" | "Text") : "Point", size_: .4, 
    ts_: 14, aps_: AbsolutePointSize[15], 
    at_: AbsoluteThickness[20]][n_, subsets_, o : OptionsPattern[Graphics]] := 
 Graphics[{Black, If[vshape == "Text", 
    MapIndexed[Text[Style[#2[[1]], ts], #] &, CirclePoints[n]], 
   {AbsolutePointSize[aps[[1]]/2], Point@CirclePoints[n]}], 
     RandomColor[], Opacity[.5], aps, at, CapForm["Round"], 
     bloB[CirclePoints[n][[#]], size]} & /@ subsets, o, ImagePadding -> 10]
| improve this answer | |
$\endgroup$
  • $\begingroup$ Looks nice! BTW, lattice for size 4 is isomorphic to the hypercube, I wonder if pre-built embeddings can make this easier to understand -- GraphData[{"Hypercube", 4}, "Graph", "All"] $\endgroup$ – Yaroslav Bulatov Oct 14 at 17:20
  • $\begingroup$ @YaroslavBulatov, "MultipartiteEmbedding" gives the cleanest picture among the built-in layouts i have tried. Re {"Hypercube", 4}, I probably misinterpreted the picture in your question, because i don't see how how the partition lattice is isomorphic to {"Hypercube", 4}. $\endgroup$ – kglr Oct 14 at 20:13
  • $\begingroup$ You can see it for a smaller set. IE, partition lattice for sets of size 2 is isomorphic to {Hypercube, 2} -- vertical edges represent adding or removing first element, horizontal correspond to the second element $\endgroup$ – Yaroslav Bulatov Oct 14 at 22:02
  • 1
    $\begingroup$ @YaroslavBulatov, GraphData[{"Hypercube", n}] is isomorphic to the Hasse diagram of SubsetQ on subsets lattice of Range[n] ; but I don't see how any graph on set partitions of Range[n] can be isomorphic to hypercube[n] because the vertex counts are not the same. $\endgroup$ – kglr Oct 15 at 1:26
  • $\begingroup$ Ah, you a are right $\endgroup$ – Yaroslav Bulatov Oct 15 at 1:27

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.