3
$\begingroup$

I am trying to duplicate (approximately) the following Venn diagram in Mathematica:

enter image description here

I have used the top of this page as a guide, which showcases the following Venn diagram triplet:

a = Disk[{0, 1}];
b = Disk[{-0.5, 0}];
c = Disk[{0.5, 0}];
subsets = Subsets[{a, b, c}, {1, 3}];
subsetscolors = Map[
Function[{c}, 
Blend[
Flatten[
Map[Table[
Map[Append[#, 1.5/Length[c]]& , c], 2]& , c]]]], 
Subsets[
Map[
ColorData[112], 
Range[3]], {1, 4}]];
RegionPlot[Evaluate[DiscretizeRegion[
     RegionDifference[
      BooleanRegion[And, #], 
      BooleanRegion[Or, Complement[{a, b, c, EmptyRegion[2]}, #]]
      ]
     ] & /@ subsets], 
 PlotLabels -> 
  Callout[(StringJoin @@@ Subsets[{"A", "B", "C"}, {1, 3}]), 
   Center], Sequence[
 PlotStyle -> subsetscolors, BoundaryStyle -> Directive[
Thickness[0.01], White], Frame -> False, LabelStyle -> {24}, 
  PerformanceGoal -> "Speed", ImageSize -> 450]]

enter image description here

Attempted code:

a = Disk[{0, 1}];
b = Disk[{-0.5, 0}];
c = Disk[{0.5, 0}];
subsets = Subsets[{b, c}, {1, 2}];
subsetscolors = 
  Map[Function[{c}, 
    Blend[Flatten[
      Map[Table[Map[Append[#, 1.5/Length[c]] &, c], 2] &, c]]]], 
   Subsets[Map[ColorData[112], Range[2]], {1, 4}]];
RegionPlot[
 Evaluate[DiscretizeRegion[
     RegionDifference[BooleanRegion[And, #], 
      BooleanRegion[Or, Complement[{b, c, EmptyRegion[2]}, #]]]] & /@ 
   subsets], 
 PlotLabels -> 
  Callout[{"Vive", "Linux", "Vive\n\[Intersection]\nLinux"}, Center], 
 Sequence[PlotStyle -> subsetscolors, 
  BoundaryStyle -> Directive[Thickness[0.01], White], Frame -> False, 
  LabelStyle -> {24}, PerformanceGoal -> "Speed", 
  ImageSize -> Automatic]]

enter image description here

The problem is that it is squashed, and I can't figure out why. How to fix?

$\endgroup$
  • $\begingroup$ Try setting the Aspect Ratio->... option by hand. $\endgroup$ – N.J.Evans Dec 11 '19 at 14:57
  • $\begingroup$ Setting AspectRatio -> 0.7 somewhat fixes the issue, but the circles are now "jagged". Is there not a way for Mathematica to interpolate this automatically? $\endgroup$ – George Dec 11 '19 at 15:06
  • $\begingroup$ You also have PerformanceGoal->"Speed" which is going to make the plot fast, and rough. When you've got what you want change that to "Quality" and you should see the edges sharpen up. $\endgroup$ – N.J.Evans Dec 11 '19 at 16:11
11
$\begingroup$

I get a decent looking result with:

RegionPlot[
 Evaluate[DiscretizeRegion[
     RegionDifference[BooleanRegion[And, #], 
      BooleanRegion[Or, Complement[{b, c, EmptyRegion[2]}, #]]], 
     MaxCellMeasure -> {"Length" -> 0.1}] & /@ subsets], 
 PlotLabels -> 
  Callout[{"Vive", "Linux", "Vive\n\[Intersection]\nLinux"}, Center], 
 Sequence[PlotStyle -> subsetscolors, 
  BoundaryStyle -> Directive[Thickness[0.01], White], Frame -> False, 
  LabelStyle -> {24}, PerformanceGoal -> "Speed", 
  ImageSize -> Automatic, AspectRatio -> Automatic]]

which has two changes from your code:

  • adds MaxCellMeasure -> {"Length" -> 0.1} to the call the DiscretizeRegion to have a finer discretization

  • uses AspectRatio -> Automatic to automatically get the aspect ratio that makes the disks not be stretched

enter image description here

$\endgroup$
8
$\begingroup$
Graphics[{
  Opacity[0.5],
  Red, Disk[{-0.66, 0}],
  Blue, Disk[{0.66, 0}],
  Opacity[1], White,
  Text[Style["Vive Users", 18], {-0.8, 0}],
  Text[Style["Linux Users", 18], {0.85, 0}],
  Text[Style["Vive\n⋂\nLinux", 18], {0, 0}]}]

enter image description here

$\endgroup$

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.