How to plot Venn diagrams with Mathematica?

Question

How does one plot Venn diagrams with Mathematica? I've searched quite a bit and I've found one source at MathWorld which provides the source code for doing them.

But I don't understand this code, can someone help me?

Answer 1

Based on that outdated notebook, I did the following function:

VennDiagram2[n_, ineqs_: {}] := 
 Module[{i, r = .6, R = 1, v, grouprules, x, y, x1, x2, y1, y2, ve},
  v = Table[Circle[r {Cos[#], Sin[#]} &[2 Pi (i - 1)/n], R], {i, n}];
  {x1, x2} = {Min[#], Max[#]} &[
    Flatten@Replace[v, 
      Circle[{xx_, yy_}, rr_] :> {xx - rr, xx + rr}, {1}]];
  {y1, y2} = {Min[#], Max[#]} &[
    Flatten@Replace[v, 
      Circle[{xx_, yy_}, rr_] :> {yy - rr, yy + rr}, {1}]];
  ve[x_, y_, i_] := 
   v[[i]] /. Circle[{xx_, yy_}, rr_] :> (x - xx)^2 + (y - yy)^2 < rr^2;
  grouprules[x_, y_] = 
   ineqs /. 
    Table[With[{is = i}, Subscript[_, is] :> ve[x, y, is]], {i, n}];
  Show[
   If[MatchQ[ineqs, {} | False], {},
    RegionPlot[grouprules[x, y],
     {x, x1, x2}, {y, y1, y2}, Axes -> False]
    ],
   Graphics[v]
   , PlotLabel -> 
    TraditionalForm[Replace[ineqs, {} | False -> ∅]], 
   Frame -> False
   ]
  ]

Which can have as inequallity any logical expression with subscripts:

EDIT: It works with more than 3 groups!

EDIT2: As Brett says, some cases of 5 doesn't work, like VennDiagram2[5, Subscript[A, 1] && ! (Subscript[A, 2] || Subscript[A, 5]) && Subscript[A, 3] && Subscript[A, 4]], but for example if you change the order to something else it works: VennDiagram2[5, Subscript[A, 1] && ! (Subscript[A, 3] || Subscript[A, 4]) && Subscript[A, 2] && Subscript[A, 5]]. So an intelligent way of sorting the circles should be needed for complex cases.

Answer 2

You get nice Venn diagrams using W|A, eg.:

= (A inter B) un (C inter D)

the inter is esc inter esc and the un is esc un esc

or skipping the opening = which doesn't work in the midst of a program:

WolframAlpha["(A \[Intersection] B) \[Union] (C \[Intersection] D)", \
{{"VennDiagram", 1}, "Content"}]

Answer 3

A series of n cosine functions at successively doubled frequencies can be phased so their signs produce a Gray Code (– for 0, + for 1).

If these cosines are also scaled to successively halved amplitudes, they partition the plane over one major cycle into 2^n non-overlapping regions, just like the circles of a Venn diagram. These regions cover the angle axis in equal intervals of width 2 Pi / 2^n.

When wrapped around the origin in a polar plot, all but one of the regions is bounded, as in a typical Venn diagram.

grayCosines = 
  Table[If[i == 0, -Cos[θ - π/2], -(
     Cos[2^(i - 1) θ]/2^(i - 1))], {i, 0, 5 - 1}];

Plot[grayCosines, {θ, 0, 2 π}]

 

ArrayPlot@Transpose@Table[UnitStep/@grayCosines,{θ,2^-5/2,2π,2^-5 2π}]

 

PolarPlot[Evaluate[1 + 0.6 grayCosines], {θ, 0, 2 π}]

Then the regions can be shaded according to some logical expression, as suggested by Alan.

Here’s everything bundled into an interactive form. "expression" is the logical expression used to shade the diagram. "scale" controls the overall amplitude of the cosines, while "zoom" controls local amplitude near the unit circle, which is handy when there are several variables.

ClearAll@grayCosines;
DynamicModule[
 {nMax, θ, grayCosines, thicknesses, lineColors, labelPosns, 
  zoomF, expression, zoom, scale, n},

 nMax = 8;
 grayCosines = 
  Table[If[i == 0, -Cos[θ - π/2], -(
     Cos[2^(i - 1) θ]/2^(i - 1))], {i, 0, nMax - 1}];
 labelPosns = 
  Prepend[{1, (3 π)/2}]@
   Table[{2^(1 - i), 2^(1 - i) π}, {i, nMax - 1}];
 thicknesses = 
  Thickness /@ (0.003 Prepend[1]@
      Table[1.0 - 0.7 (i - 1)/(nMax - 2), {i, nMax - 1}]);
 lineColors = 
  Prepend[Hue[0, 1, 1]]@
   Table[Hue[FractionalPart@N[i/GoldenRatio], 1, (3 + i - 2 nMax)/(
     4 - 2 nMax)], {i, nMax - 1}];
 zoomF[r_, k_] := 1/2 - 1/π ArcTan[k Cot[(π r)/2]];

 Manipulate[Module[
   {input, variables, varsPadded, predicates, regionPredicate, 
    regionGraphics, boundaryGraphics, labelGraphics},

   input = BooleanConvert[expression // FullSimplify, "ANF"];
   variables = BooleanVariables[input];
   n = Length@variables;
   varsPadded = PadRight[variables, nMax, "??"];
   predicates = (r < 
         zoomF[1 + scale #, zoom] /. {r -> Sqrt[
          x^2 + y^2], θ -> ArcTan[x, y]}) & /@ grayCosines;
   regionPredicate = input /. Thread[varsPadded -> predicates];

   regionGraphics = RegionPlot[
     regionPredicate,
     {x, -1.05, 1.05}, {y, -1.05, 1.05},

     MaxRecursion -> ControlActive[2, 5],
     BoundaryStyle -> None,
     PlotStyle -> LightGray,
     ImageSize -> Full,
     Frame -> False
     ];

   boundaryGraphics = PolarPlot[
       zoomF[1 + scale #[[1]], zoom],
       {θ, 0, 2 π},

       PlotStyle -> {#[[2]], #[[3]]},
       Axes -> False
       ] & /@ ({grayCosines, thicknesses, lineColors}\[Transpose][[
       1 ;; n]]);

   labelGraphics = Graphics[
     Text[Style[#[[1]], {Bold, #[[3]], FontSize -> 14}], #[[2]]] & /@ 
      Transpose[{
         varsPadded,
         (1.08 zoomF[1 + scale #[[1]], zoom] {Cos[#[[2]]], 
              Sin[#[[2]]]} & /@ labelPosns),
         lineColors
         }][[1 ;; n]]
     ];

   Show[regionGraphics, boundaryGraphics, labelGraphics]
   ],

  Column[{
    Deploy@
     Control[{expression, (b ⊻ (a \[Implies] c)) && d, 
       InputField}],
    Row@{
      Control[{{zoom, 3.0}, 1.0, 9.999}], Spacer[10],
      Dynamic@NumberForm[zoom, {3, 2}], Spacer[30],
      Dynamic@Plot[zoomF[r, zoom], {r, 0.0, 2.0}, Axes -> False]
      },
    Row@{
      Control[{{scale, 0.4}, 0.0, 1.0}], Spacer[10],
      Dynamic@NumberForm[scale, {3, 2}]
      }
    }]
  ],

 SaveDefinitions -> True
 ]

Up to nMax variables (set to 8 here) are supported, but more variables take more time. Relations can also be used in place of variables, but I haven't tried to ensure that equivalent terms are treated as one.

Answer 4

This is DrMajorBob's solution from MathGroup:

area[r1_, r2_, 
   d_] := -(1/2)*
    Sqrt[(d + r1 - r2) (d - r1 + r2) (-d + r1 + r2) (d + r1 + r2)] + 
   r1^2 ArcCos[(d^2 + r1^2 - r2^2)/(2 d r1)] + 
   r2^2 ArcCos[(d^2 - r1^2 + r2^2)/(2 d r2)];

VennDiagram[area1_?Positive, area2_?Positive, overlap_?NonNegative] /;
    overlap <= Min[area1, area2] := Module[
   {x2, r1 = Sqrt[area1/Pi], r2 = Sqrt[area2/Pi], d, colors, circles},
   d = Which[overlap == 0, r1 + r2, overlap == Min[area1, area2], 
     r1 - r2, True, 
     Chop[d /. FindRoot[area[r1, r2, d] == overlap, {d, r1}]]];
   colors = {Pink, Lighter@Lighter@Blue};
   circles = {{{0, 0}, r1}, {{d, 0}, r2}};
   Graphics[
    MapThread[{AbsoluteThickness@3, #1, [email protected], Disk @@ #2, 
       Opacity@1, Circle @@ #2} &, {colors, circles}]]
   ];

VennDiagram[5, 3, 1]

And here is a more straightforward way using RegionPlot, building on the code of Eric W. Weisstein (link in OP):

xx = -1; yy = 0; rr = 1;
SetOptions[RegionPlot, Epilog -> {Circle[], Circle[{xx, yy}, rr]}, 
  AspectRatio -> 1, Frame -> False, ImageSize -> 150];
GraphicsGrid[{{
   RegionPlot[0 < x^2 + y^2 < 1, {x, -2.5, 1.5}, {y, -2, 2}],
   RegionPlot[
    0 < (x - xx)^2 + (y + yy)^2 < 1, {x, -2.5, 1.5}, {y, -2, 2}],
   RegionPlot[
    0 < x^2 + y^2 < 1 ∨ 0 < (x - xx)^2 + (y + yy)^2 < 1, {x, -2.5,
      1.5}, {y, -2, 2}],
   RegionPlot[
    0 < x^2 + y^2 < 1 ∧ 
     0 < (x - xx)^2 + (y + yy)^2 < 1, {x, -2.5, 1.5}, {y, -2, 2}]
   }}]

Answer 5

I am taking the approach of helping the OP understand the code he's already found, to explain how to re-implement obsolete code, rather than just re-implenting it. FJRA's answer already does this perfectly well. The core of the code in the linked notebook is the following. It uses the obsolete InequalityPlot in the Graphics`InequalityGraphics` package.

VennDiagram[n_, ineqs_: {}] := Module[{i, r = .6, R = 1, v},
  v = Table[Circle[r {Cos[#], Sin[#]} &[2 Pi (i - 1)/n], R], {i, n}];
  {
   If[ineqs == {}, {},
    InequalityPlot[(v /. 
         Circle[{xx_, yy_}, rr_] :> (x - xx)^2 + (y - yy)^2 < rr^2)[[ineqs]],
      {x}, {y}, Axes -> False,
      Curves -> None,
      DisplayFunction -> Identity][[1]]
    ],
   v
   }
  ]

The first main line of the function, defining v, sets up a set of circles, spaced out nicely according to the number of circles to include in the diagram.

The second main line users InequalityPlot to work out which bits of the overlapping circles to color in. This functionality has now been superseded by RegionPlot. So you can do something like the following. I increased the number of PlotPoints to ensure that the little corners were fully colored in.

Show[Graphics[Circle[{2, 1}, 1]], Graphics[Circle[{1, 1}, 1]], 
 RegionPlot[{(x - 2)^2 + (y - 1)^2 < 1 && (x - 1.0)^2 + (y - 1)^2 < 
     1}, {x, -3, 3}, {y, -3, 3}, PlotPoints -> 200]]

Converting the Weisstein code to something that is usable in version 8 is a little more involved. Nothing has to change about the bit that creates circles, but it would be more efficient to create the Circles and the inequality code from the same sequence.

Module[{i, r = .6, R = 1, v, p, n = 3}, 
 Show@Table[
   Graphics[Circle[r {Cos[#], Sin[#]} &[2 Pi (i - 1)/n], R]], {i, n}]]

So we can imagine something like:

Module[{i, r = .6, R = 1, v, p, n = 3, coords, circles, conds},
 coords = Table[r {Cos[#], Sin[#]} &[2 Pi (i - 1)/n], {i, n}];
 circles = Graphics[Circle[#, R]] & /@ coords;
 conds = (x - #1)^2 + (y - #2)^2 < R & @@@ coords;

 Show[circles, 
  RegionPlot[And @@ conds, {x, -n, n}, {y, -n, n}, PlotPoints -> 200] ]]

Now we need to set up the connections in the RegionPlot so that it shows the specified set-theoretic connections, not just a single Intersection for all of them. Consider the following. This replacement rule preserves the intersections and unions but distributes a range of inequalities into it. The use of RuleDelayed rather than Rule is essential for it to work.

testv = {x^2 > 1, y^2  < 2, z^2 < 1};

A[1] && (A[2] || A[3]) /. _[x_Integer] :> testv[[x]]

x^2 > 1 && (y^2 < 2 || z^2 < 1)

Putting it all together:

newVennDiagram[n_, ineqs_: {}] := 
 Module[{i, r = .6, R = 1, v, p, coords, circles, conds, groupconds},
  coords = Table[r {Cos[#], Sin[#]} &[2 Pi (i - 1)/n], {i, n}];
  circles = Graphics[Circle[#, R]] & /@ coords;
  conds = (x - #1)^2 + (y - #2)^2 < R & @@@ coords;
  groupconds = ineqs /. _[x_Integer] :> conds[[x]];
  Show[circles, 
   RegionPlot[groupconds, {x, -n, n}, {y, -n, n}, PlotPoints -> 200], 
   circles ]]

The reason I have put the circles twice in the final Show is that by putting them first, their placement and options determine the sizing of the final graphic. So you don't have to mess around removing the Frame from the RegionPlot or worry too much about its PlotRange. But then the inequality regions draw on top of the circles, obscuring any lines underneath. You could fix this with appropriate Opacity settings for the PlotStyle in the RegionPlot, but just drawing the circles a second time is just as easy and the final graphic can be exported to formats (eg EPS) that don't support Opacity.

newVennDiagram[3, A[1] && (A[2] || A[3])]

Answer 6

In the upcoming version (10?) there are useful BooleanRegion functions:

{a, b} = {Disk[{-1/3, 0}, 1], Disk[{1/3, 0}, 1]};
RegionPlot@BooleanRegion[Xor, {a, b}]

{a, b} = {Disk[{0, 0}, 2], Disk[{2, 0}, 2]};
RegionPlot[RegionDifference[a, b], Epilog -> {EdgeForm@Black, FaceForm@None, a, b}]

Furthermore, regions can be more easily highlighted:

{a, b} = {Disk[{0, 0}, 1], Disk[{1, 0}, 1]};
Show[Graphics[{LightBlue, EdgeForm[Gray], a, b}], 
 HighlightMesh[DiscretizeRegion@RegionIntersection[a, b], 2]]

Answer 7

The new region set operations (RegionUnion, RegionIntersection, RegionDifference, and RegionSymmetricDifference) make this particularly easy. E.g.,

c1 = Circle[{3, 3}, 2]; c2 = Circle[{5, 3}, 2];
d1 = Disk[{3, 3}, 2]; d2 = Disk[{5, 3}, 2];
options = Sequence[PlotRange -> {{0, 8}, {0, 6}},
  FrameTicks -> None,
  AspectRatio -> Automatic,
   Epilog -> {c1, c2}
  ]
GraphicsRow[{
  RegionPlot[RegionUnion[d1, d2], Evaluate[options]],
  RegionPlot[RegionIntersection[d1, d2], Evaluate[options]]
  }]

Answer 8

You can use the ResourceFunction VennDiagram.