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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.