Cross sections of Histogram3D in both dimensions

Question

I am trying to visualize a list of about 1 million {x, y} tuples, and for this I made

Histogram3D[data, {5},
 PlotRange -> {{0, 100}, {0, -100}, Automatic},
 AxesLabel -> {"x", "y", "Count"},
 LabelingFunction -> Tooltip
]

This is good enough to see a general trend, but now I'd like to pick a bin (say, $x \in [-5,0]$ or $y \in [50,55]$) and take a cross section from there to better understand how changing that one variable affects the distribution of the other.

What is a good way of doing this interactively? I tried controlling the plot range with Manipulate[hist, {xrange, 0, 100, 5}] but it's extremely slow and always aborts. I assume it's recalculating the bin counts for the whole data set every time the value changes. It would also mean I have to edit the code if I want to see it from a bin on the $y$ axis which is not what I want.

Something like making all but the relevant bars transparent, or showing multiple discrete 2D histograms on a Manipulate window would be fine.

Answer 1

You should give up on displaying histograms as counts and use the "PDF" option as you're wanting to estimate a probability distribution. Also, you should give up on histograms as there is an automatic way to obtain a "smooth histogram" which is generally what one expects the "true" distribution to be (i.e., the underlying probability density function is many times expected to be relatively smooth).

Generate some data and produce a smooth estimate of the underlying distribution. (I've only used 10,000 observations to speed things up.)

dist1 = CopulaDistribution[{"FGM", 0.2}, {BetaDistribution[1, 3], BetaDistribution[3, 1]}];
dist2 = CopulaDistribution[{"FGM", 0.2}, {BetaDistribution[6, 6], BetaDistribution[6, 6]}];
n = 10000;
SeedRandom[12345];
data = Join[RandomVariate[dist1, n/2], RandomVariate[dist2, n/2]];
data[[All, 1]] = -100 data[[All, 1]];
data[[All, 2]] = 100 data[[All, 2]];

SmoothHistogram3D[data, {Automatic, {"Bounded", {{-100, 0}, {0, 100}}, "Gaussian"}}, "PDF",
 AxesLabel -> {"x", "y", "Probability density"},
 PlotRange -> {{-100, 0}, {0, 100}, {0, Automatic}}, 
 RotationAction -> "Clip",
 SphericalRegion -> True, ImageSize -> Large, 
 ImagePadding -> {{100, 100}, {10, 10}}]

You can produce estimates of the probability density conditional on a range of y values in the following manner:

Manipulate[
 x = Select[data, y - binWidth/2 <= #[[2]] < y + binWidth/2 &][[All, 1]];
 SmoothHistogram[x, {Automatic, {"Bounded", {-100, 0}, "Gaussian"}}, "PDF",
  PlotRange -> {{-100, 0}, {0, maxVerticalAxis}}, PlotPoints -> 200, 
  MaxRecursion -> 3, Frame -> True, FrameLabel -> {"x", "Probability density"}],
 {{y, 50}, 1, 99, Appearance -> "Labeled"},
 {{binWidth, 5}, 2, 20, Appearance -> "Labeled"},
 {{maxVerticalAxis, 0.06}, 0.01, 0.20, Appearance -> "Labeled"}]

Addition:

If you need speed for a demo, then constructing the conditional pdf's ahead of time will fix that. Here's a limited example:

p = ConstantArray[0, 99];
Do[x = Select[data, y - 5/2 <= #[[2]] < y + 5/2 &][[All, 1]];
 p[[y]] = SmoothHistogram[x, {Automatic, {"Bounded", {-100, 0}, "Gaussian"}},
   "PDF", PlotRange -> {{-100, 0}, {0, 0.06}}, PlotPoints -> 200,
   Frame -> True, FrameLabel -> {"x", "Probability density"},
   PlotLabel -> ToString[NumberForm[Max[0, y - 2.5], 3]] <> " <= y <= " <> 
     ToString[NumberForm[Min[100, y + 2.5], 3]]],
 {y, 1, 99}]

Manipulate[p[[i]],
 {{i, 1, "y"}, 1, 99, 1}, TrackedSymbols :> {i}, SaveDefinitions -> True]

If you save the Manipulate[... line to a separate file, then the SaveDefinitions -> True option will store the individual images so you don't have to recreate those each time you open that file.