# Generating set partition diagrams

I recently came across a very nice illustration of set partitions on wikipedia (Partition of a set article)

I need to reproduce this diagram in order to modify some things, does anyone have a good starting code?

• I don't quite understand the difference between what you show and what you want. Can you clarify? Here's some code for what you show: pastebin.com/evFXi3pE Oct 1, 2019 at 20:50
• clarified, thanks for the snippet Oct 1, 2019 at 21:21

I need to reproduce this diagram ...

We can use the function blobF from this answer to generate blobs around subsets:

ClearAll[blobF, fC, partition]
fC[pts_, size_: .04] := Module[{}, CommunityGraphPlot[Graph@{}, {}];
GraphComputationGraphCommunitiesPlotDumpgenerateBlobs[Automatic, {pts}, size][]]

blobF[g_, cols_, coms_, size_: .04] := Thread[{cols, EdgeForm[{Gray, Thin}], Opacity[.25],
fC[PropertyValue[{g, #}, VertexCoordinates] & /@ #, size] & /@ coms}];


and the function partition from this answer by Mr.Wizard to generate set partitions:

partition[{x_}] := {{{x}}}

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


We first sort the output of partition:

partitions5 = SortBy[{-Length@# &, Max[Length /@ #] &}] @ partition[Range@5];


and use blobF on subgraphs of CycleGraph corresponding to partition elements:

cg = CycleGraph[5, ImageSize -> 80, ImagePadding -> 12, VertexLabels -> "Name",
VertexLabelStyle -> 10, VertexSize -> Medium, VertexStyle -> Black,
EdgeShapeFunction -> None];

graphs = SetProperty[cg, {Epilog -> blobF[cg, RandomColor[Length@#], #, .07]}] & /@
partitions5;

Grid[Join[{{First @ graphs, SpanFromLeft, SpanFromLeft, SpanFromLeft,  SpanFromLeft}},
Partition[Rest @ Most @ graphs, 5],
{{Last @ graphs, SpanFromLeft, SpanFromLeft, SpanFromLeft, SpanFromLeft}}]] Update: Slightly more streamlined approach to generate plot of an arbitrary collection of subsets:

ClearAll[boX, bloB, subsetsPlot]
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[n_, subsets_, size_: .1, o : OptionsPattern[Graphics]] :=
Graphics[{Black, MapIndexed[Text[Style[#2[], 14], 1.15 #] &, CirclePoints[n]],
PointSize[.02], Point @ CirclePoints[n],
RandomColor[], PointSize[0.07], Opacity[.5], Thickness[.075], CapForm["Round"],
bloB[CirclePoints[n][[#]], size]} & /@ subsets, o, ImagePadding -> 10]


Examples:

subsetsPlot[9, {{3}, {1, 2, 6}, {4, 5, 8}, {7, 9}}] subsetsPlot[9, {Range, {3, 6}, {3, 4, 8}, {2, 5, 6, 9}, {8, 9}}] Starting with @Szabolc code I ended up with something below. I needed to get some approximate formulas for moments by dropping higher cumulants. The font size ended up a bit too small but worked otherwise (is there an easy way to make all text parts larger?)

(* Converts Moments term to Cumulant term and visa versa *)

conv[a_Moment] := MomentConvert[a, "Cumulant"];
conv[a_Cumulant] := MomentConvert[a, "Moment"];

(* Get positions of every term involving moment or cumulant *)

termPositions[expr_] := (
poses0 = Most /@ Position[expr, Moment];
poses1 = Most /@ Position[expr, Cumulant];
poses0~Join~poses1
);

(* Convert all moment (or cumulant) terms in the expression *)

convDeep[expr_] := (
MapAt[conv, expr, termPositions[expr]]
)

col0 = ColorData["Pastel"][0.2]; (* moment *)
col1 =
ColorData["Pastel"][0.8]; (* cumulant *)
Clear[pic];
pic[obj_] := (
content = obj[]; (* Cumulant[{0,0,1,0}] => {0,0,1,0} *)

pts = CirclePoints[Length@content];
pts = RotateRight[pts]; (* i, j, k, l in counter-clockwise order *)

labels = {"i", "j", "k", "l"};
labels0 = labels[[;; Length@content]];
col = Switch[obj[], Moment, col0, Cumulant, col1];
pts0 = Pick[pts, activeIndices];
labels0 = Pick[labels0, activeIndices];
Graphics[{{FaceForm[col],
EdgeForm@Directive[col, Thickness[0.15], JoinForm["Round"]],
Polygon[pts0]}, {Black, PointSize[0.07], Point[pts]}},
Frame -> True, PlotRangePadding -> Scaled[.1], FrameTicks -> None,
PlotLabel -> StringJoin[labels0], ImageSize -> Tiny]
);

visualize[expr_] := (
poses0 = Most /@ Position[expr, Moment];
poses1 = Most /@ Position[expr, Cumulant];
MapAt[pic, expr, poses0~Join~poses1]
);

(* Zeros out cumulant of order greater than k *)

zeroOutCumulant[a_, k_] := (
If[a[] === Cumulant && (Total[a[]] > k),
0,
a]);

zeroOutMoment[a_, k_] := (
If[a[] === Moment && (Total[a[]] > k),
0,
a]);

(* Truncate cumulant expansion at 2 *)
truncate[expr_] := (
MapAt[zeroOutCumulant[#, 2] &, expr, termPositions[expr]]
);

expr = Cumulant[{1, 1}];
visualize[conv@expr]
target = Moment[{1, 1, 1, 1}];
formula =
truncate[conv@
target]; (* convert to cumulants and drop higher order terms *)
\
formula =
FullSimplify@
convDeep[formula];(* convert back to moments *)
visualize[
target \[TildeEqual] formula] • You can add LabelStyle -> {FontSize->16} to change the plot label size (or Style[StringJoin[labels0], 16]), you can use ImageSize -> Automatic -> {75,75} so that the size of each rectangle is the same, and you can use BaselinePosition -> Axis -> Center so that the axis of each graphic is lined up. Oct 2, 2019 at 0:22
• thanks...is there a way to get + signs to be bigger? Oct 2, 2019 at 1:05
• You could do something like Style[visualize[target ≈ formula], 20]? Oct 2, 2019 at 2:41