There are two ways:
Calculate the density analytically. For the distribution you use this is difficult but since this for producing something pretty, and not for accuracy, you can consider using a different distribution.
Approximate the distribution numerically.
I'm going to do no. 2. below. I don't have version 7, so it is just a guess that these functions will work. In later versions SmoothKernelDistribution
is going to be a better an easier way to estimate the density, but in v7 we can't use that so I went for simple binning.
Summary of the idea:
Estimate the density by binning. The result will be sensitive to the bin size. A large bin size might smooth out the data more than desired while a small bin size will increase fluctuations.
Interpolate the histogram to obtain a smooth function. Linear interpolation might be the best choice if the histogram has a lot of fluctuations. Higher order interpolation tends to exacerbate the fluctuations.
Colour the points based on this interpolated estimate of the density.
Here's code that implements this:
This data will only be used for estimating the density. More data points give a smoother histogram.
In[74]:= data = Ball[500000];
Figure out reasonable bounds for the binning:
In[75]:= Max /@ Transpose[data]
Out[75]= {2.8324, 2.78793, 2.65889}
In[76]:= Min /@ Transpose[data]
Out[76]= {-2.85683, -3.18866, -2.73881}
-3..3
will do, but you might need to increase it if points tend to fall outside of this range. Also make sure to divide by the maximum value so that we have numbers between 0 and 1 (that can be used in Mathematica's colour functions).
In[77]:= bins = N@BinCounts[data, {-3, 3, .1}, {-3, 3, .1}, {-3, 3, .1}];
bins /= Max[bins];
In[79]:= if =
ListInterpolation[bins, {{-3, 3}, {-3, 3}, {-3, 3}},
InterpolationOrder -> 1]
Now we have a density function to colour by:
Graphics3D[{AbsolutePointSize[2],
{ColorData["Rainbow"][if[##]], Point[{##}]} & @@@ Ball[10000]},
Boxed -> True, BoxRatios -> {1, 1, 1}, ImageSize -> 800, SphericalRegion -> True]
SmoothKernelDistribution
is new in 8.0. $\endgroup$arr = Array[Exp[-0.01 {##}.{##}] &, {20, 20, 20}]; ListInterpolation[arr]
. (I don't have v7 so I don't know.) $\endgroup$