5
$\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$

1 Answer 1

8
$\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]
$\endgroup$
5
  • $\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$ Oct 14, 2020 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, 2020 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$ Oct 14, 2020 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, 2020 at 1:26
  • $\begingroup$ Ah, you a are right $\endgroup$ Oct 15, 2020 at 1:27

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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