5
$\begingroup$

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?

Improve this question
$\endgroup$
8
  • $\begingroup$ 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. $\endgroup$ Commented Apr 22, 2015 at 15:30
  • $\begingroup$ 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. $\endgroup$ Commented Apr 22, 2015 at 15:41
  • $\begingroup$ Doesn't look like a usable definition either. $\endgroup$ Commented Apr 22, 2015 at 16:01
  • $\begingroup$ 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. $\endgroup$ Commented Apr 22, 2015 at 16:08
  • $\begingroup$ 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? $\endgroup$ Commented Apr 22, 2015 at 16:15

2 Answers 2

Reset to default
4
$\begingroup$

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]

enter image description here

something like this?

 r = RandomVariate[BinormalDistribution[.5], 100]; hg = Histogram3D[r]

enter image description here

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

enter image description here

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..

Improve this answer
$\endgroup$
1
  • $\begingroup$ 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). $\endgroup$ Commented Apr 22, 2015 at 20:46
7
$\begingroup$

Update: 

SeedRandom[123] 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]}]

enter image description here

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

enter image description here

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

enter image description here

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]

enter image description here

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

enter image description here

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.