Reverse color of overlapping points?

Question

Is there a simple way to change the color of the region where two Points overlap? For example in Graphics[{PointSize[2], Point[{1, 1}], Point[{0, 0}]}], the resulting two points have an area where they overlap (their union). I am looking for a simple way to make that area White, for example.

The reason I am asking is that I have a list of data points, some of which overlap. I want to show the data in a graph but I want the reader to be easily able to realize that two neighboring and overlapping points are separate. That is why I am looking for an easy way to reverse the color of their union. Points that overlap perfectly, I treat separately, by making a circle around the first point.

Answer 1

We can use RegionSymmetricDifference to get the portions of disks that do not overlap:

rSD = Apply[RegionSymmetricDifference] @* Map[BoundaryDiscretizeRegion];

Using the example input from C.E.'s answer:

SeedRandom[101];
pts = RandomReal[10, {20, 2}];
r = 0.5;
disks = Disk[#, r] & /@ pts;

rSD @ disks

Show[Graphics[{Red, disks}], 
 BoundaryDiscretizeRegion[rSD @ disks, BaseStyle -> Black]]

Update: We can use BooleanRegion + BooleanCountingFunction to identify points that belong to two or more disks and points that belong to exactly one disk:

overlaps = BoundaryDiscretizeRegion[
  BooleanRegion[
    BooleanCountingFunction[{2, Length @ disks, 1}, Length @ disks], 
    disks], 
  MaxCellMeasure -> .001, MeshCellStyle -> {2 -> Red}]

inExactlyOneDisk = BoundaryDiscretizeRegion[
  BooleanRegion[BooleanCountingFunction[{1}, Length@disks], disks], 
  MaxCellMeasure -> .001, MeshCellStyle -> {2 -> Black}]

Show[inExactlyOneDisk, overlaps]

Answer 2

Perhaps:

Graphics[FilledCurve[{
   {Line@close@CirclePoints[{0, 0}, 1, 30]}, 
   {Line@close@CirclePoints[{1, 1}, 1, 30]}
  }]]

More generally:

close[path_List] := Append[path, First@path];

drawIt[points_List, r_: 2] := 
  FilledCurve[{Line@close@CirclePoints[#, r, 40]} & /@ points];

SeedRandom[0];
Graphics[drawIt[RandomReal[{-20, 20}, {20, 2}]]]

Answer 3

Here's a refinement of Michael's FilledCurve idea, where I use BSplineCurve to generate the circles instead of Line. The following function creates a BSplineCurve that renders as a circle with center c and radius r, where r is measure in points, and not plot coordinates (using points means that the shape of the circle is unaffected by changes in the AspectRatio of a graphic):

splineCircle[c_, r_] := BSplineCurve[
    Table[Offset[r {Cos[n Pi/4], Sin[n Pi/4]} If[OddQ[n], Sec[Pi/4], 1], c], {n, 0, 8}],
    SplineDegree -> 2,
    SplineKnots -> {0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 4},
    SplineWeights -> {1, 1/Sqrt[2], 1, 1/Sqrt[2], 1, 1/Sqrt[2], 1, 1/Sqrt[2], 1}
]

Using the above primitive, we can construct the desired output using FilledCurve:

overlappedPoints[pts_, size_] := FilledCurve @ Map[
    {splineCircle[#, size]}&,
    pts
]

Simple example:

Graphics[overlappedPoints[{{0, 0}, {.1, .1}}, 50], PlotRange->{{-.5,.5},{-.5,.5}}]

More points (using @Michael's example):

SeedRandom[0];
pts = RandomReal[{-20, 20}, {20, 2}];
g = Graphics[
    {
    overlappedPoints[pts, 9]
    },
    ImageSize->200
]

Here's how the graphic changes with changing aspect ratio:

GraphicsRow[
    {Show[g, AspectRatio->1/2], g, Show[g, AspectRatio->2]},
    ImageSize->600,
    Frame->All
]

And a fairly large example (with 1000 points):

SeedRandom[0];
pts = RandomReal[{-20, 20}, {1000, 2}];
g = Graphics[
    {
    overlappedPoints[pts, 7]
    },
    ImageSize->500
]

Addendum

If you want to be able to specify the overlap colors, a small change to my original code will allow you to do this:

overlappedPoints[pts_,size_]:={
    Red,
    Map[Disk[#, Offset[size]]&,pts],
    Black,
    FilledCurve@Map[{splineCircle[#,size]}&,pts]
}

For example:

SeedRandom[0];
pts = RandomReal[{-20,20},{20,2}];
g = Graphics[{overlappedPoints[pts,9]}, ImageSize->200, AspectRatio->1/2]

where I also changed the aspect ratio to show that the points don't get elongated when the aspect ratio is changed. This approach is pretty quick even for a 1000 points.

SeedRandom[0];
pts = RandomReal[{-20,20},{1000,2}];
Graphics[{overlappedPoints[pts,7]},ImageSize->500] //AbsoluteTiming

Answer 4

Another way using regions.

If we have two regions defined by disks

R = {r1, r2} = {Disk[{0, 0}, 2], Disk[{1, 1}, 2]};
Graphics[R]

we can effectively paint their intersection.

Show[
  Graphics[R], 
  MeshPrimitives[
    DiscretizeRegion[RegionIntersection @@ R],
    2
  ] /. reg : Polygon[_] :> {EdgeForm[White], White, reg} // Graphics, 
 PlotRange -> All
]

and, while it's almost painfully slow, for a general set of points.

overlaps[pts : {{_, _} ..}, r_: 1] := Block[
  {regs},
  regs = Disk[#, r] & /@ pts;
  Show[
    Graphics[regs],
    Graphics[
      Join @@ (
        MeshPrimitives[DiscretizeRegion@#, 2] & /@ DeleteCases[
          RegionIntersection @@@ Join @@ Table[
            regs[[{j, k}]],
            {j, Length@regs},
            {k, Range[Length@regs]~Complement~{j}}
          ],
          EmptyRegion[2]
         ]
      ) /. reg : Polygon[_] :> {EdgeForm[White], White, reg}
    ],
   PlotRange -> All
  ]
]

SeedRandom[1234]
overlaps[RandomReal[{0, 10}, {15, 2}]]

Answer 5

Here's a function that lets you color the overlap any way you want:

directedangle[a_, b_] := If[
  Sign@Det[{a, b}] >= 0,
  VectorAngle[a, b],
  2 π - VectorAngle[a, b]
  ]
angles[center_, Point[{pt1_, pt2_}]] := Module[{th1, th2},
  th1 = directedangle[{1, 0}, pt1 - center];
  th2 = directedangle[{1, 0}, pt2 - center];
  {th1, th2} = Sort[{th1, th2}];
  If[
   th2 - th1 > Pi,
   {th1, th2} = {th2, 2 Pi + th1}
   ];
  {th1 - 0.05, th2 + 0.05}
  ]

diskOverlaps[{idx1_, idx2_}, pts_] := Module[{pt1, pt2},
  pt1 = pts[[idx1]];
  pt2 = pts[[idx2]];
  intersection = RegionIntersection[Circle[pt1, r], Circle[pt2, r]];
  DiskSegment[pt1, r, angles[pt1, intersection]]
  ]
diskOverlaps[pts_] := Module[{distanceMatrix, overlapping},
  distanceMatrix = DistanceMatrix[pts];
  overlapping = Position[UnitStep[distanceMatrix - 2 r] + IdentityMatrix[Length[pts]], 0];
  diskOverlaps[#, pts] & /@ overlapping
  ]

Using it:

SeedRandom[101]
pts = RandomReal[10, {20, 2}];
r = 0.5;

Graphics[{
  Disk[#, r] & /@ pts,
  Red, diskOverlaps[pts]
  }]

Credit goes to this answer for the directedangle function. For performance reasons, one can use Nearest instead of DistanceMatrix to find disks that touch each other, but I didn't focus on that here.