# Plot contours for 3d histograms

I have a data set which is a list of pairs. From this I can easily make a 3d histogram with Histogram3D[data] or a smoothed projection of it to the plane with SmoothDensityHistogram[data]. What I would like to obtain is a smoothed contour line within which the data count has a given value or higher. Essentially this would be a single customizable contour line in the plot produced by SmoothDensityHistogram[data]. Ultimately I would need to combine several such contour lines in a single plot. How would I achieve this?

I investigated a bit and found that this approach

data1 = RandomVariate[BinormalDistribution[.75], 10];
distribution1 = SmoothKernelDistribution[data1];
data2 = RandomVariate[BinormalDistribution[.75], 10];
distribution2 = SmoothKernelDistribution[data2];

Sow[ContourPlot[
PDF[distribution1, {x, y}] == 10^(-2), {x, -3, 3}, {y, -3, 3},
ContourStyle -> Opacity[0.4], ContourShading -> None],
ContourPlot[
PDF[distribution2, {x, y}] == 10^(-2), {x, -3, 3}, {y, -3, 3},
ContourStyle -> Opacity[0.4], ContourShading -> None]]


should be producing what I want.

The remaining problem is that the resulting plot shows only one of the contour lines as if the background of the plots was not transparent. Any ideas?

• I don't know but is it really possible to define a single contour that would encompass say 60% of the data points? I'd say there will be a multitude of contours that do that. – Sjoerd C. de Vries Apr 22 '15 at 15:30
• Sorry, wrong phrasing! It should plot a maximum likelihood contour rather than that, i.e. one within which the probability has a given value or more. Of course there can be a set of disconnected such contours and, of course, it won't be unique either because it will depend on the smoothing. – highsciguy Apr 22 '15 at 15:41
• Doesn't look like a usable definition either. – Sjoerd C. de Vries Apr 22 '15 at 16:01
• Let's put it this way: The histogram gets me an integer value (count) for each of a finite number of 2-dimensional bins. I then apply a (to be defined) smoothing algorithm which gives a smooth function f(x,y) of two variables (I could turn it into a probability distribution function by normalization). I want to plot a specific contour line which satisfies f(x,y)=const. As I mentioned this this would be a contour line in a SmoothDensityHistogram[] plot. – highsciguy Apr 22 '15 at 16:08
• But that contour describes a local density and it does neither relate to the total data count within the contour (original question) nor the probability of finding a member of the data set within the contour (update in comment) which is what you seem to want. If you simply want the density contours from a SmoothDensityHistogram why don't you use that? – Sjoerd C. de Vries Apr 22 '15 at 16:15

Edit, based on the added info in the question:

 data1 = RandomVariate[BinormalDistribution[.75], 10];
distribution1 = SmoothKernelDistribution[data1];
data2 = RandomVariate[BinormalDistribution[.75], 10];
distribution2 = SmoothKernelDistribution[data2];
ContourPlot[
{PDF[distribution1, {x, y}] == 10^(-2),
PDF[distribution2, {x, y}] == 10^(-2)}, {x, -3, 3}, {y, -3, 3},
ContourStyle -> {Red,Blue}, ContourShading -> None] something like this?

 r = RandomVariate[BinormalDistribution[.5], 100];
hg = Histogram3D[r] hl = HistogramList[r];
Show[hg, Graphics3D[{Thick, Red,
Map[Append[#, 5] & , First@Cases[Normal@First@
Cases[ListContourPlot[
Flatten[Table[{
Mean@hl[[1, 1, j ;; j + 1]],
Mean@hl[[1, 2, i ;; i + 1]],
hl[[2, j, i]]},
{i, Length@hl[[1, 2]] - 1}, {j, Length@hl[[1, 1]] - 1}], 1],
Contours -> {5}], _GraphicsComplex, Infinity],
_Line, Infinity], {2}]}]] By the way, It would be cleaner to work with SmoothDensityHistogram, but I can't figure how to coax it to give a single contour line at a specified level..

• This is the correct direction, however I do need only two contour lines and I need it smoothed (see my recent edit to the question). – highsciguy Apr 22 '15 at 20:46

Update:

SeedRandom
d1 = BinormalDistribution[.75];
r = RandomVariate[d1, 20];
hg = Histogram3D[r, Automatic, "PDF", ChartStyle -> Opacity[.35]];
sh = SmoothHistogram3D[r, Automatic, "PDF", BoundaryStyle -> None,  PlotStyle -> None,
Mesh -> {{{.03, Directive[Thick, Orange]}, {.11, Directive[Thick, Red]}}}];
Row[{Show[hg, sh, PlotRange -> All, BoxRatios -> 1, ImageSize -> 400],
Show[hg, sh /. Line[x_] :> {Line[x], EdgeForm[], FaceForm[Opacity[.4]], Polygon[x]},
PlotRange -> All, BoxRatios -> 1, ImageSize -> 400]}] Using SmoothKernelDistribution of data with Plot3D and MeshFunctions:

d2 = SmoothKernelDistribution[r];
plt3d = Plot3D[Evaluate[PDF[#, {x, y}]], {x, -3, 3}, {y, -3, 3},
MeshFunctions -> {#3 &}, Mesh -> {{.03}},
MeshStyle -> {Directive[Thick, Purple], Directive[Thick, Brown]}[[#2]],
PlotStyle -> None, BoundaryStyle -> None,
ClippingStyle -> None] & @@@ {{d1, 1}, {d2, 2}};
Legended[Show[hg, plt3d,
PlotRange -> All, BoxRatios -> 1], LineLegend[{Purple, Brown},
(Style[#, 16, "Panel"]&/@{"PDF[Binormal[.7]]", "PDF[SmoothKernelDistribution[r]]"})]] Manipulate[Show[hg, Plot3D[Evaluate[PDF[#, {x, y}]], {x, -3, 3}, {y, -3, 3},
MeshFunctions -> {#3 &}, Mesh -> {{mesh}},
MeshStyle -> {Directive[Thick, Purple], Directive[Thick, Brown]}[[#2]],
PlotStyle -> None, BoundaryStyle -> None,
ClippingStyle -> None] & @@@ {{d1, 1}, {d2, 2}},
PlotRange -> {{-3, 3}, {-3, 3}, {0, .25}}, BoxRatios -> 1],
{{mesh, .03}, .01, .20}] Original post:

Maybe something like:

r = RandomVariate[BinormalDistribution[.5], 100];
hg = Histogram3D[r, Automatic, "PDF", ChartStyle -> Opacity[.5]];

sh = SmoothHistogram3D[r, Automatic, "PDF",
Mesh -> {{{.05, Directive[Thick, Orange]}, {.12, Directive[Thick, Red]}}},
BoundaryStyle -> None, PlotStyle -> None];

Show[hg, sh] Show[hg, sh /. Line[x_] :> {Opacity[.8], Polygon[x]}] 