I'm trying to plot the Smooth Density Histogram of a double pendulum (particularly the location of the bottom pendulum). Since a pendulum has physical constraints, when shown in the Smooth Density Histogram there are unrealistic locations of probabilities (i.e. there is a probability at a location where it is impossible for the pendulum to reach because the smoothing function "smoothed" out to zero).

Is there a way to have a type of exclusion that dictates the physical constraints of the system, when applying the smoothing function.

For example the following code:

deqns = {Subscript[m, 1] x1''[
  t] == (\[Lambda]1[t]/Subscript[l, 1]) x1[
   t] - (\[Lambda]2[t]/Subscript[l, 2]) (x2[t] - x1[t]), 
  Subscript[m, 1] y1''[
  t] == (\[Lambda]1[t]/Subscript[l, 1]) y1[
   t] - (\[Lambda]2[t]/Subscript[l, 2]) (y2[t] - y1[t]) - 
  Subscript[m, 1] g, 
  Subscript[m, 2] x2''[
  t] == (\[Lambda]2[t]/Subscript[l, 2]) (x2[t] - x1[t]), 
  Subscript[m, 2] y2''[
  t] == (\[Lambda]2[t]/Subscript[l, 2]) (y2[t] - y1[t]) - 
  Subscript[m, 2] g};

aeqns = {x1[t]^2 + y1[t]^2 == 
  Subscript[l, 1]^2, (x2[t] - x1[t])^2 + (y2[t] - y1[t])^2 == 
  Subscript[l, 2]^2};

