# How can I make points “glow”?

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.

-

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.

-
Damn! I was doing the same +1 :) –  belisarius Mar 8 '13 at 1:12
Wow, that's perfect! Thank you so much. –  Antonio Vargas Mar 8 '13 at 1:23
Maybe Total[ instead of Plus @@( ? –  Murta Mar 8 '13 at 11:00
@Murta Yes, thanks. Plus @@ is an old habit that dies hard. –  Michael E2 Mar 8 '13 at 11:19

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


-
Thanks, that's pretty neat. Ideally the solution shouldn't rely on the geometry of these particular points, though. The goal is to apply this to some other arbitrary point sets. –  Antonio Vargas Mar 7 '13 at 23:17
Beautiful and very bright. Very good idea! –  Stefan Mar 13 '13 at 21:04

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]


-
+1, that second plot is beautiful. –  Antonio Vargas Mar 13 '13 at 20:30
Thank you. It is basically the same as an earlier one, but without the extra exponent variable. –  Michael Hale Mar 13 '13 at 20:39
It is glowing, really! –  asim Aug 6 '13 at 15:10