{-# LANGUAGE RebindableSyntax #-}
module Feature (
Class(..),
lowRateSqrt,
dictionaryMerged,
HMM(..),
readHMM,
writeHMM,
hmmHardwired,
) where
import qualified HiddenMarkovModel.Hardwired as HMMHard
import qualified HiddenMarkovModel as HMM
import qualified Math.HiddenMarkovModel.Named as HMMNamed
import qualified Evaluation
import qualified LabelChain
import qualified LabelChainShifted
import qualified LabelTrack
import qualified Label
import qualified Signal
import qualified Rate
import qualified Named
import qualified Class
import qualified Parameters as Params
import Parameters (Freq(Freq), formatFreq, Time(Time), timeCeil, )
import qualified SignalProcessingMethods as SPMethods
import qualified SignalProcessingSpecific as SPS
import SignalProcessingSpecific
(bandEnvelopes, bandEnvelopesLowRate, dehum, )
import SignalProcessing
(differentiate, differentiateMin3, differentiateMin3Init,
bandpass, lowpassTwoPass, centroidVariance3,
downSampleMax, downSampleMaxFrac, sliceOverlapping, )
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Basic.Binary as Bin
import qualified Data.StorableVector.Lazy as SVL
import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Functor.HT as FuncHT
import Control.Arrow ((^<<), (<<^), )
import Control.Monad (liftM2, )
import Control.Applicative ((<$>), )
import qualified Data.List.Reverse.StrictElement as Rev
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import qualified Data.Char as Char
import Data.Map (Map, ); import qualified Data.Map as Map
import Data.Set (Set, ); import qualified Data.Set as Set
import Data.Bool.HT (if', )
import Data.Maybe (isJust, )
import qualified System.Path.PartClass as PathClass
import qualified System.Path.IO as PathIO
import qualified System.Path as Path
import qualified Text.CSV.Lazy.String as CSV
import Text.Printf (printf, )
import NumericPrelude.Numeric
import NumericPrelude.Base
data Class =
Class {
name :: [String],
signals ::
SPMethods.T -> Signal.Sox -> Signal.T Rate.Feature [Named.Signal],
scale :: [Float],
fineSnappedFromCoarseIntervals ::
Params.T -> Rate.Feature -> Signal.Sox ->
LabelTrack.T Double Class.SoundParsed ->
ME.Exceptional String (LabelChain.T Int String),
evaluateFromIntervals ::
SPMethods.T -> Params.T ->
Signal.SoxLabelled String -> Evaluation.Result,
admissibleTransitions :: Set (String, String)
}
bandName :: [String]
bandName = ["band", "1200Hz", "2000Hz"]
highRate :: Class
highRate =
Class {
name = bandName ++ ["high rate"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = repeat 0.1,
signals =
\_methods sig@(Signal.Cons rate _) ->
let (_volume, (relEnv12, relEnv20, _relEnv40)) = bandEnvelopes sig
in Signal.Cons (Rate.featureFromSample rate) [relEnv12, relEnv20]
}
data HMM =
HMM {
hmmClass :: Class,
hmmodel :: HMMNamed.Gaussian Double
}
hmmHardwired :: HMM
hmmHardwired =
HMM {
hmmClass =
Class {
name = ["band", "2000Hz"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = repeat 0.1,
signals = \_methods sig@(Signal.Cons rate _) ->
let (_volume, (_relEnv12, relEnv20, _relEnv40)) =
bandEnvelopes sig
in Signal.Cons (Rate.featureFromSample rate) [relEnv20]
},
hmmodel = HMMHard.hmmNamed
}
reduceSampleRate :: Int -> Rate.Feature -> Rate.Feature
reduceSampleRate k (Rate.Feature rate) = Rate.Feature $ rate / fromIntegral k
formatRate :: Rate.Feature -> String
formatRate = printf "%.0fHz" . Rate.unpack
lowRate :: Rate.Feature -> Class
lowRate rate =
Class {
name = bandName ++ ["low rate", formatRate rate],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = repeat 0.1,
signals = \_methods sig ->
let (_volume, (relEnv12, relEnv20, _relEnv40)) =
bandEnvelopesLowRate rate sig
in Signal.Cons rate [relEnv12, relEnv20]
}
{- |
Computes the square root of all values
in order to compress high values and expand low values.
This way the emission clusters better fit to the normal distribution.
-}
lowRateSqrt :: Rate.Feature -> Class
lowRateSqrt rate =
Class {
name = bandName ++ ["low rate", formatRate rate, "sqrt"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = repeat (1/3),
signals = \_methods sig ->
let (_volume, (relEnv12, relEnv20, _relEnv40)) =
bandEnvelopesLowRate rate sig
in Signal.Cons rate $ map (fmap (SVL.map sqrt)) [relEnv12, relEnv20]
}
attackSignal ::
Rate.Feature -> Signal.Sox ->
(Named.Signal, Named.Signal, Named.Signal,
(Named.Signal, Named.Signal),
(Named.Signal, Named.Signal))
attackSignal featRate sig =
let rate = Signal.sampleRate sig
dehummed =
Causal.apply (dehum rate <<^ Bin.toCanonical) $ Signal.body sig
envelope =
downSampleMaxFrac (Rate.ratio rate featRate) $ SVL.map abs dehummed
volFreq = Freq 20
volume = lowpassTwoPass featRate volFreq envelope
relEnv = SVL.zipWith (/) envelope volume
relEnvDiff = Causal.apply differentiate relEnv
band bandFreq =
lowpassTwoPass featRate volFreq $
downSampleMaxFrac (Rate.ratio rate featRate) $
Causal.apply (abs ^<< bandpass rate 10 bandFreq) dehummed
relEnvBand f =
Named.Cons ("band " ++ formatFreq f) $ SVL.zipWith (/) (band f) volume
g0 = 1200; g1 = 2000
centroid =
SVL.zipWith
(\x0 x1 -> ((g0*x0 + g1*x1) / (x0+x1) * 2 - (g0+g1)) / (g1-g0))
(band (Freq g0))
(band (Freq g1))
f0 = 1000; f1 = 2500; f2 = 4000
spread =
SVL.zipWith3
(\x0 x1 x2 ->
snd (centroidVariance3 (f0,x0) (f1,x1) (f2,x2)) * (2 / (f2-f0))^2)
(band (Freq f0))
(band (Freq f1))
(band (Freq f2))
in (Named.Cons "envelope" relEnv,
Named.Cons "differentiated envelope" relEnvDiff,
Named.Cons "variance of envelope" $
lowpassTwoPass featRate volFreq $ SVL.map abs relEnvDiff,
(relEnvBand $ Freq 1200, relEnvBand $ Freq 2000),
(Named.Cons "centroid" centroid, Named.Cons "spread" spread))
attacks :: Rate.Feature -> Class
attacks rate =
Class {
name = ["attacks", formatRate rate],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1/2, 1],
signals = \_methods sig ->
let (_relEnv, relEnvDiff, variance, _relVol, _spectral) =
attackSignal rate sig
in Signal.Cons rate [relEnvDiff, variance]
}
attacksClipped :: Rate.Feature -> Class
attacksClipped rate =
Class {
name = ["attacks", formatRate rate, "clipped"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1, 1],
signals = \_methods sig ->
let (_relEnv, relEnvDiff, variance, _relVol, _spectral) =
attackSignal rate sig
-- (limit (0,1)) would cause a singular matrix in unsupervised training
softLimit x =
if' (x<0) (x/10) $
if' (x>1) ((x+9)/10) $
x
in Signal.Cons rate [fmap (SVL.map softLimit) relEnvDiff, variance]
}
attacksDelayed :: Rate.Feature -> Class
attacksDelayed rate =
Class {
name = ["attacks", formatRate rate, "delayed"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1/2, 1/2, 1],
signals = \_methods sig ->
let (relEnv, _relEnvDiff, variance, _relVol, _spectral) =
attackSignal rate sig
in Signal.Cons rate
[relEnv,
Named.apply "delayed"
(Causal.apply (Causal.consInit zero)) relEnv,
variance]
}
attacksFromEnv :: Named.Signal -> Named.Signal
attacksFromEnv = Named.apply "attacks" (Causal.apply differentiateMin3)
attackSignalMin3 ::
Rate.Feature -> Signal.Sox -> (Named.Signal, Named.Signal, Named.Signal)
attackSignalMin3 featRate sig =
let (relEnv, _relEnvDiff, _variance, _relVol, (_centroid, spread)) =
attackSignal featRate sig
in (relEnv, attacksFromEnv relEnv, spread)
attacksMin3Spread :: Rate.Feature -> Class
attacksMin3Spread rate =
Class {
name = ["attacks", formatRate rate, "min3", "spread"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1/2, 1],
signals = \_methods sig ->
let (_relEnv, relEnvDiff, spread) = attackSignalMin3 rate sig
in Signal.Cons rate [relEnvDiff, spread]
}
attacksMin3SpreadSat :: Rate.Feature -> Class
attacksMin3SpreadSat rate =
Class {
name = ["attacks", formatRate rate, "min3", "spread", "sat"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1/2, 1],
signals = \_methods sig ->
let (_relEnv, relEnvDiff, spread) = attackSignalMin3 rate sig
in Signal.Cons rate [fmap (SVL.map saturationRat) relEnvDiff, spread]
}
attacksMin3Band :: Rate.Feature -> Class
attacksMin3Band rate =
Class {
name = ["attacks", formatRate rate, "min3", "band", "2000hz"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1/2, 1/10],
signals = \_methods sig ->
let (relEnv, _relEnvDiff, _variance, (_relEnv12, relEnv20), _spectral) =
attackSignal rate sig
in Signal.Cons rate [attacksFromEnv relEnv, relEnv20]
}
attacksMin3BandSat :: Rate.Feature -> Class
attacksMin3BandSat rate =
Class {
name = ["attacks", formatRate rate, "min3", "band", "2000hz", "sat"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1/2, 1/10],
signals = \_methods sig ->
let (relEnv, _relEnvDiff, _variance, (_relEnv12, relEnv20), _spectral) =
attackSignal rate sig
in Signal.Cons rate
[fmap (Causal.apply (saturationRat ^<< differentiateMin3)) relEnv,
relEnv20]
}
attacksMin3Bands :: Rate.Feature -> Class
attacksMin3Bands rate =
Class {
name = ["attacks", formatRate rate, "min3", "band", "1200hz", "2000hz"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1/2, 1/10, 1/10],
signals = \_methods sig ->
let (relEnv, _relEnvDiff, _variance, (relEnv12, relEnv20), _spectral) =
attackSignal rate sig
in Signal.Cons rate [attacksFromEnv relEnv, relEnv12, relEnv20]
}
attacksMin3BandsSat :: Rate.Feature -> Class
attacksMin3BandsSat rate =
Class {
name = ["attacks", formatRate rate, "min3", "band", "1200hz", "2000hz", "sat"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [1/2, 1/10, 1/10],
signals = \_methods sig ->
let (relEnv, _relEnvDiff, _variance, (relEnv12, relEnv20), _spectral) =
attackSignal rate sig
in Signal.Cons rate
[fmap (Causal.apply (saturationRat ^<< differentiateMin3)) relEnv,
relEnv12, relEnv20]
}
attackBandsSignal :: Rate.Feature -> Signal.Sox -> (Named.Signal, Named.Signal)
attackBandsSignal featRate sig =
let rate = Signal.sampleRate sig
dehummed =
Causal.apply (dehum rate <<^ Bin.toCanonical) $ Signal.body sig
band f =
downSampleMaxFrac (Rate.ratio rate featRate) $
Causal.apply (abs ^<< bandpass rate 10 f) dehummed
volume =
lowpassTwoPass featRate (Freq 20) $
downSampleMaxFrac (Rate.ratio rate featRate) $ SVL.map abs dehummed
relEnv f =
Named.Cons ("band " ++ formatFreq f) $ SVL.zipWith (/) (band f) volume
in (relEnv $ Freq 1200, relEnv $ Freq 2000)
attacksBandsMin3 :: Rate.Feature -> Class
attacksBandsMin3 rate =
Class {
name = ["attacks", "1200Hz", "2000Hz", "low rate", formatRate rate, "min3"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [0.1, 0.1],
signals = \_methods sig ->
let (relEnv12, relEnv20) = attackBandsSignal rate sig
in Signal.Cons rate
[attacksFromEnv relEnv12, attacksFromEnv relEnv20]
}
attacksBandsMin3Sqrt :: Rate.Feature -> Class
attacksBandsMin3Sqrt rate =
Class {
name = ["attacks", "1200Hz", "2000Hz", "low rate", formatRate rate, "min3", "sqrt"],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3,
evaluateFromIntervals = Evaluation.fromClicksFineIntervals,
admissibleTransitions = HMM.admissibleTransitionSet,
scale = [0.1, 0.1],
signals = \_methods sig ->
let (relEnv12, relEnv20) = attackBandsSignal rate sig
in Signal.Cons rate
[Named.apply "attacks"
(Causal.apply (posSqrt ^<< differentiateMin3)) relEnv12,
Named.apply "attacks"
(Causal.apply (posSqrt ^<< differentiateMin3)) relEnv20]
}
posSqrt :: Float -> Float
posSqrt x = if x>0 then sqrt x else x
{-
Saturation function helps to separate high and low values
and concentrate the high values.
Otherwise some negative values are associated with the broad cloud of high values.
-}
{-
easier to write, but less efficient
-}
_saturationTanh :: Float -> Float
_saturationTanh x = tanh (x-0.5) + 0.5
{-
not as steep as tanh, but can be vectorised
-}
saturationRat :: Float -> Float
saturationRat x = satRat (x-0.5) + 0.5
satRat :: Float -> Float
satRat x = x/(1+abs x)
globalBandsSignal ::
SPMethods.T -> Rate.Feature -> Int -> Int -> Signal.Sox ->
(Named.Signal, Named.Signal, Named.Signal)
globalBandsSignal methods featRate blockSize preSize sig =
let band f =
SPMethods.bandpassDownSample methods
(reduceSampleRate blockSize featRate) f sig
(volume, relDehum) =
SPMethods.dehummedEnvelopeLowRate methods featRate sig
volumeDown = downSampleMax blockSize volume
relEnv f =
Named.Cons ("band " ++ formatFreq f) $
SVL.zipWith (/) (band f) volumeDown
maxAttacks =
Named.Cons "attack" $
SigG.fromList SigG.defaultLazySize $ fmap SVL.maximum $
sliceOverlapping blockSize (preSize, 0) $
Causal.apply
(differentiateMin3Init $ SVL.switchL zero const relDehum) $
relDehum
in (maxAttacks, relEnv $ Freq 1200, relEnv $ Freq 2000)
globalBands :: Rate.Feature -> Int -> Int -> Class
globalBands rate blockSize preSize =
Class {
name =
["global", "1200Hz", "2000Hz", "low rate", formatRate rate,
"block size", show blockSize],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsGlobal,
evaluateFromIntervals = Evaluation.fromGlobalRumbleDuo,
admissibleTransitions =
let states =
[Label.pause, Label.rasping, Label.chirping, Label.growling]
in Set.fromList $ liftM2 (,) states states,
scale = [1/3, 0.1, 0.1],
signals = \methods sig ->
let (maxAttacks, relEnv12, relEnv20) =
globalBandsSignal methods rate blockSize preSize sig
in Signal.Cons (reduceSampleRate blockSize rate)
[maxAttacks, relEnv12, relEnv20]
}
globalBandsSqrt :: Rate.Feature -> Int -> Int -> Class
globalBandsSqrt rate blockSize preSize =
let cls = globalBands rate blockSize preSize
in cls {
name = name cls ++ ["sqrt"],
signals = \methods sig ->
map (SVL.map sqrt <$>) <$> signals cls methods sig
}
{- |
List must be non-empty, but we have no benefit from using NonEmpty.T.
-}
positiveOffset :: (Ord a) => [a] -> a
positiveOffset xs = List.sort xs !! div (length xs) 32
removePositiveOffset :: SVL.Vector Float -> SVL.Vector Float
removePositiveOffset xs =
SVL.map (subtract $ positiveOffset $ SVL.unpack xs) xs
globalBandsRumbleSignal ::
SPMethods.T -> Rate.Feature -> Int -> Signal.Sox ->
(Named.Signal, Named.Signal, Named.Signal, Named.Signal)
globalBandsRumbleSignal methods featRate blockSize sig =
let band f =
SPMethods.bandpassDownSample methods
(reduceSampleRate blockSize featRate) f sig
(volume, relDehum) =
SPMethods.dehummedEnvelopeLowRate methods featRate sig
volumeDown = downSampleMax blockSize volume
relEnv f =
Named.Cons ("band " ++ formatFreq f) $
SVL.zipWith (/) (band f) volumeDown
{-
We do not normalize the rumbling track with the volume
because we expect that rumble always occur directly at the microphone
and thus should have similar amplitude.
The rumbles might still differ in amplitude
and microphones might be calibrated differently.
We weaken this influence by taking square roots.
Additionally we remove the influence of background noise
by subtracting a low quantile of the rumble signal.
-}
rumblingEnv =
Named.Cons "rumbling" $
removePositiveOffset $ SVL.map sqrt $
SPMethods.downSampleAbs methods
(Rate.unpack featRate / fromIntegral blockSize) $
SPMethods.rumble methods sig
maxAttacks =
Named.Cons "attack" $
SigG.fromList SigG.defaultLazySize $ fmap SVL.maximum $
sliceOverlapping blockSize (blockSize, 0) $
Causal.apply
(differentiateMin3Init $ SVL.switchL zero const relDehum) $
relDehum
in (maxAttacks, rumblingEnv, relEnv $ Freq 1200, relEnv $ Freq 2000)
globalBandsRumbleSolo :: Rate.Feature -> Int -> Class
globalBandsRumbleSolo rate blockSize =
Class {
name =
["global", "rumble", "solo", "1200Hz", "2000Hz",
"low rate", formatRate rate, "block size", show blockSize],
fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsGlobal,
evaluateFromIntervals = Evaluation.fromGlobalRumbleSolo,
admissibleTransitions =
let states =
[Label.pause, Label.rumble,
Label.rasping, Label.chirping, Label.growling]
in Set.fromList $ liftM2 (,) states states,
scale = [1/3, 1, 0.1, 0.1],
signals = \methods sig ->
let (maxAttacks, relRumbleEnv, relEnv12, relEnv20) =
globalBandsRumbleSignal methods rate blockSize sig
in Signal.Cons (reduceSampleRate blockSize rate)
[maxAttacks, relRumbleEnv, relEnv12, relEnv20]
}
globalBandsRumbleDuo :: Rate.Feature -> Int -> Class
globalBandsRumbleDuo rate blockSize =
Class {
name =
["global", "rumble", "duo", "1200Hz", "2000Hz",
"low rate", formatRate rate, "block size", show blockSize],
fineSnappedFromCoarseIntervals =
fineSnappedFromCoarseIntervalsGlobalRumble,
evaluateFromIntervals = Evaluation.fromGlobalRumbleDuo,
admissibleTransitions =
let states =
[Label.pause, Label.rasping, Label.chirping, Label.growling,
Label.rumble, Label.raspingRumble,
Label.chirpingRumble, Label.growlingRumble]
in Set.fromList $ liftM2 (,) states states,
scale = [1/3, 1, 0.1, 0.1],
signals = \methods sig ->
let (maxAttacks, relRumbleEnv, relEnv12, relEnv20) =
globalBandsRumbleSignal methods rate blockSize sig
in Signal.Cons (reduceSampleRate blockSize rate)
[maxAttacks, relRumbleEnv, relEnv12, relEnv20]
}
tickingToRasping ::
Class.Sound ticking chirping ticking growling ->
Class.Sound ticking chirping ticking growling
tickingToRasping cls =
case cls of
Class.Ticking x -> Class.Rasping x
_ -> cls
liftExc ::
Rate.C rate =>
(rate -> signal -> LabelChain.T Int a -> b) ->
rate -> signal -> LabelTrack.T Double a -> ME.Exceptional String b
liftExc f rate sig =
fmap (f rate sig . Signal.body) . LabelTrack.discretizeTrack rate
fineSnappedFromCoarseIntervalsGlobal ::
Params.T -> Rate.Feature -> Signal.Sox ->
LabelTrack.T Double (Class.Sound rasping chirping rasping growling) ->
ME.Exceptional String (LabelChain.T Int String)
fineSnappedFromCoarseIntervalsGlobal _params = liftExc $ \ _rate _sig ->
fmap (Class.toName . tickingToRasping)
{- |
Turn overlapping "+rumble" labels into combined labels like "rasping rumble".
-}
mergeRumble ::
(Rate.C rate) =>
rate ->
LabelTrack.T Double Class.SoundParsed ->
ME.Exceptional String (LabelChain.T Int Class.SoundPurity)
mergeRumble rate track = do
let (rumble, labels) =
FuncHT.unzip $
LabelTrack.partition
((Just Label.overlayedRumble ==) . Class.maybeOther) <$>
LabelTrack.discretizeTimes rate (Class.checkPurity <$> track)
sortedRumble <- LabelTrack.checkOverlap rumble
fmap (\(maybeRumble, cls) -> Class.setRumble (isJust maybeRumble) cls) .
LabelChainShifted.shiftToLabelChain .
LabelChainShifted.subdivideTrack (Signal.body sortedRumble) .
LabelChainShifted.fromLabelChain . Signal.body
<$> LabelTrack.checkGaps labels
fineSnappedFromCoarseIntervalsGlobalRumble ::
Params.T -> Rate.Feature -> Signal.Sox ->
LabelTrack.T Double Class.SoundParsed ->
ME.Exceptional String (LabelChain.T Int String)
fineSnappedFromCoarseIntervalsGlobalRumble _params rate _sig =
fmap (fmap (Class.purityToName . tickingToRasping)) . mergeRumble rate
_fineFromCoarseIntervalsBand20 ::
Params.T -> Rate.Feature -> SVL.Vector Float ->
LabelChain.T Int (Class.Sound rasping chirping ticking growling) ->
LabelChain.T Int String
_fineFromCoarseIntervalsBand20 _params rate =
LabelChain.fineFromCoarseIntervalsInt
(case 3::Int of
0 -> LabelChain.detectClicksExtrema
(timeCeil rate (Time 0.01),
timeCeil rate (Time 0.03))
1 -> LabelChain.detectClicksThreshold 2.5
2 -> LabelChain.detectClicksLaxMonotony (1.0,1.0)
_ -> LabelChain.detectClicksWeakMonotony (3,3) 0.5)
{-
Threshold 0.5 gives a better separation
of the emission clusters of r0 and r1,
especially in the 1.2 kHz band,
than a higher threshold like 0.7.
However the low threshold risks to leave an empty click end phase.
-}
fineFromCoarseIntervalsEnv ::
Params.T -> Rate.Feature -> SVL.Vector Float ->
LabelChain.T Int (Class.Sound rasping chirping ticking growling) ->
LabelChain.T Int String
fineFromCoarseIntervalsEnv params _rate =
LabelChain.fineFromCoarseIntervalsInt
(LabelChain.detectClicksWeakMonotony
(Params.weakCounterSlopeSizes params) 0.5)
_fineSnappedFromCoarseIntervalsBand20 ::
Params.T -> Rate.Feature -> Signal.Sox ->
LabelChain.T Int (Class.Sound rasping chirping ticking growling) ->
LabelChain.T Int String
_fineSnappedFromCoarseIntervalsBand20 params rate sig =
let (_volume, (_relEnv12, Named.Cons _ relEnv20, _relEnv40)) =
bandEnvelopesLowRate rate sig
in _fineFromCoarseIntervalsBand20 params rate relEnv20 .
LabelChain.snapBoundaries relEnv20
{- |
This should be prefered to '_fineSnappedFromCoarseIntervalsBand20'
since it also works if the 2 kHz band is weak, e.g. in growling sounds.
-}
fineSnappedFromCoarseIntervalsEnv ::
Params.T -> Rate.Feature -> Signal.Sox ->
LabelTrack.T Double (Class.Sound rasping chirping ticking growling) ->
ME.Exceptional String (LabelChain.T Int String)
fineSnappedFromCoarseIntervalsEnv params = liftExc $ \ rate sig ->
let (_volume, env) =
SPMethods.dehummedEnvelopeLowRate SPS.methods rate sig
in fineFromCoarseIntervalsEnv params rate env .
LabelChain.snapBoundaries env
fineSnappedFromCoarseIntervalsDiff ::
Params.T -> Rate.Feature -> Signal.Sox ->
LabelTrack.T Double (Class.Sound rasping chirping ticking growling) ->
ME.Exceptional String (LabelChain.T Int String)
fineSnappedFromCoarseIntervalsDiff _params = liftExc $ \ rate sig ->
let (Named.Cons _ relEnv, Named.Cons _ relEnvDiff,
_variance, _relVol, _spectral) =
attackSignal rate sig
in LabelChain.fineFromCoarseIntervalsInt2
(LabelChain.detectClicksDiff 0.2 0.8) relEnv relEnvDiff .
LabelChain.snapBoundaries relEnv
fineSnappedFromCoarseIntervalsMin3 ::
Params.T -> Rate.Feature -> Signal.Sox ->
LabelTrack.T Double (Class.Sound rasping chirping ticking growling) ->
ME.Exceptional String (LabelChain.T Int String)
fineSnappedFromCoarseIntervalsMin3 _params = liftExc $ \ rate sig ->
let (Named.Cons _ relEnv, Named.Cons _ relEnvDiff, _variance) =
attackSignalMin3 rate sig
in LabelChain.fineFromCoarseIntervalsInt2
(LabelChain.detectClicksThreshold 0.5) relEnv relEnvDiff .
LabelChain.snapBoundaries relEnv
dictionary :: Map [String] Class
dictionary =
Map.fromList $
map (\cls -> (name cls, cls)) $
let featRate = Rate.Feature 200
in highRate :
lowRate featRate :
lowRateSqrt featRate :
attacks featRate :
attacksClipped featRate :
attacksDelayed featRate :
attacksMin3Spread featRate :
attacksMin3SpreadSat featRate :
attacksMin3Band featRate :
attacksMin3BandSat featRate :
attacksMin3Bands featRate :
attacksMin3BandsSat featRate :
attacksBandsMin3 featRate :
attacksBandsMin3Sqrt featRate :
globalBands featRate 5 5 :
globalBands featRate 10 0 :
globalBands featRate 20 0 :
globalBandsSqrt featRate 5 5 :
globalBandsRumbleSolo featRate 5 :
globalBandsRumbleDuo featRate 5 :
[]
mergeName :: [String] -> String
mergeName =
let lower c =
case c of
' ' -> '-'
_ -> Char.toLower c
in List.intercalate "-" . map (map lower)
dictionaryMerged :: Map String Class
dictionaryMerged = Map.mapKeys mergeName dictionary
readHMM :: (PathClass.AbsRel ar) => Path.File ar -> IO HMM
readHMM path = do
content <- PathIO.readFile path
case ListHT.breakAfter ('\n'==) content of
(featureRow, model) ->
ME.resolveT (ioError . userError) $ ME.ExceptionalT $ return $ do
hmmNamed <- HMMNamed.fromCSV model
featureDescr <-
case CSV.parseCSV featureRow of
[header] ->
fmap (Rev.dropWhile null . map CSV.csvFieldContent) $
ME.mapException
(unlines . ("when parsing header:" :) .
map CSV.ppCSVError) $
ME.fromEither header
_ -> error "CSV parsing of a row should produce exactly one row"
let notFoundMsg =
unlines $
("unknown feature set: " ++ featureRow) :
"known sets:" :
(map show $ Map.keys dictionary)
feature <-
ME.fromMaybe notFoundMsg $
Map.lookup featureDescr dictionary
return $
HMM {
hmmClass = feature,
hmmodel = hmmNamed
}
writeHMM :: (PathClass.AbsRel ar) => Path.File ar -> HMM -> IO ()
writeHMM path featureHMM =
PathIO.writeFile path $ toCSV featureHMM
toCSV :: HMM -> String
toCSV featureHMM =
(CSV.ppCSVTable $ snd $ CSV.toCSVTable [name $ hmmClass featureHMM])
++
(HMMNamed.toCSV $ hmmodel featureHMM)