ics = {x1[0] == 1, y1[0] == 0, y1'[0] == 0, x2[0] == 1, y2[0] == -1, 
  y2'[0] == 0};

params = {g -> 9.81, Subscript[m, 1] -> 1, Subscript[m, 2] -> 1, 
  Subscript[l, 1] -> 1, Subscript[l, 2] -> 1};

soldp = First[
  NDSolve[{deqns, aeqns, ics} /. params, {x1, y1, x2, 
  y2, \[Lambda]1, \[Lambda]2}, {t, 0, 15000}, 
  Method -> {"IndexReduction" -> {"Pantelides", 
    "ConstraintMethod" -> "Projection"}}]];

will give the solution to a double pendulum (where each pendulum is of length one). ($t$ is really large so if you want to run it yourself feel free to bring it down an order of magnitude).

Looking at the smooth histogram,

  Map[Function[Evaluate[{x2[#], y2[#]} /. soldp]], 
   Range[0, 15000, 0.025]], Mesh -> 5, 
  PlotRange -> {{-2, 2}, {-2, 0.1}}]

Density Probability Double Pendulum

you can see I only plotted to $y=-2$ to emphasis that there should not exist a probability after this point. So is there a way to force the smoothing function to not smooth anything outside of the boundary conditions i.e. Exclusions -> Function[{x, y}, x^2 + y^2 > 2^2]

  • $\begingroup$ does adding the option RegionFunction -> Function[{x, y}, x^2 + y^2 <= 4] give what you need? $\endgroup$ – kglr Feb 19 '19 at 18:32
  • $\begingroup$ or play with the option MaxExtraBandwidths using SmoothKernelDistribution on your data and DensityPlot its pdf (PDF[SmoothKernelDistribution[ Map[Function[Evaluate[{x2[#], y2[#]} /. soldp]], Range[0, 2 1500, 0.025]], MaxExtraBandwidths ->0], {x, y}]). $\endgroup$ – kglr Feb 19 '19 at 18:47
  • $\begingroup$ @kglr I think the RegionFunction just cuts off what is being plotted and doesn't actually fix the smoothing problem. (I tried this) $\endgroup$ – Josh Feb 19 '19 at 19:07
  • $\begingroup$ For sharper boundaries sometimes an "adaptive bandwidth" produces more desirable results. However, it does not appear that SmoothHistogramDensity accepts anything but fixed bandwidths. SmoothKernelDistribution does allow for adaptive bandwidths. An article that might be useful is sciencedirect.com/science/article/pii/S0047259X09001651. $\endgroup$ – JimB Feb 19 '19 at 20:04

I'm not so sure you can get there from here using the current nonparametric density capabilities of Mathematica. (That is not to say that what you want isn't desirable.)

First, you really don't have independent random samples from a bivariate distribution. (You really don't have samples at all but observations along a very long but deterministic process.) However, if you consider the data generation process as a sort of random number generator, then using 0.025 as the step function results in high correlations between neighboring steps. Why is this potentially bad? The automatic bandwidth selected is estimated using sample size assuming that observations are independent (with a few other assumptions) which results in undersmoothing.

Second, there are not only external boundaries but there are apparent discontinuities (essentially big jumps in "density") associated with internal borders. Fixed-width kernel density estimation don't handle such things very well. (Adaptive kernel density estimation is much better but for your case I'm not so sure and the adaptive bandwidth that one can use in SmoothKernelDistribution is not lightning fast.)

I'm a great believer in getting rid of histograms in favor of nonparametric density estimation but for this case, I think you might be much better off using a very densely gridded histogram with a very large sample size (because of the external borders and the internal jumps).

Here's what I get using 50,000 rather than 15,000 for the maximum t value:

n = 50000;
soldp = First[
   NDSolve[{deqns, aeqns, ics} /. params, {x1, y1, x2, y2, λ1, λ2}, {t, 0, n}, 
    Method -> {"IndexReduction" -> {"Pantelides", "ConstraintMethod" -> "Projection"}}]];

data = Map[Function[Evaluate[{x2[#], y2[#]} /. soldp]], Range[0, n, 0.025]];

hdata = HistogramList[data, 200];
x = Table[(hdata[[1, 1, i]] + hdata[[1, 1, i - 1]])/2, {i, 2, Length[hdata[[1, 1]]]}];
y = Table[(hdata[[1, 2, i]] + hdata[[1, 2, i - 1]])/2, {i, 2, Length[hdata[[1, 1]]]}];
htable = Flatten[Table[{x[[i]], y[[j]], hdata[[2, i, j]]}, {i, Length[x]}, {j, Length[y]}], 1];

ListContourPlot[htable, PlotRange -> All, 
  Contours -> {10, 20, 30, 40, 50, 100, 150, 200, 300, 400, 500, 600, 700, 800}, 
  AspectRatio -> 1, ImageSize -> Medium, 
  PlotLegends -> Automatic]

Contour plot of bivariate histogram counts

Looking at the figure, there's still a lot of bumpiness and besides having external borders, the count (I just used the histogram count rather than converting to density) jumps dramatically near the borders (both internal and external borders) which just makes this a very difficult surface to fit. Maybe a much larger sample size will make things better.


Here's an alternative visualization that uses ListPlot with a very low Opacity:

ListPlot[Table[Evaluate[{x2[t], y2[t]} /. soldp], {t, 0, 15000, 0.01}], 
  PlotStyle -> {Black, Opacity[0.002], PointSize[0.005]}]

Mathematica graphics

Otherwise, SmoothKernelDistribution has two options for smoothing kernels that seem potentially useful if they could only be combined -- "Bounded" and "Radial".

d = SmoothKernelDistribution[
  Map[Function[Evaluate[{x2[#], y2[#]} /. soldp]], Range[0, 15000, 0.025]], 
  Automatic, {"Bounded", {{-2, 2}, {-2, 0}}, "Gaussian"}];

ContourPlot[PDF[d, {x, y}], {x, -2, 2}, {y, -2, 0.1}, MaxRecursion -> 3, PlotPoints -> 50]

Mathematica graphics

d = SmoothKernelDistribution[
  Map[Function[Evaluate[{x2[#], y2[#]} /. soldp]], Range[0, 15000, 0.025]],
  Automatic, {"Radial", "Gaussian"}];

ContourPlot[PDF[d, {x, y}], {x, -2, 2}, {y, -2, 0.1}, MaxRecursion -> 3, PlotPoints -> 50]

Mathematica graphics

Those are both kind of horrifying. Maybe the general kernel specification func could be pressed into service by someone smarter than me!


Maybe a trip through polar coordinates makes the "Bounded" option more useful. (I wonder if this needs to be corrected for the effect of changing the area of different volumes of phase space...)

dat = Map[Function[Evaluate[{x2[#], y2[#]} /. soldp]], Range[0, 15000, 0.025]];
pdat = ToPolarCoordinates[dat];
d = SmoothKernelDistribution[pdat, Automatic,
  {"Bounded", {{0, 2}, {0, 2 π}}, "Gaussian"}];
ContourPlot[Evaluate[PDF[d, {r, θ}] /. {r -> Sqrt[x^2 + y^2], θ -> ArcTan[x, -y]}],
  {x, -2, 2}, {y, -2, 2}, PlotPoints -> 200, Contours -> 10, PlotRange -> {0, All}]

Mathematica graphics

Getting better, but still kind of hideous! Polar ContourPlot thanks to this old answer by @rcollyer (with an extra minus sign before y, because ???)

  • $\begingroup$ I like the work you did, but you are right, I think their could be something better. I was wondering this morning if mirroring locally around the boundary conditions (obviously this is an estimation as it is impossible to exactly mirror around the boundary condition), run the smoothing function, then go in and change all values outside of the boundary to zero (thus a discontinuity would exist around the boundary). I have no idea how to do that or if it is even a good idea, it was just a thought I had. $\endgroup$ – Josh Feb 20 '19 at 16:31

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.