# How to stretch this Venn diagram?

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

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


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


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

• Try setting the Aspect Ratio->... option by hand. Dec 11 '19 at 14:57
• 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? Dec 11 '19 at 15:06
• 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. Dec 11 '19 at 16:11

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

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