36
$\begingroup$

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

enter image description here

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":

enter image description here

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:

enter image description here

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.

$\endgroup$

3 Answers 3

36
$\begingroup$

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

DensityPlot output

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.

$\endgroup$
4
  • $\begingroup$ Damn! I was doing the same +1 :) $\endgroup$ Mar 8, 2013 at 1:12
  • 1
    $\begingroup$ Wow, that's perfect! Thank you so much. $\endgroup$ Mar 8, 2013 at 1:23
  • $\begingroup$ Maybe Total[ instead of Plus @@( ? $\endgroup$
    – Murta
    Mar 8, 2013 at 11:00
  • 1
    $\begingroup$ @Murta Yes, thanks. Plus @@ is an old habit that dies hard. $\endgroup$
    – Michael E2
    Mar 8, 2013 at 11:19
20
$\begingroup$

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

Glowy spiral

$\endgroup$
2
  • $\begingroup$ 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. $\endgroup$ Mar 7, 2013 at 23:17
  • $\begingroup$ Beautiful and very bright. Very good idea! $\endgroup$
    – Stefan
    Mar 13, 2013 at 21:04
10
$\begingroup$

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]

original points

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]

random points

$\endgroup$
2
  • $\begingroup$ Thank you. It is basically the same as an earlier one, but without the extra exponent variable. $\endgroup$ Mar 13, 2013 at 20:39
  • $\begingroup$ It is glowing, really! $\endgroup$
    – asim
    Aug 6, 2013 at 15:10

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.