Visualisation du treillis de partition d'ensemble

Question

Il y a une visualisation cool de l'ensemble de toutes les partitions sur 4 éléments classés par raffinement, ce qui en fait un treillis. Mathematica peut-il être utilisé pour générer automatiquement ce type de visualisations? Ce réseau est utilisé lors de la conversion entre moments et cumulants, également appelée inversion de Möbius.

Une question connexe concernait la visualisation des entrées individuelles dans le treillis - Génération de diagrammes de partition de groupe électrogène

Answer 1

La fonction refinementQ[x, y]retourne Truesi partition yest un raffinement de 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]);

Nous pouvons utiliser oneElementRefinementQavec RelationGraphavec une mise en page intégrée "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]] &)]

Alternativement, nous pouvons utiliser VertexCoordinatesavec des coordonnées personnalisées:

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]] &)]

Utiliser vCoords2plutôt que vCoordsoù

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

obtenir

Remplacez subsetsPlot[]par subsetsPlot["Text"]pour obtenir:

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]] &)]

Utilisation

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

au lieu d' vCoordsobtenir

Annexe: Fonctions des diagrammes de partition des groupes électrogènes ( subsetsPlotlégèrement modifiés):

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]