64
$\begingroup$

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?

$\endgroup$
40
$\begingroup$

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:

enter image description here enter image description here enter image description here

EDIT: It works with more than 3 groups!

enter image description here

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.

$\endgroup$
  • 4
    $\begingroup$ You don't have enough regions in the 5 set case. For example, there is no region corresponding to VennDiagram2[5, Subscript[A, 1] && ! (Subscript[A, 2] || Subscript[A, 5]) && Subscript[A, 3] && Subscript[A, 4]]. $\endgroup$ – Brett Champion Mar 3 '12 at 22:12
  • $\begingroup$ @BrettChampion you are right :P. $\endgroup$ – FJRA Mar 3 '12 at 23:48
  • $\begingroup$ Funny, maybe it should have a dynamic order of groups... and now I see that it has no labels... $\endgroup$ – FJRA Mar 4 '12 at 0:02
  • 6
    $\begingroup$ In response to your edit, for n=5 you can't do it with circles no matter how you sort/move them around... you'll have to use ellipses (and gets more complicated for even higher dimensions). $\endgroup$ – rm -rf Mar 4 '12 at 9:05
  • $\begingroup$ @R.M Yes, only some cases are fine with circle. $\endgroup$ – FJRA Mar 4 '12 at 15:02
31
$\begingroup$

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

Mathematica graphics

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"}]

Mathematica graphics

$\endgroup$
  • $\begingroup$ @Sjoerd How did you manage to display the inter and union signs? $\endgroup$ – Peter Breitfeld Mar 3 '12 at 14:38
  • $\begingroup$ I'm trying to plot it there. I want to plot this: (A intersect B) element of (D) but i don't know how to express the "element of, any clue? $\endgroup$ – Billy Rubina Mar 3 '12 at 14:59
  • 1
    $\begingroup$ @Peter Breitfield asked how to get the intersection and union signs. In Mathematica or here? For Mathematica, with esc inter esc and esc un esc, as one can discover by selecting the characters on the Special Characters palette. Here, by embedding LaTeX mark-up, I presume. $\endgroup$ – murray Mar 3 '12 at 16:21
  • $\begingroup$ @murray: I know how to do it in Mma, but didn't know, that I can include LaTeX markup $\endgroup$ – Peter Breitfeld Mar 3 '12 at 17:04
  • 1
    $\begingroup$ @PeterBreitfeld In this case I used an image, my LaTeX is a bit rusty after 19 years. Posting images is easy once you have sufficient rep to post them here. Szabolcs created a Mathematica palette to automate it all. See this question. For other tricks I used in your answer you can enter the edit mode in your answer to see the raw code. $\endgroup$ – Sjoerd C. de Vries Mar 3 '12 at 20:09
16
$\begingroup$

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 π}]

enter image description here

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
 ]

enter image description here

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.

$\endgroup$
  • $\begingroup$ hm, the image link is dead ... and if I run the in MMA 11.1, it just shows two regions $\endgroup$ – Yaroslav Bulatov May 1 '17 at 17:45
  • $\begingroup$ A page refresh seemed to fix the image link problem. I just ran the code above in Mathematica 11.1.1.0 and it works fine. $\endgroup$ – RRas May 2 '17 at 19:25
  • $\begingroup$ Thanks, kernel restart makes it work for me too, looks like some variable was interfering $\endgroup$ – Yaroslav Bulatov May 2 '17 at 20:05
14
$\begingroup$

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, Opacity@.3, Disk @@ #2, 
       Opacity@1, Circle @@ #2} &, {colors, circles}]]
   ];

VennDiagram[5, 3, 1]

Mathematica graphics

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

Mathematica graphics

$\endgroup$
13
$\begingroup$

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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$
9
$\begingroup$

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

enter image description here

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

Mathematica graphics

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

enter image description here

$\endgroup$
9
$\begingroup$

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

enter image description here

$\endgroup$
  • $\begingroup$ Adam, you are certainly correct in saying that the region functions help in building the graphical representations of Venn diagrams, but the spirit of the original question asked for methods to go from a statement expressed as set operations to the corresponding diagram. In order to use your method, it seems to me that one has to have already worked out the result of the logic statement instead... $\endgroup$ – MarcoB Sep 20 '15 at 5:24
  • $\begingroup$ It's a direction translation. E.g., A1 && (A2 || A3) /. {And -> RegionIntersection, Or -> RegionUnion} $\endgroup$ – Alan Sep 21 '15 at 12: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.