module Evaluation (
Result,
fromClicksFineIntervals,
fromGlobalRumbleSolo,
fromGlobalRumbleDuo,
) where
import qualified LabelTrack
import qualified LabelChain
import qualified SignalProcessingMethods as SPMethods
import qualified SignalProcessing as SP
import qualified Signal
import qualified Rate
import qualified Named
import qualified Class
import qualified Parameters as Params
import LabelChain (BreakRel(BreakRel), )
import Parameters (Time(Time), getTime, )
import Measurement
(ClassFeatures, ChunkFeatures, SpectralParameters, measureSignal, )
import qualified Control.Functor.HT as FuncHT
import Control.Monad (join, )
import Control.Applicative ((<$>), )
import Control.Functor.HT (void)
import qualified Data.NonEmpty as NonEmpty
import qualified Data.List.HT as ListHT
import Data.Tuple.HT (mapSnd, )
import Text.Printf (printf, )
import Algebra.ToRational (realToField)
import NumericPrelude.Numeric
import NumericPrelude.Base
import Prelude ()
type SoundMeasure t = Class.Sound Int (BreakRel t) Int Int
doubleFromTime :: Time -> Double
doubleFromTime = realToField . Params.getTime
_classFromClicksFloat ::
Params.T ->
LabelChain.T Double String ->
LabelChain.T Double (SoundMeasure Double)
_classFromClicksFloat params =
let skip :: (a -> a) -> (a -> a)
skip _ = id
in fmap
(Class.mapTicking SP.foldLength .
Class.mapRasping SP.foldLength .
Class.mapGrowling SP.foldLength) .
LabelChain.classRelativeFromAbsolute .
LabelChain.fuseTickingBouts join .
LabelChain.tickingsFromRaspings
(ListHT.lengthAtLeast (Params.raspingMinNumClicks params) .
NonEmpty.flatten) .
skip
(LabelChain.breakLongClicks
(realToField (Params.raspingMaxRelativeClickDistance params) *)) .
LabelChain.mergeRaspingGrowling
join (void . concatMap NonEmpty.flatten) .
LabelChain.classFromFineIntervals .
LabelChain.correctShortChirping
(doubleFromTime $ Params.chirpingHackDur params) .
skip
(LabelChain.mergeRaspingShortPause
(doubleFromTime $ Params.hardHighDist params))
classFromClicksInt ::
Params.T -> Rate.Sample ->
LabelChain.T Int String ->
LabelChain.T Int (SoundMeasure Int)
classFromClicksInt params rate =
let skip :: (a -> a) -> (a -> a)
skip _ = id
in fmap
(Class.mapTicking SP.foldLength .
Class.mapRasping SP.foldLength .
Class.mapGrowling SP.foldLength) .
LabelChain.classRelativeFromAbsolute .
LabelChain.fuseTickingBouts join .
LabelChain.tickingsFromRaspings
(ListHT.lengthAtLeast (Params.raspingMinNumClicks params) .
NonEmpty.flatten) .
skip
(LabelChain.breakLongClicks
(\median ->
ceiling $
Params.raspingMaxRelativeClickDistance params
* fromIntegral median)) .
LabelChain.mergeRaspingGrowling
join (void . concatMap NonEmpty.flatten) .
LabelChain.classFromFineIntervals .
LabelChain.correctShortChirping
(Params.time rate $ Params.chirpingHackDur params) .
skip
(LabelChain.mergeRaspingShortPause
(Params.time rate $ Params.hardHighDist params))
classLabelsFromChunkFeatures ::
ChunkFeatures ->
Class.Sound rasping chirping ticking growling -> SoundMeasure Int
classLabelsFromChunkFeatures
((numClicks, _sumHalfLifes, _numEmphasized), chirpMain) cls =
case cls of
Class.Rasping _ -> Class.Rasping numClicks
Class.Chirping _ -> Class.Chirping $ BreakRel chirpMain
Class.Ticking _ -> Class.Ticking numClicks
Class.Growling _ -> Class.Growling numClicks
Class.Other str -> Class.Other str
checkWarn :: Bool -> a -> [a]
checkWarn cond msg = if cond then [] else [msg]
checkChirping :: Params.T -> (Double, Double) -> [String]
checkChirping params bnd =
let dur = Time $ realToFrac $ uncurry subtract bnd
minDur = Params.chirpingMinDur params
maxDur = Params.chirpingMaxDur params
in (checkWarn (dur >= minDur) $
printf "duration must be at least %f" $ getTime minDur)
++
(checkWarn (dur <= maxDur) $
printf "duration must be at most %f" $ getTime maxDur)
checkTicking :: Int -> [String]
checkTicking numClicks =
checkWarn (numClicks > 0) "zero ticks"
suspiciousIntervalsFromClicks ::
Params.T -> Rate.Sample ->
LabelTrack.T Double (ChunkFeatures, SoundMeasure Int) ->
LabelTrack.T Double String
suspiciousIntervalsFromClicks params highRate =
let measRate = Params.measureSampleRate params
in LabelTrack.concat .
LabelTrack.mapWithTime
(\bnd (((numClicks, _sumHalfLifes, _numEmphasized), chirpMain), cls) ->
case cls of
Class.Rasping n ->
let minNumClicks = Params.raspingMinNumClicks params
in (checkWarn (n == numClicks) $
printf "deviating alternative click count: %d" n)
++
(checkWarn (numClicks >= minNumClicks) $
printf "expected at least %d clicks" minNumClicks)
Class.Chirping (BreakRel brk) ->
let maxDev = Params.chirpingMainDurMaxDeviation params
brkTime = Params.toTime highRate brk
mainTime = Params.toTime measRate chirpMain
in checkChirping params bnd
++
(checkWarn
((Time $ realToFrac $ abs $ brkTime-mainTime)
<= maxDev) $
printf "deviating main duration: %f vs. %f"
brkTime mainTime)
Class.Growling n ->
(checkWarn (n == numClicks) $
printf "deviating alternative click count: %d" n)
Class.Ticking n -> checkTicking n
_ -> [])
type Result =
(LabelChain.T Double (SoundMeasure Int),
LabelTrack.T Double String,
(Signal.LabelChain Rate.Measure
(SpectralParameters Float, ClassFeatures),
([Float], Signal.T Rate.Measure [Named.Signal])))
fromClicks ::
SPMethods.T -> Params.T -> Signal.SoxLabelled (SoundMeasure Int) -> Result
fromClicks sigProc params labelled =
let (sig, classified) = FuncHT.unzip labelled
(chunkFeats, measuresEnvelopes) = measureSignal sigProc params labelled
classifiedMeas =
LabelChain.zipWithList (,) chunkFeats $
Signal.labelRealTimes classified
in (fmap (uncurry classLabelsFromChunkFeatures) classifiedMeas,
suspiciousIntervalsFromClicks params (Signal.sampleRate sig) $
LabelTrack.fromLabelChain classifiedMeas,
measuresEnvelopes)
fromClicksFineIntervals ::
SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result
fromClicksFineIntervals sigProc params sig =
fromClicks sigProc params $
fmap (mapSnd (classFromClicksInt params (Signal.sampleRate sig))) sig
suspiciousIntervalsFromGlobal ::
Params.T ->
LabelTrack.T Double (Class.Sound rasping chirping Int growling) ->
LabelTrack.T Double String
suspiciousIntervalsFromGlobal params =
LabelTrack.concat .
LabelTrack.mapWithTime
(\bnd cls ->
case cls of
Class.Chirping _ -> checkChirping params bnd
Class.Ticking numClicks -> checkTicking numClicks
_ -> [])
countClicksGlobal ::
SPMethods.T -> Params.T ->
Signal.SoxLabelled (Class.Sound rasping chirping ticking growling) ->
LabelChain.T Double (Class.Sound Int (BreakRel Int) Int Int)
countClicksGlobal sigProc params sigClassified =
{- ToDo:
comparison could be made more lazy
using lazy chunky numbers from non-negative package
-}
LabelChain.mergeRaspingGrowling NonEmpty.sum sum $
LabelChain.zipWithList classLabelsFromChunkFeatures
(fst $ measureSignal sigProc params sigClassified) $
Signal.labelRealTimes $ fmap snd sigClassified
{- |
Works on sequences like rasping-rumble-rasping.
-}
classFromGlobalRumbleSolo ::
SPMethods.T -> Params.T -> Signal.SoxLabelled String ->
(LabelTrack.T Double String,
LabelChain.T Double (SoundMeasure Int))
classFromGlobalRumbleSolo sigProc params sigClassified =
let (rumbling, classifiedMeas) =
LabelChain.unzipRumbling $
{-
The NonEmpty.head selects the information of the first chirping chunk.
That carries a BreakRel value that becomes rather arbitrary
after merging chirping with rumble.
-}
LabelChain.assimilateRumblingSolo
NonEmpty.sum NonEmpty.head NonEmpty.sum
(doubleFromTime $ Params.maxInterimRumblingDur params) $
countClicksGlobal sigProc params $
fmap (mapSnd (fmap Class.fromLabel)) sigClassified
in (rumbling,
LabelChain.fuseTickingBouts NonEmpty.sum $
LabelChain.tickingsFromRaspings
(Params.raspingMinNumClicks params <=) $
classifiedMeas)
{- |
Works on sequences like rasping-raspingRumble-rasping.
-}
classFromGlobalRumbleDuo ::
SPMethods.T -> Params.T -> Signal.SoxLabelled String ->
(LabelTrack.T Double String,
LabelChain.T Double (SoundMeasure Int))
classFromGlobalRumbleDuo sigProc params sigClassified =
let sigRumbleClassified =
mapSnd
(LabelChain.unzipRumbling .
LabelChain.assimilateRumblingDuo .
fmap (Class.checkPurity . Class.fromLabel))
<$>
sigClassified
in (LabelTrack.mergeNamesakes $
LabelTrack.realTimes $ fst . snd <$> sigRumbleClassified,
LabelChain.fuseTickingBouts NonEmpty.sum $
LabelChain.tickingsFromRaspings (Params.raspingMinNumClicks params <=) $
countClicksGlobal sigProc params $
mapSnd snd <$> sigRumbleClassified)
{- ToDo:
Is it possible and sensible to split measureSignal,
such that we need to call it only once?
-}
fromGlobal ::
SPMethods.T -> Params.T -> Signal.Sox ->
(LabelTrack.T Double String, LabelChain.T Double (SoundMeasure Int)) ->
Result
fromGlobal sigProc params sig (rumbling, classifiedMeas) =
(classifiedMeas,
LabelTrack.merge
(suspiciousIntervalsFromGlobal params
(LabelTrack.fromLabelChain classifiedMeas))
rumbling,
snd $ measureSignal sigProc params $
Signal.addDiscretizedLabels sig classifiedMeas)
fromGlobalRumbleSolo ::
SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result
fromGlobalRumbleSolo sigProc params labelled =
fromGlobal sigProc params (fmap fst labelled) $
classFromGlobalRumbleSolo sigProc params labelled
fromGlobalRumbleDuo ::
SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result
fromGlobalRumbleDuo sigProc params labelled =
fromGlobal sigProc params (fmap fst labelled) $
classFromGlobalRumbleDuo sigProc params labelled