8
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ Perhaps Graphics[{PointSize[2], Opacity[0.6], Red, Point[{1, 1}], Blue, Point[{0, 0}]}]? $\endgroup$ – Michael E2 Nov 10 at 19:46
  • 1
    $\begingroup$ It should be possible by using DiskSegment, maybe I'll have time to look into it tomorrow. $\endgroup$ – C. E. Nov 10 at 22:49
  • $\begingroup$ I don't want to give the points different colors, they are a single set of data. I was hoping that one of the newfangled graphics functions that I do not understand, like DiscretizeGraphics or MeshPrimitives could be layered on top of a Point@data and do it automatically, not having to program each point separately. $\endgroup$ – Nicholas G Nov 10 at 22:59
  • 1
    $\begingroup$ Region[BooleanRegion[Xor, {Point[{1, 1}], Point[{0, 0}]} /. Point[x_] :> Disk[x, 1]], Frame -> True, BaseStyle -> Blue] ? $\endgroup$ – Alx Nov 11 at 3:19
  • $\begingroup$ If you are all having fun with this question, as you seem to be, the next challenge would be to produce a different treatment for those regions where three points overlap, and a different one if four do! $\endgroup$ – Nicholas G Nov 13 at 10:54
2
$\begingroup$

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

Mathematica graphics

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.

$\endgroup$
9
$\begingroup$

Perhaps:

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

enter image description here

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

enter image description here

$\endgroup$
  • $\begingroup$ Almost. It gets thrown off by the ratio of the axes, so the disks look flattened. I try to define different x- and y- radii but it does not work, e.g., Graphics[drawIt[{{1, .5}, {.25, .25}, {0, 0}}, {.5, 1}], AspectRatio -> .5] $\endgroup$ – Nicholas G Nov 11 at 10:09
  • $\begingroup$ If you're going to play with AspectRatio, you'll have to control the PlotRange, too. For instance: ClearAll[drawIt ]; drawIt[points_List, sr_: 1/10, sc__: {ax_, ay_}] := FilledCurve[{Line[ Transpose[# + ScalingMatrix[sc].Transpose@ close@CirclePoints[{0, 0}, sr, 40]]]} & /@ points]; With[{ar = 0.5, pr = {{-0.5, 1.5}, {-0.6, 1.1}}}, Graphics[ drawIt[{{1, .5}, {.25, .25}, {0, 0}}, 0.3, #/First[#] &[{ar, 1} Flatten[Differences /@ pr]]], AspectRatio -> ar, PlotRange -> pr, Frame -> True]] $\endgroup$ – Michael E2 Nov 11 at 12:47
  • $\begingroup$ Beautiful, many thanks! $\endgroup$ – Nicholas G Nov 11 at 16:23
6
$\begingroup$

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

enter image description here

More points (using @Michael's example):

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

enter image description here

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
]

enter image description here

And a fairly large example (with 1000 points):

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

enter image description here

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]

enter image description here

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

enter image description here

$\endgroup$
  • $\begingroup$ Very nice, thanks. $\endgroup$ – Nicholas G Nov 11 at 21:37
  • $\begingroup$ Plus this code alternates colors back to black where three points overlap, and so on. $\endgroup$ – Nicholas G Nov 13 at 11:10
5
$\begingroup$

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]

Overlapping regions

we can effectively paint their intersection.

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

Region with the intersection in White

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

Many different regions with white intersections

$\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.