Memvisualisasikan kisi partisi set

Question

Ada visualisasi keren dari kumpulan semua partisi lebih dari 4 elemen yang diurutkan berdasarkan penyempurnaan, yang membuatnya menjadi kisi. Dapatkah Mathematica digunakan untuk menghasilkan jenis visualisasi ini secara otomatis? Kisi ini digunakan saat mengkonversi antara momen dan kumulan, juga dikenal sebagai inversi Möbius.

Sebuah pertanyaan terkait ditangani dengan memvisualisasikan entri individu dalam kisi - Membuat diagram partisi set

Answer 1

Fungsi tersebut refinementQ[x, y]kembali Truejika partisi yadalah penyempurnaan partisi 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]);

Kita dapat menggunakan oneElementRefinementQdengan RelationGraphtata letak bawaan "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]] &)]

Sebagai alternatif, kita dapat menggunakan VertexCoordinateskoordinat khusus:

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

Gunakan vCoords2alih-alih di vCoordsmana

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

mendapatkan

Gantikan subsetsPlot[]dengan subsetsPlot["Text"]untuk mendapatkan:

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

Menggunakan

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

bukannya vCoordsmendapatkan

Lampiran: Fungsi dari Membuat diagram partisi set ( subsetsPlotsedikit dimodifikasi):

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]