7
$\begingroup$

I would like to create a Venn Diagram, but I have not found any documentation about it.

There is a lot of information about Intersection, but not much about .

a = {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10};
b = {2, 5, 8, 4, 7};
c = {2, 8};
Graphics[{
  Circle[{0, 0}, 10],
  Circle[{0, 0}, 20],
  Circle[{0, 0}, 30],
  FontSize -> 20,
  Text["0", {0, 25}],
  Text["1", {-21.65063509, 12.5}],
  Text["2", {-3, 0}],
  Text["3", {-21.65063509, -12.5}],
  Text["4", {-12.99038106, -7.5}],
  Text["5", {0, 15}],
  Text["6", {0, -25}],
  Text["7", {12.99038106, -7.5}],
  Text["8", {3, 0}],
  Text["9", {21.65063509, -12.5}],
  Text["10", {21.65063509, 12.5}]
  }]

enter image description here

My question is whether there is a function that recognizes that:

$C\subset B$ and $B\subset A$

And still generate a diagram ...

$\endgroup$
18
$\begingroup$

Below are two different methods for drawing a Venn diagram given a list of sets. The first method places the labels for set elements by finding an evenly distributed list of points in each region using a mesh. I then realized that, with a little coaxing, the WordCloud function could also be used for this task. I added a second method using that idea at the end. The second method also has options for labeling the sets and graphics styling.


Fun example first!

pokelists = EntityClassList["Pokemon"][[{24, 46, 47}]]

Mathematica graphics

VennDiagram[EntityList /@ pokelists, 
  SetLabels -> pokelists, ElementStyle -> 11, ImageSize -> 10 72
]

Mathematica graphics


Method 1

In the following function, suitably spaced positions for the set element labels are found for each region by using DiscretizeRegion to find a mesh, extracting the list of mesh points, and then weeding out points that are too close to each other. If there aren't enough points remaining, additional points are chosen randomly without regard for overlap. Labels are kept away from the edges of the region by subtracting a thickened border region from the region to be meshed.

deleteNearPoints[{processed_, unprocessed_ /; Length@unprocessed < 2}, d_] :=   
  Join[processed, unprocessed]

deleteNearPoints[{processed_, unprocessed_}, d_] := deleteNearPoints[
  {
    Append[processed, First@unprocessed],
    DeleteCases[
      Rest@unprocessed,
      Alternatives @@ Nearest[Rest@unprocessed, First@unprocessed, {Infinity, d}]
    ]
  },
  d
]

