Best way to include a "singularity" in a SmoothHistogram?

Question

I have a dataset like this:

data = {0,0,1.1,1.3,0,0,3.4,0,0,2.3,0,0 .....}

You can imagine that data is generated from a probability distribution of the form:

$$p(x)=w_0\delta(x) + (1 - w_0)f(x)$$

where $f(x)$ is a smooth probability density function, $\delta$ is Dirac-delta function, and $0\le w_0 \le 1$.

That is, there is a finite probability that $x=0$.

I want to plot an histogram of data. If I exclude 0, then a SmoothHistogram is fine. But now I want to include also in this plot the frequency of 0. In this case, SmoothHistogram performs poorly, since it tries to draw a smooth peak centered at 0.

Can you suggest a better way to visualize data? Note that I know that the location of the singularity is at 0.

Answer 1

I guess you just do something like this:

data = RandomSample[Join[RandomVariate[NormalDistribution[2, 1], 2000],
    ConstantArray[0, {100}]]];
Histogram[data]

SmoothHistogram[Select[data, # != 0 &], 
 Epilog -> Line[{{0, 0}, {0, .15}}], AxesOrigin -> {-2, 0}]

I cant see a sensible way to scale that line (It really goes to Infinity).

also the overall smooth plot ought to be scaled down somehow something like this should do:

 SmoothHistogram[...]/.Line[x_?(Length[#] > 3 &)] :> 
               Line[{1, Count[data, 0]/Length@data} # & /@ x]

In this case the scale change is so small its not worth showing another plot.

Edit:

here is an idea, pick a bin width around your singularity, then you can assign an appropriate height to a bar on the chart:

bin = .1;
inbin = Select[data, Abs[#] < bin &] // Length;
hbin = inbin/Length[data]/(2 bin) // N
SmoothHistogram[Select[data, Abs[#] > bin &], 
  Epilog -> Rectangle[{-bin, 0}, {bin, hbin}], 
  AxesOrigin -> {-2, 0}] /. 
 Line[x_?(Length[#] > 3 &)] :> 
  Line[{1, 1 - inbin/Length@data} # & /@ x]

note this counts all the data in the bin not just the exact zeros. This last chart looks a little different because its using a new random data set by the way.

Answer 2

This is what we get playing with the parameters of SmoothHistogram and SmoothKernelDistribution:

data = RandomSample[Join[RandomVariate[NormalDistribution[2, 1], 2000], 
    ConstantArray[0, {100}]]];
Histogram[data]

SmoothHistogram[data, {"Adaptive", .1, .001}]

SmoothHistogram[data, {"Adaptive", .05, .01}]

dist = SmoothKernelDistribution[data, {"Adaptive", .1, .001}];

Plot[PDF[dist, x], {x, -4, 4}]