Pyknograms

Hilbert[X_] := Module[{x, h, n = Length[X]},
   x = Fourier[X];
   h = Table[
     Piecewise[{{1, i == 1 || i == Floor[n/2] + 1}, {2,
        i <= Floor[n/2]}}], {i, n}];
   InverseFourier[h x][[;; n]]
   ];
Unwrap[data_?VectorQ, tol_: Pi/2, inc_: 2 Pi] :=
  data + inc FoldList[Plus, 0,
     Sign[Chop[Apply[Subtract, Partition[data, 2, 1], {1}], tol]]];
Freq[X_] := Module[{H = Hilbert[X], \[Phi]},
   \[Phi] = Unwrap[Arg@H];
   Block[{\[Sigma] = 4},
    ListConvolve[
     Table[-((E^(-(x^2/(2 \[Sigma]))) x)/(Sqrt[
            2 \[Pi]] \[Sigma]^2)), {x, -2 \[Sigma],
       2 \[Sigma], \[Sigma]/10}], \[Phi]]]
   ];
Filter[X_, width_, sep_] :=
  Module[{x =
     PadRight[PadLeft[X, Floor[Length[X] + width/2], 10^-7],
      Floor[Length[X] + width], 10^-7]},

   Table[(0.54 - 0.46 Cos[2 Pi i/(width - 1)]) x[[i + j sep]], {j, 0,
     Floor[(Length@x - width)/sep] - 1}, {i, 1, width}]
   ];
FreqEstimate[fs_] := Module[{\[Mu], \[Sigma]},
   \[Mu] = Length[fs] Mean[fs^2*Range[Length[fs]]]/Total[fs^2];
   \[Sigma] = Total[(Range[Length[fs]] - \[Mu])^2 fs^2]/Total[fs^2];
   {\[Mu], \[Sigma]}
   ];
Pyknos[X_] :=
  Module[{frames, ft, framewidth = 16000*0.025,
    framesep = 16000*0.01, n = Length[X], filterwidth = 50,
    filtersep = 5, out},
   frames = Filter[X, framewidth, framesep];

   out = Map[
     Map[FreqEstimate,
       Filter[Abs[Fourier[#]][[;; Floor[framewidth/2]]], filterwidth,
        filtersep]] &
     ,
     frames];
   Map[Table[{filtersep (i - 1) - filterwidth/2, 0},
       {i, Length[out[[1]]]}] + # &
    , out]
   ];
Spectrogram[X_] :=
  Module[{frames, ft, framewidth = 16000 *0.025,
    framesep = 16000*0.01, n = Length[X], filterwidth = 200,
    filtersep = 2, out},
   frames = Filter[X, framewidth, framesep];

   out = Map[
     Abs[Fourier[#]][[;; Floor[framewidth/2]]] &
     ,
     frames]
   ];
DownSample[l_, n_] := Table[l[[i]], {i, 1, Length@l, n}];
voice = Import[
   "/Users/matt/Music/iTunes/iTunes Media/Music/Unknown \
Artist/Unknown Album/mg436x-001-120416_231400_0001162_0001585.wav",
   "Data"];
data = First[voice];
spec = Reverse@Transpose@Spectrogram[data];
pyk = Transpose@Pyknos[data];
VariancePoly[l_, col_: Black] :=
  Module[{\[Mu] = First /@ l, \[Sigma] = Last /@ l,
    x = Range[Length@l]},
   {Opacity[0.05], col, Table[
     Polygon[
      Join[Transpose@{x, \[Mu] + i \[Sigma]/10},
       Reverse[Transpose@{x,
          Map[Max[0, #] &, \[Mu] - i \[Sigma]/10]}]]]
     , {i, 5}],
    Opacity[0.2], Black, Thick,
    Line[Transpose@{x, Map[Max[0, #] &, \[Mu]]}]
    }
   ];
SimplePyk[l_, col_: Black] :=
 Module[{\[Mu] = First /@ l, \[Sigma] = Last /@ l,
   x = Range[Length@l]},
  {
   col, Line[Transpose@{x, Map[Max[0, #] &, \[Mu]]}]
   }
  ];
pykplot =
 Graphics[{Table[
    VariancePoly[pyk[[i]][[110 ;; 300]],
     Blend[{Purple, RGBColor[0.1, 0.6, 0.2]}, i/20]], {i, 20}]},
  AspectRatio -> 0.4, PlotRange -> {0, 100}]