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?

$\endgroup$
  • $\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$ – Sjoerd C. de Vries Apr 22 '15 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$ – highsciguy Apr 22 '15 at 15:41
  • $\begingroup$ Doesn't look like a usable definition either. $\endgroup$ – Sjoerd C. de Vries Apr 22 '15 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$ – highsciguy Apr 22 '15 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$ – Sjoerd C. de Vries Apr 22 '15 at 16:15
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..

$\endgroup$
  • $\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$ – highsciguy Apr 22 '15 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

$\endgroup$

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.