7
$\begingroup$

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?

enter image description here

$\endgroup$
  • $\begingroup$ 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 $\endgroup$ – Szabolcs Oct 1 at 20:50
  • $\begingroup$ clarified, thanks for the snippet $\endgroup$ – Yaroslav Bulatov Oct 1 at 21:21
13
$\begingroup$

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@{}, {}]; 
  GraphComputation`GraphCommunitiesPlotDump`generateBlobs[Automatic, {pts}, size][[2]]]

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[5] 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}}]]

enter image description here

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[[1]], 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}}]

enter image description here

subsetsPlot[9, {Range[7], {3, 6}, {3, 4, 8}, {2, 5, 6, 9}, {8, 9}}]

enter image description here

$\endgroup$
10
$\begingroup$

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[[1]]; (* 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]];
   activeIndices = Thread[content == 1];
   col = Switch[obj[[0]], 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[[0]] === Cumulant && (Total[a[[1]]] > k),
    0,
    a]);

zeroOutMoment[a_, k_] := (
   If[a[[0]] === Moment && (Total[a[[1]]] > 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]

enter image description here

$\endgroup$
  • 1
    $\begingroup$ 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. $\endgroup$ – Carl Woll Oct 2 at 0:22
  • $\begingroup$ thanks...is there a way to get + signs to be bigger? $\endgroup$ – Yaroslav Bulatov Oct 2 at 1:05
  • 1
    $\begingroup$ You could do something like Style[visualize[target ≈ formula], 20]? $\endgroup$ – Carl Woll Oct 2 at 2:41

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.