VennDiagram[lists : {_List ..}] := Module[
  {d = .6, r = 1, thickness = .15, pointDistance = .1, 
   n = Length@lists, cases, labels, elements, disks, points, region, 
   outlines},
  disks = NestList[
    TransformedRegion[#, RotationTransform[2 Pi/n, {0, 0}]] &,
    Disk[{d, 0}, r],
    n - 1
    ];
  outlines = RegionUnion @@ RegionDifference @@@
    (disks /. Disk[p_, r_] -> {Disk[p, (1 + thickness) r], Disk[p, (1 - thickness) r]});
  cases = Most@Tuples[{True, False}, n];
  labels = Flatten[Table[
     If[
      (elements = Complement[
          Intersection @@ Pick[lists, case],
          Union @@ Pick[lists, Not /@ case]
          ]) == {},
      {},
      region = RegionDifference[
        RegionIntersection[Pick[disks, case]],
        RegionUnion @@ Flatten@{Pick[disks, Not /@ case], outlines}
        ];
      points = MeshCoordinates@DiscretizeRegion[region, MaxCellMeasure -> .01];
      points = deleteNearPoints[{{}, points}, pointDistance];
      If[Length@points < Length@elements,
       Transpose@{elements, 
         Join[points, RandomPoint[region, Length@elements - Length@points]]
       },
       Transpose@{elements, RandomSample[points, Length@elements]}
       ]
      ],
     {case, cases}
     ], 1];
  Show[Graphics[{FaceForm[GrayLevel[0, .04]], EdgeForm[Black], disks, Text @@@ labels}]]
  ]

The OP's sets:

VennDiagram[{a, b, c}]

Mathematica graphics

Some bigger sets:

VennDiagram[Table[RandomSample[Range[60], 40], 2]]

Mathematica graphics

VennDiagram[Table[RandomSample[Range[60], 40], 3]]

Mathematica graphics

Too many elements to fit, resulting in overlapping labels:

VennDiagram[Table[RandomSample[Range[100], 80], 3]]

Mathematica graphics

Some combinations of more than three sets will work, but not in general:

VennDiagram[{
  {0, 1, 2, 3, 13}, {0, 3, 4, 5, 12, 13}, {0, 5, 6, 7, 11, 12, 13}, 
  {0, 7, 8, 11, 12}, {0, 9, 10, 11}
}] 

Mathematica graphics


Method 2

I realized that one can also accomplish this task somewhat more easily and attractively using WordCloud to place the labels. The only complication is that Mathematica generates the word cloud at an arbitrary size -- it needs to be scaled and translated properly to fit on the diagram. I also remove the font scaling so that all the labels have the same font size.

Options[VennDiagram] = 
 Join[{SetLabels -> None, ElementStyle -> {}}, Options[Graphics]]

VennDiagram[lists : {_List ..}, opts : OptionsPattern[]] := Module[
  {d = .6, r = 1, thickness = .05, n = Length@lists, cases, labels, 
   elements, disks, region, outlines, points, bounds, cloud, 
   setlabels, anchor},
  disks = NestList[
    TransformedRegion[#, RotationTransform[2 Pi/n, {0, 0}]] &,
    Disk[{d, 0}, r],
    n - 1
    ];
  setlabels = If[(labelstrings = OptionValue[SetLabels]) === None,
    {},
    Table[
     anchor = {Cos[2 Pi (i - 1)/n], Sin[2 Pi (i - 1)/n]};
     {Line[(d + r) {anchor, 1.05 anchor}],
      Text[Framed@labelstrings[[i]], 1.04 (d + r) anchor, Sign /@ -anchor]
      },
     {i, n}
     ]
    ];
  outlines = RegionUnion @@ RegionDifference @@@
     (disks /. Disk[p_, r_] -> {Disk[p, (1 + thickness) r], Disk[p, (1 - thickness) r]});
  cases = Most@Tuples[{True, False}, n];
  labels = Flatten@Table[
     If[
      (elements = Complement[
          Intersection @@ Pick[lists, case],
          Union @@ Pick[lists, Not /@ case]
          ]) == {},
      {},
      region = RegionDifference[
        RegionIntersection[Pick[disks, case]],
        RegionUnion @@ Flatten@{Pick[disks, Not /@ case], outlines}
        ];
      If[Length[elements] == 1,
       elements = Join[elements, {Invisible["a"], Invisible["b"]}]
       ];
      cloud = WordCloud[elements, region, MaxItems -> All];
      cloud = DeleteCases[cloud, FontSize -> _, Infinity] /.
        Style[args__] -> Style[args, OptionValue@ElementStyle];
      points = MeshCoordinates@DiscretizeRegion@region;
      bounds = MinMax /@ Transpose@points;
      Inset[cloud, Mean /@ bounds, Center, -Subtract @@@ bounds]
      ],
     {case, cases}
     ];
  Show[
   Graphics[{
     FaceForm[GrayLevel[0, .04]], EdgeForm[Black],
     Style[setlabels, OptionValue@LabelStyle], disks, labels
     }, FilterRules[{opts}, Options@Graphics]
    ]
   ]
  ]

I find the bounding box of each region by discretizing and then taking min and max of the mesh points. There is a built-in function RegionBounds that is supposed to accomplish this task, but it seems to be extremely slow in this case. Also, WordCloud does not like making clouds in a region with only one word -- I think that's a bug -- so I add a couple of invisible elements to the list for that case.

Examples:

VennDiagram[{a, b, c}, SetLabels -> {"A", "B", "C"}, LabelStyle -> 14, ElementStyle -> 12]

Mathematica graphics

VennDiagram[Table[RandomSample[Range[200], 100], 3]]

Mathematica graphics

VennDiagram[{
  {0, 1, 2, 3, 13}, {0, 3, 4, 5, 12, 13}, {0, 5, 6, 7, 11, 12, 13}, 
  {0, 7, 8, 11, 12}, {0, 9, 10, 11}
}]

Mathematica graphics

$\endgroup$
  • $\begingroup$ Wonderfu work,just a suggestion,can you label each circle?Like this or by Key of Association,which clear the graph's structure. :) $\endgroup$ – yode Dec 25 '16 at 1:21
  • $\begingroup$ @yode Thanks, yes, I was going to do that, but I got tired...I will add that at some point. $\endgroup$ – Simon Rochester Dec 25 '16 at 1:27
  • $\begingroup$ These deserve a good rest. :) $\endgroup$ – yode Dec 25 '16 at 1:30
  • $\begingroup$ See my answer,just a simple try. $\endgroup$ – yode Dec 25 '16 at 6:33
  • $\begingroup$ @yode Added options for labels and graphics styling. $\endgroup$ – Simon Rochester Dec 25 '16 at 11:32
4
$\begingroup$

For this request

VennDiagram[data : (_Association | _List)] := 
 Module[{posAss, 
   ass = If[Head[data] === Association, data, 
     AssociationThread[Range@Length[data], data]]}, 
  posAss = Map[Plus[#, RandomReal[.2, {2}]] &, 
    Merge[Association@*Thread /@ 
      Thread[Rule[Values[ass], 
        MapIndexed[
         ConstantArray[CirclePoints[Length[ass]][[First[#2]]], 
           Length[#1]] &, Values[ass]]]], Mean]];
  Show[Graphics[{Text @@@ 
      Normal[posAss], {Style[#, Red, 30, Bold] & /@ 
       Text @@@ Normal[Map[Mean, ass /. Normal[posAss]]]}, 
     Circle @@@ 
      MapAt[Plus[#, .1 #] &, 
       BoundingRegion[#, "MinDisk"] & /@ 
        Values[ass /. Normal[posAss]], {All, 2}]}]]]

If we have such Association,I give a Venn Diagram like following:

ass=<|"a"->{1,2,3,5},"b"->{5,3,9,11,12},"c"->{5,9,10,16}|>;
VennDiagram[ass]

Or you have a list:

list = {{1, 2, 3, 5}, {5, 3, 9, 11, 12}, {5, 9, 10, 16}};
VennDiagram[list]

Ps:Actually this diagram is expected(without that extra intersectant part):

enter image description here

Hope to see this diagram be improved.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy