How can I make points "glow"?

Question

I have a set of points in the plane which I would like to have "glow". I would like for each point to glow individually and I would also like some increase in the intensity corresponding to an increase in density of the points.

I've come up with a couple ideas for how to do this using DensityPlot but neither are quite what I'm hoping for. I'll describe them below.

I need some points, say

pts = Table[{Re[E^(I t/2 - t/10)], Im[E^(I t/2 - t/10)]}, {t, 1, 50}];

The first idea is to consider an density function like

$$ \frac{1}{\epsilon + \min_{a \in \text{pts}}\operatorname{dist}((x,y),a)}. $$

My code for this is

eps = 1/16; exponent = 1/2;

distfunc1[x_, y_] = 
   1/(eps + Min[
      Table[
         ((x - pts[[k, 1]])^2 + (y - pts[[k, 2]])^2)^(exponent),
         {k, 1, Length[pts]}
      ]
   ]);

Show[
   DensityPlot[distfunc1[x, y], {x, -1, 1}, {y, -1, 1}, 
      PlotPoints -> 40],
   Graphics[{PointSize[0.007], Point[pts]}]
]

which produces

The non-differentiability of the density function leads to sharp divisions between the glows. To get around that I considered adding the distances instead of taking the minimum, like

$$ \sum_{a \in \text{pts}} \frac{1}{\epsilon + \operatorname{dist}((x,y),a)}. $$

My definition is

distfunc2[x_, y_] = 
   Sum[
      1/(((x - pts[[k, 1]])^2 + (y - pts[[k, 2]])^2)^(exponent) + eps),
      {k, 1, Length[pts]}
   ];

By varying the parameters eps and exponent I can get parts of what I want. For example with eps = 1/4 and exponent = 1/2 I get nice smooth glows around the outer points but the inner region becomes too "hot":

With eps = 1/2 and exponent = 1/1400 the middle is no longer too hot and has the brightest glow from the density but the outer points no longer have significant idividual glows:

I haven't yet found a way to have a nice strong glow in the center as well as distinct, nontrivial glows for each of the outer points. I appreciate any ideas you may have.

Also, I'm new to Mathematica and I don't really know how ColorFunction works. Is it easy to increase the range of lights/darks (i.e. increase contrast) in the color function used by DensityPlot to render its pictures? I would like the darkest color to be near-black in the above pictures if possible.

Answer 1

One important thing you probably want is PlotRange -> All. The white-hot spots are from plot range clipping. Another thing I add below is a little smoothing by considering (more or less) the harmonic mean of the distances to the two nearest points:

pts = Table[{Re[E^(I t/2 - t/10)], Im[E^(I t/2 - t/10)]}, {t, 1, 50}];

distfunc1[x_, y_, a_] := 
  Max[1 - a / Total[1/EuclideanDistance[{x, y}, #] & /@ Nearest[pts, {x, y}, 2]], 0]^2;

Show[DensityPlot[distfunc1[x, y, 10], {x, -1, 1}, {y, -1, 1}, 
  PlotPoints -> 40, PlotRange -> All], 
 Graphics[{PointSize[0.007], Point[pts]}]]

The intensity is given by 1 - a times the mean distance or 0, whichever is greater. The spread of the glow is controlled by a, the spread decreasing as a increases. Squaring Max smooths the transition of the intensity to 0. The image above is for a == 10.

Answer 2

You can get a sort of interpolation between these two ideas by taking the total of the nearest two points. I reduce the intensity at the center by scaling as a function of distance from the center. Increasing MaxRecursion gets better resolution in the crowded middle. The use of ColorFunction to blend between black, blue and white is also shown:

distfunc[x_, y_] = 
  Norm[{x, y}] Total[
      Max[#] + RankedMax[#, 2]] &[(Norm[{x, y} - #])^-1 & /@ pts];
Show[DensityPlot[distfunc[x, y], {x, -1, 1}, {y, -1, 1}, 
  PlotPoints -> 40, MaxRecursion -> 4,
  ColorFunction -> (Blend[{{0, Black}, {0.5, Blue}, {1, 
        White}}, #] &)], Graphics[{PointSize[0.007], Point[pts]}]]

Answer 3

Here is an answer using a glow intensity falloff function of 1/(a*x+1). I set a to 5, but increase it to increase the sharpness of the glowing points. I do a sum from the 5 nearest points, but you can change that for a performance/accuracy tradeoff.

pts = Table[{Re[E^(I t/2 - t/10)], Im[E^(I t/2 - t/10)]}, {t, 1, 50}];
near = Nearest[pts];
DensityPlot[
 Module[{nearest = near[{x, y}, 5]}, 
  Sum[1/(5 EuclideanDistance[{x, y}, nearest[[a]]] + 1), {a, 
    Length@nearest}]], {x, -1, 1}, {y, -1, 1}, PlotRange -> All, 
 PlotPoints -> 40]

It looks good with random points too.

pts = RandomReal[{-1, 1}, {100, 2}];
near = Nearest[pts];
DensityPlot[
 Module[{nearest = near[{x, y}, 5]}, 
  Sum[1/(5 EuclideanDistance[{x, y}, nearest[[a]]] + 1), {a, 
    Length@nearest}]], {x, -1, 1}, {y, -1, 1}, PlotRange -> All, 
 PlotPoints -> 40]