{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import qualified HiddenMarkovModel as HMM
import qualified Math.HiddenMarkovModel.Named as HMMNamed
import qualified Math.HiddenMarkovModel as HMM0
import qualified Durations as Durs
import qualified LabelTrack
import qualified LabelChainShifted
import qualified LabelChain
import qualified Fourier
import qualified Feature
import qualified Class
import qualified Named
import qualified Parameters as Params
import qualified SignalProcessingOption as SPOption
import qualified SignalProcessingMethods as SPMethods
import qualified SignalProcessing as SP
import qualified Signal
import qualified Rate
import Measurement (measureSignal, )
import SignalProcessingSpecific (filterBand, dehum, )
import SignalProcessing (bandpass, lowpassTwoPass, lag2, svlConcat, )
import Parameters (Time(Time), Freq(Freq), time, )
import qualified Option
import qualified Options.Applicative as OP
import Option
(Flags,
TrainingFlags
(TrainingFlags, trainingFeature, trainingSignalProcessing))
import qualified Time
import qualified Data.Time.LocalTime as LocalTime
import qualified Data.Time.Format as TimeFormat
import Data.Time.LocalTime (LocalTime)
import qualified Synthesizer.Generic.Filter.Recursive.Comb as Comb
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Basic.Binary as Bin
import qualified Sound.Audacity.Project.Track.Label as ProjectLabelTrack
import qualified Sound.Audacity.Project.Track.Wave.Summary as ProjectWaveSummary
import qualified Sound.Audacity.Project as Audacity
import qualified Audacity.TrackName as TrackName
import qualified Sound.SoxLib as SoxLib
import Sox (withSound, writeChannels, writeFeatures)
import Audacity (
projectLabelChain, projectLabelTrack,
projectWaveTrackConcat, projectWaveTrackFeatures,
projectWaveTrackInput, projectWaveTrackInputSummary,
summary, waveSummaryEval,
writeFeatureTracks, writeLabelTrackInt,
zoomFullSignal, zoomWidth,
OriginPaths, originsFromRecordingTrack, originsFromOriginTrack,
getOriginRoot, dirFromAudPath,
createProject,
)
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import qualified Text.HTML.Tagchup.Parser as TagParser
import qualified Spreadsheet.Formula as CalcForm
import qualified Spreadsheet.Format as Format
import Spreadsheet.Format (Results, formatTables, (<->), )
import qualified Data.Text.IO as TextIO
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Graphics.Gnuplot.Frame.OptionSet as Opts
import qualified Graphics.Gnuplot.Frame as Frame
import qualified Graphics.Gnuplot.LineSpecification as LineSpec
import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D
import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D
import qualified Graphics.Gnuplot.Terminal.Default as DefaultTerm
import qualified Graphics.Gnuplot.Advanced as GP
import qualified Control.Parallel.Strategies as Par
import qualified Control.Concurrent.PooledIO.Final as Parallel
import qualified Control.Concurrent.PooledIO.Sequence as Sequence
import qualified Control.Concurrent.Split.MVar as MVar
import Control.Concurrent (forkIO, getNumCapabilities, )
import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Arrow as Arrow
import qualified Control.Functor.HT as FuncHT
import qualified GHC.IO.Exception as GHCExc
import qualified System.IO.Error as IOErr
import Control.Exception (bracket)
import Control.DeepSeq (NFData, rnf, ($!!), )
import Control.Arrow ((^<<), (<<^), )
import Control.Category (id, )
import Control.Monad.IO.Class (MonadIO, )
import Control.Monad.HT ((<=<), )
import Control.Monad (when, guard, void, liftM2, liftM3, )
import Control.Applicative (pure, liftA2, (<*>), (<|>), (<$), (<$>), )
import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import qualified Data.Array.Comfort.Boxed as Array
import qualified Data.List.Match as Match
import qualified Data.List.Key as Key
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import qualified Data.Monoid.HT as Mn
import qualified Data.NonEmpty.Map as NonEmptyMap
import qualified Data.NonEmpty.Mixed as NonEmptyMixed
import qualified Data.NonEmpty.Class as NonEmptyC
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Empty as Empty
import Data.Map (Map, ); import qualified Data.Map as Map
import Data.Set (Set, ); import qualified Data.Set as Set
import Data.Array.Comfort.Boxed (Array, (!))
import Data.NonEmpty ((!:), )
import Data.Biapplicative (biliftA2, )
import Data.Bitraversable (bisequenceA, )
import Data.Traversable (forM, )
import Data.Foldable (forM_, )
import Data.Monoid (mconcat, (<>), )
import Data.Tuple.HT (mapPair, mapFst, mapSnd, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (fromMaybe, mapMaybe, catMaybes, maybeToList, )
import Data.Ord.HT (inRange, comparing, )
import Data.Bool.HT (if', )
import Data.Char (toLower, isDigit, )
import qualified System.Path.PartClass as PathClass
import qualified System.Path.Part as PathPart
import qualified System.Path.Directory as Dir
import qualified System.Path.IO as PathIO
import qualified System.Path as Path
import qualified System.FilePath.Find as Find
import System.FilePath.Find ((==?), (||?), )
import System.Path ((</>), (<.>), )
import Text.Printf (printf, )
import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix
import qualified Numeric.LAPACK.Matrix as Matrix
import qualified Numeric.LAPACK.Vector as Vector
import qualified Algebra.RealRing as Real
import qualified Algebra.Ring as Ring
import NumericPrelude.Numeric
import NumericPrelude.Base hiding (id)
-- * computation
localMaxima :: (Real.C a) => Causal.T a (Maybe a)
localMaxima =
(\(x0,x1,x2) -> toMaybe (x1 >= x0 && x1 >= x2) x1)
^<<
lag2
pruneCloseMaxima :: (Ord a) => Int -> [(Int, a)] -> [(Int, a)]
pruneCloseMaxima dist =
let go (p0@(t0,y0):p1@(t1,y1):ls) =
if t0+dist<=t1
then p0 : go (p1:ls)
else
go $
if y0<=y1
then p1:ls
else p0:ls
go ls = ls
in go
sigCatMaybes :: SigS.T (Maybe a) -> [a]
sigCatMaybes = SigG.foldR (maybe id (:)) []
symDifference :: Int -> SVL.Vector Float -> SVL.Vector Float
symDifference halfDiffDist env =
let pause = SVL.fromChunks [SV.replicate halfDiffDist 0]
in SVL.zipWith (-)
(SVL.drop halfDiffDist env <> pause)
(pause <> env)
causalMaxima :: Float -> Causal.T (Float, Float) (Maybe Float)
causalMaxima minClickAttack =
(\(v,mx) -> do
x <- mx
guard (x > minClickAttack * v)
return (x/v))
^<<
Arrow.second localMaxima
maximaFromEnv ::
Float -> Int ->
SVL.Vector Float -> SVL.Vector Float -> [(Int, Float)]
maximaFromEnv minClickAttack halfDiffDist volume diffEnv =
pruneCloseMaxima (2*halfDiffDist) $ sigCatMaybes $
SigS.zipWith
(\pos mx -> (,) pos <$> mx)
(SigS.iterate (1+) (-1::Int)) $
Causal.apply (causalMaxima minClickAttack) $
SigG.zip
(SigG.toState $ SVL.cons zero volume)
(SigG.toState $ SigG.snoc diffEnv zero)
histogramReal :: (Ord a, Ring.C b) => [(a,b)] -> [(a, b)]
histogramReal = Map.toAscList . Map.fromListWith (+)
histogram :: (Ord a) => [a] -> [(a, Int)]
histogram = histogramReal . map (flip (,) 1)
combFilter ::
Rate.Sample -> Float -> Time -> SVL.Vector Float -> SVL.Vector Float
combFilter rate gain delay =
Comb.run (time rate delay) gain
distancePenalty :: Params.T -> Rate.Sample -> Int -> Float
distancePenalty params rate =
let softLow = time rate $ Time 0.022
softHigh = time rate $ Time 0.034
hardLow = time rate $ Params.hardLowDist params
hardHigh = time rate $ Params.hardHighDist params
interpolate (soft,hard) dist =
fromIntegral (dist-soft) / fromIntegral (hard-soft)
in \dist ->
if' (dist < softLow) (interpolate (softLow,hardLow) dist) $
if' (dist > softHigh) (interpolate (softHigh,hardHigh) dist) 0
updatePenalty :: Params.T -> Rate.Sample -> Int -> Float -> Float -> Maybe Float
updatePenalty params rate dist y penalty = do
let hardLowDist = time rate $ Params.hardLowDist params
let hardHighDist = time rate $ Params.hardHighDist params
guard $ inRange (hardLowDist, hardHighDist) dist
let newPenalty = penalty + max 0 (1-y) + distancePenalty params rate dist
guard $ newPenalty <= 2
return newPenalty
raspingsFromClicksDynProg ::
Params.T -> Rate.Sample -> [(Int, Float)] -> [NonEmpty.T [] Int]
raspingsFromClicksDynProg params rate =
let selectBest = NonEmpty.reverse . fst . NonEmpty.minimumBy (comparing snd)
hardHighDist = time rate $ Params.hardHighDist params
in (\(queue,mxs) ->
catMaybes $ mxs ++ [selectBest <$> NonEmpty.fetch queue]) .
List.mapAccumL
(\bestSoFar (pos, y) ->
case NonEmpty.fetch bestSoFar of
Nothing -> ([(NonEmpty.singleton pos, 0)], Nothing)
Just neBestSoFar ->
let updatedBests =
mapMaybe
(\(chain@(NonEmpty.Cons lastPos _), penalty) ->
(,) (NonEmptyC.cons pos chain) <$>
updatePenalty params rate (pos-lastPos) y penalty) $
NonEmpty.flatten neBestSoFar
in case NonEmpty.fetch updatedBests of
Nothing ->
([(NonEmpty.singleton pos, 0)],
Just $ selectBest neBestSoFar)
Just neUpdatedBests ->
(NonEmpty.minimumBy (comparing snd) neUpdatedBests
:
(filter ((pos - hardHighDist <) . NonEmpty.head . fst) $
map
(\(chain, penalty) -> (chain, penalty+y))
bestSoFar),
Nothing))
[]
raspingsFromClicks :: Rate.Sample -> [(Int, Float)] -> [NonEmpty.T [] Int]
raspingsFromClicks rate maxima =
map
(\xs ->
NonEmpty.cons (fst (NonEmpty.head xs))
(map snd $ NonEmpty.flatten xs)) $
NonEmptyMixed.filterToInfixes
(inRange
(time rate (Time 0.020),
time rate (Time 0.050)) .
uncurry subtract) $
ListHT.mapAdjacent (,) $
map fst maxima
-- * driver
runDehum ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runDehum flags input output =
withSound flags input $ \fmtIn (Signal.Cons rate sig) ->
writeChannels fmtIn rate output $ (:[]) $
Causal.apply
(Bin.fromCanonicalWith Real.roundSimple
^<<
bandpass rate 2 (Freq 2000)
<<^
Bin.toCanonical) $
sig
runDetectAdvertiseSlope ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Params.T -> Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runDetectAdvertiseSlope params flags input output =
withSound flags input $ \fmtIn (Signal.Cons rate xs) ->
let clean = Causal.apply (dehum rate <<^ Bin.toCanonical) xs
volume = lowpassTwoPass rate (Params.volumeFrequency params) clean
env = lowpassTwoPass rate (Params.envelopeFrequency params) clean
halfDiffDist = time rate $ Params.halfDiffDist params
diffEnv = symDifference halfDiffDist env
minClickAttack = Params.minClickAttack params
maxima =
Causal.apply (fromMaybe 0 ^<< causalMaxima minClickAttack) $
SVL.zipWith (,) (SVL.cons zero volume) (SigG.snoc diffEnv zero)
maximaList =
maximaFromEnv minClickAttack halfDiffDist volume diffEnv
outputStem = Path.dropExtension output
in do LabelTrack.writeFileInt rate
(outputStem <-> "ticks-labels.txt") $
LabelTrack.Cons $
ListHT.mapAdjacent
(\(from,y) (to,_) -> ((from, to), show y)) maximaList
LabelTrack.writeFileInt rate
(outputStem <-> "rasping-labels.txt") $
LabelTrack.Cons $
map
(\sequ ->
((NonEmpty.head sequ, NonEmpty.last sequ),
printf "%d ticks" $ length $ NonEmpty.tail sequ)) $
raspingsFromClicksDynProg params rate maximaList
void $ GP.plotDefault $
Plot2D.list Graph2D.points $ histogram $
ListHT.mapAdjacent subtract $
map fst maximaList
void $ GP.plotDefault $
Plot2D.list Graph2D.points $ histogramReal $
ListHT.mapAdjacent
(\(from,y) (to,_) -> (to-from, y)) maximaList
writeChannels fmtIn rate output $
map (SVL.map (Bin.fromCanonicalWith Real.roundSimple)) $
[diffEnv, SVL.drop 1 maxima]
averageSignals ::
NonEmpty.T [] (SV.Vector Float, SV.Vector Float) -> SV.Vector Float
averageSignals xs =
let sumAll = NonEmpty.foldl1 (SV.zipWith (+))
(vols, sigs) = FuncHT.unzip xs
in SV.zipWith (/) (sumAll sigs) (sumAll vols)
averageSignalsMinLength ::
Int -> [(SV.Vector Float, SV.Vector Float)] -> SV.Vector Float
averageSignalsMinLength minLen xs =
Fold.foldMap averageSignals $ NonEmpty.fetch $
filter ((>=minLen) . SV.length . snd) xs
runExtractPatterns ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Params.T -> Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runExtractPatterns params flags input output =
withSound flags input $ \fmtIn (Signal.Cons rate xs) -> do
(chunkSizes, labels) <-
fmap (unzip . Fold.toList .
LabelChain.intervalSizes . fmap Class.fromLabel . Signal.body) $
userErrorFromExc . LabelTrack.discretizeTrack rate =<<
LabelTrack.readFile (Path.dropExtension input <-> "coarse.txt")
let (outputStem, outputExt) = Path.splitExtensions output
let clean = Causal.apply (dehum rate <<^ Bin.toCanonical) xs
cleanAbs = SVL.map abs clean
volume = lowpassTwoPass rate (Params.volumeFrequency params) cleanAbs
env = lowpassTwoPass rate (Params.envelopeFrequency params) cleanAbs
halfDiffDist = time rate $ Params.halfDiffDist params
diffEnv = symDifference halfDiffDist env
let raspingChunks =
catMaybes $
zipWith (\lab chunk -> chunk <$ Class.maybeRasping lab) labels $
zip (SP.chop clean chunkSizes) $
zip (SP.chop volume chunkSizes) (SP.chop diffEnv chunkSizes)
starts = scanl (+) 0 $ map (SVL.length . fst) raspingChunks
maximaList = maximaFromEnv (Params.minClickAttack params) halfDiffDist
raspingClicks = map (uncurry maximaList . snd) raspingChunks
clickLength = time rate $ Params.minClickDur params
takeClick pos =
SV.concat . SVL.chunks . SVL.take clickLength . SVL.drop pos
avg =
SV.map (0.25*) $
averageSignalsMinLength clickLength $
concat $
zipWith
(\(sig,(vol,_)) ->
map (\(pos, _) -> (takeClick pos vol, takeClick pos sig)))
raspingChunks raspingClicks
clickLabels =
mconcat $
zipWith LabelTrack.shift starts $
map
(LabelTrack.Cons .
ListHT.mapAdjacent (\(from,x) (to,_) -> ((from,to), x)))
raspingClicks
writeChannels fmtIn rate output $
map (SVL.map (Bin.fromCanonicalWith Real.roundSimple)) $
[SVL.concat $ map fst raspingChunks,
SVL.concat $ map (fst.snd) raspingChunks,
SVL.concat $ map (snd.snd) raspingChunks]
writeChannels fmtIn rate (outputStem <-> "click" <.> outputExt) $
[SVL.map (Bin.fromCanonicalWith Real.roundSimple) $
SVL.fromChunks [avg]]
writeChannels fmtIn rate (outputStem <-> "clicks" <.> outputExt) $
[SVL.map (Bin.fromCanonicalWith Real.roundSimple) $
SVL.fromChunks $ replicate 20 avg]
LabelTrack.writeFileInt rate (outputStem <-> "clicks.txt") $
fmap show clickLabels
runMatchPatterns ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1, PathClass.AbsRel ar2) =>
Path.FilePath ar0 -> Params.T -> Flags ->
Path.FilePath ar1 -> Path.FilePath ar2 -> IO ()
runMatchPatterns patternPath params flags input output =
withSound flags patternPath $ \ _fmtPat (Signal.Cons ratePat ys) ->
withSound flags input $ \fmtIn (Signal.Cons rate xs) -> do
when (ratePat /= rate) $ ioError $ userError $
printf "rate of pattern (%f) and signal differ (%f)"
(Rate.unpack ratePat) (Rate.unpack rate)
let fac = 0.3 / (SigG.sum $ SVL.map (abs . Bin.toCanonical) ys)
clean = Causal.apply (dehum rate <<^ Bin.toCanonical) xs
volume =
lowpassTwoPass rate (Params.volumeFrequency params) $
SVL.map abs clean
writeChannels fmtIn rate output $
[SVL.fromChunks $ (:[]) $
SV.map (Bin.fromCanonicalWith Real.roundSimple) $
Fourier.correlate
(svlConcat $ SVL.map ((fac*) . Bin.toCanonical) ys)
(svlConcat $ SVL.zipWith (/) clean volume)]
newtype PlotProcess = PlotProcess (MVar.Out ())
waitPlot :: PlotProcess -> IO ()
waitPlot (PlotProcess mvarOut) = MVar.take mvarOut
waitPlots :: [PlotProcess] -> IO ()
waitPlots = mapM_ waitPlot
plotStateEmissions ::
String -> Array HMM.ShapeState String ->
String -> [(HMM.State, (Float, Float))] -> IO PlotProcess
plotStateEmissions title dict subTitle ps = do
(mvarIn, mvarOut) <- MVar.newEmpty
let header = title ++ ": " ++ subTitle
void $ forkIO $ plotStateEmissionsSync dict header ps >> MVar.put mvarIn ()
return $ PlotProcess mvarOut
plotStateEmissionsSync ::
Array HMM.ShapeState String ->
String -> [(HMM.State, (Float, Float))] -> IO ()
plotStateEmissionsSync dict title ps =
void $ GP.plotSync DefaultTerm.cons $
Frame.cons (Opts.title title Opts.deflt) $
Fold.foldMap
(\(state, emissions) ->
Graph2D.lineSpec (LineSpec.title (dict!state) LineSpec.deflt) <$>
Plot2D.list Graph2D.points emissions) $
Array.toAssociations $
Array.accumulate (flip (:)) ([] <$ dict) ps
emissionPairs :: [Named.Signal] -> [(String, [(Float, Float)])]
emissionPairs =
map
(\(NonEmpty.Cons (Named.Cons n xs)
(NonEmpty.Cons (Named.Cons m ys) Empty.Cons)) ->
(m ++ " vs. " ++ n, zip ys xs)) .
NonEmptyMixed.choose . map (fmap SVL.unpack)
plotStateEmissionsSingle ::
Bool -> String ->
Array HMM.ShapeState String ->
[(String, [(Float, Float)])] ->
[HMM.State] -> IO [PlotProcess]
plotStateEmissionsSingle plot title labelFromStateMap featPoints labelled =
guardPlot plot $
forM featPoints $ \(n,xs) ->
plotStateEmissions title labelFromStateMap n $ zip labelled xs
plotStateEmissionsMulti ::
(Functor map, Fold.Foldable map) =>
Bool -> String ->
Map String HMM.State ->
Array HMM.ShapeState String ->
map ([Named.NonEmptySignal], LabelChain.T Int String) ->
IO [PlotProcess]
plotStateEmissionsMulti plot title stateFromLabelMap labelFromStateMap =
guardPlot plot . Trav.sequence . Map.elems .
Map.mapWithKey (plotStateEmissions title labelFromStateMap) .
Fold.foldr1 (Map.unionWith (++)) .
fmap
(\(featSigs, intervals) ->
fmap (zip (HMM.flattenIntervals stateFromLabelMap intervals)) $
Map.fromList $ emissionPairs $
map (fmap HMM.flattenStorableVectorLazy) featSigs)
checkAdmissibilityTrans ::
(PathClass.AbsRel ar) =>
Set (String, String) -> Array HMM.ShapeState String ->
Path.FilePath ar -> HMM.GaussianTrained -> IO ()
checkAdmissibilityTrans
admissibleTransitions labelFromStateMap path hmmTrained = do
let forbiddenTransitions =
HMM.forbiddenTransitions admissibleTransitions
labelFromStateMap hmmTrained
when (not $ Set.null forbiddenTransitions) $
ioError $ userError $ unlines $
printf "detected forbidden transitions in %s:" (Path.toString path) :
map (\(from,to) -> printf "%s -> %s" from to)
(Set.toList forbiddenTransitions)
checkEmptyIntervals ::
(PathClass.AbsRel ar) =>
Rate.Feature -> Path.FilePath ar -> LabelChain.T Int String -> IO ()
checkEmptyIntervals rate path intervals = do
let emptyIntervals =
filter (uncurry (==) . fst) $
LabelTrack.decons $ LabelTrack.fromLabelChain intervals
when (not $ null emptyIntervals) $
ioError $ userError $ unlines $
printf "empty intervals found in %s:" (Path.toString path) :
map
(\((from,_to), label) ->
printf "%f: %s" (Params.toTime rate from) label)
emptyIntervals
printLabelCounts :: Map String HMM.State -> [(String, Int)] -> IO ()
printLabelCounts stateFromLabelMap labelCounts =
forM_ labelCounts $ \(label,count) -> do
printf "%003d %s\t%5d\n"
(case stateFromLabelMap Map.! label of HMM.State s -> s)
label count
{-
We only consider the difference of the transition matrix.
HMM0.deviation is too pessimistic
because it also compares initial probabilities
and these are based on little data, namely one number per audio file.
-}
printModelDifference :: HMM.Gaussian -> HMM.Gaussian -> IO ()
printModelDifference hmmSup hmmUnsup =
void $ printf "difference between supervised and unsupervised: %f\n" $
Vector.normInf $ ArrMatrix.toVector $
Matrix.sub (HMM0.transition hmmSup) (HMM0.transition hmmUnsup)
supervisedName, hmmSupervisedName :: String
unsupervisedName, hmmUnsupervisedName :: String
supervisedName = "supervised"
hmmSupervisedName = "hmm-supervised.csv"
unsupervisedName = "unsupervised"
hmmUnsupervisedName = "hmm-unsupervised.csv"
writeMLPackEmissions ::
(PathClass.AbsRel ar) =>
Path.FilePath ar -> [Named.T (SVL.Vector Float)] -> IO ()
writeMLPackEmissions outputStem featSigs =
PathIO.writeFile (outputStem <-> "mlpack-emissions.csv") $ unlines $
map (List.intercalate "," . map show) $
List.transpose $ map (SVL.unpack . Named.body) featSigs
writeMLPackStates ::
(PathClass.AbsRel ar) =>
Path.FilePath ar -> String -> [HMM.State] -> IO ()
writeMLPackStates outputStem part =
PathIO.writeFile (outputStem <-> "mlpack" <-> part <.> "csv") . unlines .
map (\(HMM.State s) -> show s)
userErrorFromExc :: ME.Exceptional String a -> IO a
userErrorFromExc =
ME.switch (ioError . userError) return
collectExceptions :: [ME.Exceptional e a] -> ME.Exceptional [e] [a]
collectExceptions =
(\(es,as) -> if List.null es then ME.Success as else ME.throw es) .
ListHT.unzipEithers . map (ME.switch Left Right)
guardPlot :: Bool -> IO [a] -> IO [a]
guardPlot plot act = if plot then act else return []
featureSignals ::
(PathClass.AbsRel ar) =>
SPMethods.T -> Feature.Class ->
Path.FilePath ar -> Signal.Sox ->
IO (Signal.T Rate.Feature [Named.Signal], [Named.NonEmptySignal])
featureSignals sigProc feature input sig = do
let featSigs = Feature.signals feature sigProc sig
featSigsNE <-
userErrorFromExc $ mapM (HMM.checkNonEmpty input) $ Signal.body featSigs
return (featSigs, featSigsNE)
hmmTrainings ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Flags -> TrainingFlags ->
Path.FilePath ar0 ->
SoxLib.Format mode ->
Signal.Sox ->
LabelChain.T Int String ->
Path.FilePath ar1 ->
(Signal.T Rate.Feature [Named.Signal], [Named.NonEmptySignal]) -> IO ()
hmmTrainings flags (TrainingFlags _sigProc feature cvg mlpack plot)
input fmtIn sig intervals
output (rateFeatSigs@(Signal.Cons rate featSigs), featSigsNE) = do
let outputStem = Path.dropExtension output
featureTracksSum <-
writeFeatureTracks fmtIn output (Feature.scale feature) rateFeatSigs
checkEmptyIntervals rate outputStem intervals
when mlpack $ writeMLPackEmissions outputStem featSigs
let labelCounts = histogram $ Fold.toList intervals
(stateFromLabelMap, labelFromStateMap) =
HMM.mapsFromLabels $ map fst labelCounts
Option.infoAction flags $ do
putStrLn "encountered labels with assigned state number and frequency"
printLabelCounts stateFromLabelMap labelCounts
let states = HMM.flattenIntervals stateFromLabelMap intervals
when mlpack $ writeMLPackStates outputStem "states" states
let featPoints = emissionPairs featSigs
waits0 <-
plotStateEmissionsSingle plot supervisedName
labelFromStateMap featPoints states
hmmTrained <-
userErrorFromExc $
HMM.trainSupervised stateFromLabelMap input featSigsNE intervals
checkAdmissibilityTrans (Feature.admissibleTransitions feature)
labelFromStateMap outputStem hmmTrained
Option.notice flags "supervised training"
let hmm = HMM0.finishTraining hmmTrained
addNames model =
Feature.HMM {
Feature.hmmClass = feature,
Feature.hmmodel =
HMMNamed.Cons {
HMMNamed.model = model,
HMMNamed.nameFromStateMap = labelFromStateMap,
HMMNamed.stateFromNameMap = stateFromLabelMap
}
}
Feature.writeHMM (outputStem <-> hmmSupervisedName) $ addNames hmm
Option.infoMsg flags $ HMM0.toCSV hmm
Option.notice flags "classify using trained model"
let newIntervals = HMM.label hmm featSigsNE
supervisedTrack <-
writeLabelTrackInt rate outputStem supervisedName $
fmap (labelFromStateMap!) $ LabelChain.segment newIntervals
when mlpack $ writeMLPackStates outputStem "classified" newIntervals
Option.notice flags "unsupervised training"
let prep = HMM.prepare featSigsNE
step model = HMM0.finishTraining $ HMM0.trainUnsupervised model prep
hmms = HMM.takeUntilConvergence cvg $ iterate step hmm
lastHMM = last hmms
lastFeatureHMM = addNames lastHMM
mapM_ (Option.infoMsg flags . HMM0.toCSV) hmms
Option.noticeAction flags $ printModelDifference hmm lastHMM
Option.notice flags "classify using trained model"
Feature.writeHMM (outputStem <-> hmmUnsupervisedName) lastFeatureHMM
let labelledUnsupervised =
HMM.analyze (Feature.hmmodel lastFeatureHMM) featSigsNE
waits1 <-
plotStateEmissionsSingle
plot unsupervisedName labelFromStateMap featPoints $
HMM.flattenIntervals stateFromLabelMap labelledUnsupervised
unsupervisedTrack <-
writeLabelTrackInt rate outputStem unsupervisedName labelledUnsupervised
((audPath, audFormat), (inputTrack, featSigTracks)) <-
waveSummaryEval outputStem $
liftM2 (,) (projectWaveTrackInput (sig, input)) featureTracksSum
PathIO.writeFile audPath $ audFormat $
createProject (zoomFullSignal sig) $
inputTrack :
featSigTracks ++
projectLabelChain "fine" (LabelChain.realTimes rate intervals) :
supervisedTrack :
unsupervisedTrack :
[]
waitPlots $ waits0 ++ waits1
runHMMTrainingUnsupervised ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Flags -> TrainingFlags -> Int ->
Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runHMMTrainingUnsupervised
flags (TrainingFlags sigProc feature cvg mlpack plot) numStates
input output =
withSound flags input $ \fmtIn sig -> do
(rateFeatSigs@(Signal.Cons featRate featSigs), featSigsNE) <-
featureSignals sigProc feature input sig
let outputStem = Path.dropExtension output
featureTracksSum <-
writeFeatureTracks fmtIn output (Feature.scale feature) rateFeatSigs
when mlpack $ writeMLPackEmissions outputStem featSigs
Option.notice flags "train HMM"
let prep = HMM.prepare featSigsNE
step model =
HMM0.finishTraining $
HMM0.trainUnsupervised model prep
states = HMM.state 0 !: take (numStates-1) [HMM.state 1 ..]
statesShape = HMM.statesShape numStates
hmms =
HMM.takeUntilConvergence cvg $ iterate step $
HMM0.uniform $ HMM0.distribution $ HMM0.finishTraining $
HMM0.trainSupervised statesShape $
NonEmptyC.zip (NonEmpty.cycle states) prep
hmm = last hmms
labelFromStateMap =
Array.fromList statesShape $ map (show . fromEnum) $
NonEmpty.flatten states
addNames model =
Feature.HMM {
Feature.hmmClass = feature,
Feature.hmmodel =
HMMNamed.Cons {
HMMNamed.model = model,
HMMNamed.nameFromStateMap = labelFromStateMap,
HMMNamed.stateFromNameMap =
HMM.inverseMap labelFromStateMap
}
}
mapM_ (Option.infoMsg flags . HMM0.toCSV) hmms
Feature.writeHMM (outputStem <-> hmmUnsupervisedName) $ addNames hmm
Option.notice flags "classify using trained model"
let labelled = HMM.label hmm featSigsNE
unsupervisedTrack <-
writeLabelTrackInt featRate outputStem unsupervisedName $
(\(HMM.State s) -> show s) <$> LabelChain.segment labelled
when mlpack $ writeMLPackStates outputStem "classified" labelled
((audPath, audFormat), (inputTrack, featSigTracks)) <-
waveSummaryEval outputStem $
liftM2 (,) (projectWaveTrackInput (sig, input)) featureTracksSum
PathIO.writeFile audPath $ audFormat $
createProject (zoomFullSignal sig) $
inputTrack :
featSigTracks ++
unsupervisedTrack :
[]
waitPlots =<<
plotStateEmissionsSingle plot unsupervisedName
labelFromStateMap (emissionPairs featSigs) labelled
textWriteFile ::
(PathClass.AbsRel ar) =>
Path.FilePath ar -> Text -> IO ()
textWriteFile = TextIO.writeFile . Path.toString
type
DetectionParams =
(SPMethods.T, Feature.HMM, (Format.Flags, Bool), Params.T, Flags)
runDetectHMM ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
DetectionParams -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runDetectHMM dp@(_,_,_,_,flags) input output =
withSound flags input $ \fmtIn sig ->
let startTime = Time.parseRecordingName $ Path.takeBaseName input
in void $ runDetectHMMMain dp id startTime fmtIn sig input output
type
GlobalLabelTracks =
NonEmpty.T (NonEmpty.T (NonEmpty.T Maybe)) (LabelTrack.T Double String)
runDetectHMMMain ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
DetectionParams ->
(IO () -> IO ()) ->
Maybe LocalTime ->
SoxLib.Format mode -> Signal.Sox ->
Path.FilePath ar0 -> Path.FilePath ar1 ->
IO ((Map String Int, Results),
(Signal.T Rate.Sample [ProjectWaveSummary.T], GlobalLabelTracks))
runDetectHMMMain (sigProc, featureHMM, (fmtFlags, emitTrack), params, flags)
emit startTime fmtIn sig@(Signal.Cons highRate xs) input output = do
let feature = Feature.hmmClass featureHMM
(featSigs@(Signal.Cons featRate _), featSigsNE) <-
featureSignals sigProc feature input sig
let (outputStem, outputExt) = Path.splitExtensions output
outputEnv = outputStem <-> "env" <.> outputExt
hmmNamed = Feature.hmmodel featureHMM
{-
We need to quantize the label boundaries to the sampling grid
for the following reasons:
1. We need to quantize for perfect reconstruction
of label boundaries in the measurement process.
2. The sample period is the only quantization unit
that is still available in the measurement process,
whereas the feature rate is no longer accessible then.
If we leave the label boundaries at the feature rate positions
then it happens occasionally,
that a 0.5 time value is rounded to 0 at classification
and later when read back from the audacity project
and shifted according to the beginning of the recording part
it becomes 0.50000001 and is rounded to 1.
Rounding to multiples of the sampling period means
that time values like 0.5 cannot occur at all.
-}
sigIntervals =
fmap (mapSnd (LabelChain.adjustLength (CutG.length xs))) $
Signal.addDiscretizedLabels sig $
Signal.labelRealTimes $ Signal.Cons featRate $
HMM.analyze hmmNamed featSigsNE
(classified, warningIntervals,
(measures, (envelopeScales, envelope))) =
Feature.evaluateFromIntervals feature sigProc params sigIntervals
classifiedAbstractly =
LabelChain.abstractFromSoundClassIntervals classified
classifiedTrack = LabelTrack.fromLabelChain classified
classifiedAbstractlyTrack =
LabelTrack.fromLabelChain classifiedAbstractly
maybeAbsTimeLabels =
LabelTrack.fromLabelChain .
Time.timeLabels (Signal.duration sig) . LocalTime.localTimeOfDay
<$> startTime
maybeHours =
LabelChain.takeTime (Signal.duration sig) . Time.hours <$> startTime
maybeHourLabels =
LabelTrack.fromLabelChain .
fmap (Time.formatHour "%Y-%m-%d %H") <$> maybeHours
durationsHourly =
flip fmap maybeHours $ \hours ->
fmap Durs.sum $ Map.fromList $
LabelChainShifted.chopChain hours $
LabelChainShifted.fromLabelChain classifiedAbstractly
do
when emitTrack $ do
let labelsWriteFile part =
emit . LabelTrack.writeFile (outputStem <-> part <.> "txt")
labelsWriteFile "hmm-labels" $!!
LabelTrack.fromLabelChain $
Signal.labelRealTimes $ fmap snd sigIntervals
labelsWriteFile "hmm-labels-coarse" $!!
fmap Class.toLabel classifiedTrack
labelsWriteFile "hmm-labels-abstract" $!!
fmap Class.abstractToLabel classifiedAbstractlyTrack
labelsWriteFile "warnings" $!! warningIntervals
Fold.mapM_ (labelsWriteFile "abstimes") $!! maybeAbsTimeLabels
do
inputAbs <- Path.genericMakeAbsoluteFromCwd input
let (results, tableFiles) =
MW.runWriter $
formatTables fmtFlags highRate inputAbs outputStem measures
mapM_ (emit . uncurry textWriteFile $!!) tableFiles
let emitFeatures ::
(PathClass.AbsRel ar, Rate.C rate, MonadIO m) =>
Path.File ar -> [Float] -> Signal.T rate [Named.Signal] ->
IO (ProjectWaveSummary.Monad m [Audacity.Track])
emitFeatures path scales sigs = do
emit . writeFeatures fmtIn path scales $!! sigs
return $ projectWaveTrackFeatures ((scales, sigs), path)
sigProj <- emitFeatures output (Feature.scale feature) featSigs
envelopeProj <- emitFeatures outputEnv envelopeScales envelope
let inputSummary = Signal.map (summary . SVL.map Bin.toCanonical) sig
do
((audPath, audFormat),
(inputTrack, featSigTracks, envelopeTracks)) <-
waveSummaryEval outputStem $
liftM3 (,,)
(projectWaveTrackInputSummary (inputSummary, inputAbs))
sigProj envelopeProj
emit . textWriteFile audPath $!!
Text.pack $ audFormat $
createProject (zoomFullSignal sig) $
inputTrack :
featSigTracks ++
envelopeTracks ++
projectLabelTrack TrackName.coarse
(fmap Class.toLabel classifiedTrack) :
projectLabelTrack TrackName.abstract
(fmap Class.abstractToLabel classifiedAbstractlyTrack) :
projectLabelTrack TrackName.warnings warningIntervals :
maybeToList
(projectLabelTrack TrackName.time <$>
maybeAbsTimeLabels) ++
maybeToList
(projectLabelTrack TrackName.hour <$>
maybeHourLabels) ++
[]
Option.infoAction flags $
emit . putStrLn $!!
("update HMM\n" ++) $
HMM0.toCSV $ HMM0.finishTraining $
HMM0.trainUnsupervised (HMMNamed.model hmmNamed) $
HMM.prepare featSigsNE
return
((Class.countOthers classified,
(Durs.sum classifiedAbstractly,
Fold.fold durationsHourly, results)),
(inputSummary,
fmap Class.toLabel classifiedTrack !:
fmap Class.abstractToLabel classifiedAbstractlyTrack !:
warningIntervals !:
maybeHourLabels))
isSeparator :: Char -> Bool
isSeparator = flip elem ['-', ' ']
numericPattern ::
(PathClass.FileDir fd) => Path.Rel fd -> [Either Integer String]
numericPattern =
let go [] = []
go (x:xs) =
let b = isDigit x
(ys,zs) = mapFst (x:) $ span ((b==) . isDigit) xs
in (if b
then Left $ read ys
else Right $ filter (not . isSeparator) ys)
: go zs
in go . Path.toString
type Sort a = [(Path.RelDir, a)] -> IO [(Int, (Path.RelDir, a))]
readCustomOrder :: (PathClass.AbsRel ar) => Path.FilePath ar -> IO (Sort a)
readCustomOrder path = do
content <- PathIO.readFile path
let dict = Map.fromList $ flip zip [0..] $ lines content
return $ \pairs ->
fmap (List.sortBy (comparing fst)) $
forM pairs $ \pair@(name,_) ->
case Map.lookup (Path.toString name) dict of
Just pos -> return (pos, pair)
Nothing ->
ioError $ userError $
printf "directory name \"%s\" not found in \"%s\""
(Path.toString name) (Path.toString path)
getDirectoryContents ::
(PathClass.AbsRel ar, PathClass.FileDir fd) =>
Path.DirPath ar -> IO [Path.Rel fd]
getDirectoryContents =
fmap (List.sort . mapMaybe Path.fromFileDir) . Dir.getDirectoryContents
infixr 9 +~+
(+~+) :: String -> String -> String
xs +~+ ys = xs ++ ' ' : ys
getDirectoryErrorMsg :: IOErr.IOError -> Maybe String
getDirectoryErrorMsg e =
toMaybe
(case IOErr.ioeGetErrorType e of
GHCExc.InappropriateType -> True
GHCExc.InvalidArgument -> True
_ -> False)
(unlines $
"Tried to read directory content, but it is not a directory." :
"There could be several reasons:" :
"There are additional files in the directory tree" +~+
"not belonging to the project." :
"You did not use the project main directory as input," +~+
"but a sub-directory." :
"You did not give a project directory at all," +~+
"but e.g. swapped input and output directory." :
[])
getDirectoryContentsFull ::
(PathClass.AbsRel ar, PathClass.FileDir fd) =>
Path.DirPath ar -> IO [(Path.Rel fd, Path.Path ar fd)]
getDirectoryContentsFull dir =
IOErr.modifyIOError
(\e ->
maybe e (\msg -> e{GHCExc.ioe_description = msg}) $
getDirectoryErrorMsg e) $
map (\entry -> (entry, dir</>entry)) <$> getDirectoryContents dir
runDetectHMMThread ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
DetectionParams -> Sequence.In ->
Maybe LocalTime ->
Path.FilePath ar0 -> Path.FilePath ar1 ->
IO ((Map String Int, Results),
(Signal.T Rate.Sample [ProjectWaveSummary.T], GlobalLabelTracks))
runDetectHMMThread dp@(_,_,_,_,flags) seqIn startTime input output = do
(fmtIn, sig) <-
Sequence.sync seqIn $
withSound flags input $
\fmtIn sig -> return . (,) fmtIn $!! sig
Sequence.sync seqIn . return =<<
runDetectHMMMain dp (Sequence.async seqIn)
startTime fmtIn sig input output
matchFileName :: [String] -> Path.FilePath ar -> Bool
matchFileName exts caseName =
let name = map toLower $ Path.toString $ Path.takeFileName caseName
in any (flip List.isSuffixOf name) exts
matchWaveName :: Path.FilePath ar -> Bool
matchWaveName = matchFileName [".wav", ".flac"]
matchLogName :: Path.FilePath ar -> Bool
matchLogName = matchFileName [".log"]
getStartTimes ::
(PathClass.AbsRel ar, PathClass.AbsRel ar0) =>
Flags -> Path.DirPath ar0 ->
[(Path.RelFile, Path.FilePath ar)] ->
IO [(Maybe LocalTime, (Path.RelFile, Path.FilePath ar))]
getStartTimes flags dir files = do
let (logFiles, otherFiles) = List.partition (matchLogName . fst) files
let fmtPath path = Path.toString path
case logFiles of
[] -> do
Option.warn flags $
printf "\n%s: Log file not found\n" $ fmtPath dir
return $
map
(\file2 ->
let startTime = Time.parseRecordingName $ fst file2
in (startTime, file2)) $
filter (matchWaveName . fst) otherFiles
[(_,logFile)] -> do
(unparseable, entries) <-
ListHT.unzipEithers . Time.parseLog <$> PathIO.readFile logFile
when (not $ null unparseable) $
Option.warn flags $ unlines $
printf "\n%s:1: Found ill-formated lines:" (fmtPath logFile) :
unparseable
let (recordings, clashing) =
clashingMapFromList $
flip mapMaybe entries $ \(startTime,e) ->
case e of
Time.Recording name _ ->
Just (Path.dropExtension name, startTime)
_ -> Nothing
let formatTime =
TimeFormat.formatTime TimeFormat.defaultTimeLocale
"%Y-%m-%d %H:%M:%S"
checkClash "logged recordings with the same name stem:" $
Map.map (fmap formatTime) clashing
let (otherFileMap, otherClashing) =
clashingMapFromList $
map (\file2 -> (Path.dropExtension $ fst file2, file2))
otherFiles
checkClash "found file name with the same name stem:" $
Map.map (Path.toString . fst <$>) otherClashing
let missing = Map.difference recordings otherFileMap
in when (not $ Map.null missing) $
Option.warn flags $ unlines $
printf
"\n%s:1: Listed recordings without actual audio files:"
(fmtPath logFile) :
map Path.toString (Map.keys missing)
let missing = Map.difference otherFileMap recordings
in when False $
when (not $ Map.null missing) $
Option.warn flags $ unlines $
printf
"\n%s:1: Found files that are not registered in the log file:"
(fmtPath logFile) :
map (Path.toString . snd) (Map.elems missing)
return $ Map.elems $
Map.intersectionWith (,) (fmap Just recordings) otherFileMap
_ ->
ioError $ userError $ unlines $
printf "\n%s: Found multiple log files:" (fmtPath dir) :
map (Path.toString . fst) logFiles
parallelRun :: (NFData a) => (Sequence.In -> [IO a]) -> IO [a]
parallelRun acts = do
(seqIn, seqOut) <- Sequence.new
void $ forkIO $ Sequence.run seqOut
numCap <- getNumCapabilities
Parallel.runLimited (max 1 $ numCap-1) $
Trav.traverse Parallel.fork $ acts seqIn
{- |
Consider namings like this one:
> Ko1 VIN
> Ko2 VIN
> Ko3 VIN
> VIN 10-10M - 1
> VIN 10-10M - 2
> VIN 10-10M - 3
-}
takeTreatmentName :: String -> String
takeTreatmentName str =
let (revSuffix, revPrefix) = break isDigit $ reverse str
in (reverse . dropWhile isSeparator . dropWhile isDigit $ revPrefix) ++
case dropWhile isSeparator . reverse $ revSuffix of
"" -> ""
suffix -> " " ++ suffix
fmapDeep :: (Monad m, NFData b) => (a -> b) -> m a -> m b
fmapDeep f act = (return $!!) . f =<< act
forAnimals ::
(PathClass.AbsRel ar, PathClass.AbsRel ar1) =>
Format.AllPaths ar -> Path.AbsDir -> Path.RelDir ->
[(Int, (Path.RelDir, Path.Path ar1 fd))] ->
((Path.RelDir, Path.Path ar1 fd) ->
IO [(Path.RelFile, (Map String Int, Results))]) ->
IO (Map String Int)
forAnimals overviewPaths inputAbs dir0 dirs1 act = do
let treatments =
NonEmptyMixed.groupKey
(takeTreatmentName . Path.toString . fst . snd) dirs1
fmapDeep (Map.unionsWith (+)) $
forM treatments $ \(treatment, animals) -> do
totalDursResultss <-
forM (NonEmpty.flatten animals)
(\(animal, (dir1,fullDir1)) -> do
totalDursResults <- act (dir1,fullDir1)
Format.appendOverview overviewPaths
inputAbs dir0 dir1 animal $
map (mapSnd snd) totalDursResults
return totalDursResults)
Format.appendTreatmentOverview overviewPaths inputAbs dir0 treatment $
map (map (mapSnd snd)) totalDursResultss
return $!!
Map.unionsWith (+) $ concatMap (map (fst . snd)) totalDursResultss
reportIgnoredIntervals :: Flags -> [Map String Int] -> IO ()
reportIgnoredIntervals flags countss =
($ Map.unionsWith (+) countss) $ \counts ->
when (not $ Map.null counts) $
Option.warn flags $ unlines $
"" : "Ignored interval labels:" :
Map.elems (Map.mapWithKey (printf "%s: %d times") counts)
withOverviewPaths ::
(PathClass.AbsRel ar) =>
Format.Flags -> Path.DirPath ar -> (Format.AllPaths ar -> IO a) -> IO a
withOverviewPaths fmtFlags output act = do
Dir.createDirectoryIfMissing True output
bracket
(Format.writeOverviewHead fmtFlags output) Format.writeOverviewFoot act
runDetectHMMMulti ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Sort (Path.DirPath ar0) -> DetectionParams ->
Path.DirPath ar0 -> Path.DirPath ar1 -> IO ()
runDetectHMMMulti sort dp@(_,_,fmtFlags,_,flags) input output =
withOverviewPaths (fst fmtFlags) output $ \overviewPaths -> do
dirs0 <- getDirectoryContentsFull input
inputAbs <- Path.genericMakeAbsoluteFromCwd input
(reportIgnoredIntervals flags =<<) $
forM (Key.sort (numericPattern . fst) dirs0) $ \(dir0,fullDir0) -> do
dirs1 <- sort =<< getDirectoryContentsFull fullDir0
forAnimals overviewPaths inputAbs dir0 dirs1 $ \(dir1,fullDir1) -> do
{-
Retrieve directory content first,
in order to make sure that it is really a directory.
-}
files <-
getStartTimes flags fullDir1 =<< getDirectoryContentsFull fullDir1
let outDir = output </> dir0 </> dir1
Dir.createDirectoryIfMissing True outDir
(totalDursResults, sigs) <-
fmap unzip $
parallelRun $ \seqIn ->
map
(\(startTime, (file, fullFile)) ->
mapPair ((,) file, (,) fullFile) <$>
runDetectHMMThread dp seqIn
startTime fullFile (outDir </> file)) $
files
let outputStem =
fromMaybe (error "outDir: empty path") $ Path.fileFromDir outDir
((audPath, audFormat),
(totalDur, inputTrack, labelTrack, originTrack)) <-
waveSummaryEval outputStem $
projectWaveTrackConcat
(TrackName.classes !: TrackName.abstract !: TrackName.warnings !:
Just TrackName.hour) $
sigs
PathIO.writeFile audPath $ audFormat $
createProject (zoomWidth / totalDur) $
inputTrack :
Fold.toList labelTrack ++
originTrack :
[]
return totalDursResults
runMeasureMain ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
SPMethods.T -> (Format.Flags, Bool) -> Params.T ->
(IO () -> IO ()) ->
LabelChain.T Double Time.Hour ->
LabelChain.T Double (Class.Sound clicks chirping ticking clicks) ->
SoxLib.Format mode ->
Signal.Sox ->
Path.FilePath ar0 -> Path.FilePath ar1 ->
IO (Map String Int, Results)
runMeasureMain sigProc (fmtFlags, emitTrack) params emit hours classified fmtIn
sig@(Signal.Cons highRate _) input output =
let (outputStem, outputExt) = Path.splitExtensions output
outputEnv = outputStem <-> "env" <.> outputExt
{-
We must discretize 'classified' in order to eliminate rounding errors
from parsing decimal time values
and from dissection of concatenated label tracks.
-}
sigClassified = Signal.addDiscretizedLabels sig classified
(measures, (envelopeScales, envelope)) =
snd $ measureSignal sigProc params sigClassified
classifiedAbstractly =
LabelChain.abstractFromSoundClassIntervals $
Signal.labelRealTimes $ fmap snd sigClassified
(results, tableFiles) =
MW.runWriter $
formatTables fmtFlags highRate input outputStem measures
durationsHourly =
Map.fromListWith (liftA2 (+)) $
map (mapSnd Durs.sum) $
LabelChainShifted.chopChain hours $
LabelChainShifted.fromLabelChain classifiedAbstractly
in do
when emitTrack $
emit . writeFeatures fmtIn outputEnv envelopeScales $!! envelope
mapM_ (emit . uncurry textWriteFile $!!) tableFiles
return
(Class.countOthers classified,
(Durs.sum classifiedAbstractly, durationsHourly, results))
whenDirectory ::
(PathClass.AbsRel ar) => a -> Path.DirPath ar -> IO a -> IO a
whenDirectory deflt dir act =
Dir.doesDirectoryExist dir >>= \b -> if b then act else return deflt
readConcatAudacityProject ::
PathClass.AbsRel ar =>
Params.T ->
Path.FilePath ar ->
IO (LabelChain.T Double
(OriginPaths PathPart.AbsRel,
(LabelChain.T Double Time.Hour,
LabelChain.T Double Class.SoundParsed)))
readConcatAudacityProject params fullAup1 = do
tagsoup <- TagParser.runSoup <$> PathIO.readFile fullAup1
let fullAup1Str = Path.toString fullAup1
trackMap <-
userErrorFromExc $
ME.mapException (printf "when reading '%s':\n%s" fullAup1Str) $
Map.fromList .
map (\track ->
(ProjectLabelTrack.name_ track,
ProjectLabelTrack.track_ track)) <$>
ProjectLabelTrack.tracksFromXML tagsoup
let lookupTrack name =
userErrorFromExc $
ME.fromMaybe (printf "%s: missing track '%s'" fullAup1Str name) $
Map.lookup name trackMap
let userErrorFromTrackExc ::
String -> (e -> Either String [String]) -> ME.Exceptional e a -> IO a
userErrorFromTrackExc trackName procMsg =
let header = printf "%s: In track '%s':" fullAup1Str trackName
in userErrorFromExc .
ME.mapException
(either (header +~+) (unlines . (header :)) . procMsg)
let toLabelChain ::
String -> LabelTrack.T Double a -> IO (LabelChain.T Double a)
toLabelChain name =
userErrorFromTrackExc name Left .
LabelTrack.maybeToLabelChain (Params.measureSampleRate params)
origins <- do
let labelChainFromIntervals ::
String ->
[ME.Exceptional String
(LabelTrack.Interval Double (OriginPaths PathPart.AbsRel))] ->
IO (LabelChain.T Double (OriginPaths PathPart.AbsRel))
labelChainFromIntervals name =
toLabelChain name . LabelTrack.Cons <=<
userErrorFromTrackExc name Right . collectExceptions
if True
then labelChainFromIntervals TrackName.recording =<<
originsFromRecordingTrack fullAup1 tagsoup
else labelChainFromIntervals TrackName.origin =<<
originsFromOriginTrack tagsoup lookupTrack
let chopLabelTrack ::
String -> LabelChain.T Double a -> IO [LabelChain.T Double a]
chopLabelTrack name =
userErrorFromTrackExc name
(\bndErrors ->
Right $
case ListHT.partitionMaybe id bndErrors of
(matchErrors, endErrors) ->
(Mn.when (not $ null matchErrors) $
"Could not find recording boundaries at:" :
map (printf "%.6f") matchErrors)
++
(Mn.when (not $ null endErrors)
["There are more labels than recordings."])) .
collectExceptions .
map (fmap LabelChainShifted.shiftToLabelChain) .
LabelChainShifted.chopClosest
(recip $ Rate.unpack $ Params.measureSampleRate params)
(void origins) .
LabelChainShifted.fromLabelChain
classifiedChunks <-
fmap (map (fmap Class.fromLabel)) $
chopLabelTrack TrackName.classes
=<<
toLabelChain TrackName.classes
=<<
lookupTrack TrackName.classes
hoursChunks <-
chopLabelTrack TrackName.hour
=<<
userErrorFromTrackExc
TrackName.hour (Right . ("Could not parse hours:" :)) .
LabelChain.collectExceptions .
fmap
(\label ->
maybe (ME.throw label) ME.Success $
Time.parseHour "%Y-%m-%d %H" label)
=<<
toLabelChain TrackName.hour
=<<
lookupTrack TrackName.hour
return $
LabelChain.zipWithList (flip (,))
(zip hoursChunks classifiedChunks) origins
runMeasureMulti ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Sort (Path.FilePath ar0) -> SPMethods.T -> (Format.Flags, Bool) ->
Params.T -> Flags ->
Path.DirPath ar0 -> Path.DirPath ar1 -> IO ()
runMeasureMulti sort sigProc fmtFlags params flags input output =
withOverviewPaths (fst fmtFlags) output $ \overviewPaths -> do
origRoot <- getOriginRoot input
dirs0 <- getDirectoryContentsFull input
(reportIgnoredIntervals flags =<<) $
forM (Key.sort (numericPattern . fst) dirs0) $ \(dir0,fullDir0) ->
whenDirectory Map.empty fullDir0 $ do
aups1 <-
sort . mapMaybe (FuncHT.mapFst dirFromAudPath)
=<< getDirectoryContentsFull fullDir0
forAnimals overviewPaths origRoot dir0 aups1 $ \(dir1,fullAup1) -> do
let outDir = output </> dir0 </> dir1
Dir.createDirectoryIfMissing True outDir
chunks <- readConcatAudacityProject params fullAup1
parallelRun $ \seqIn ->
flip map (LabelTrack.decons $ LabelChain.toLabelTrack chunks) $
\(bnd, ((origin, originPath), (hours, classified))) -> do
(fmtIn, sig) <-
Sequence.sync seqIn $
withSound flags originPath $
\ fmtIn sig -> return . (,) fmtIn $!! sig
Option.infoMsg flags $
printf "%s: signal length %f, interval %s, labels %d\n"
(Path.toString origin) (Signal.duration sig) (show bnd)
(SP.foldLength classified)
fmap ((,) origin) $
-- wait for the completion of the emissions
Sequence.sync seqIn . return =<<
runMeasureMain
sigProc fmtFlags params (Sequence.async seqIn)
hours classified fmtIn sig
originPath (outDir </> origin)
{-
You can compare results with mlpack's HMM implementation:
$ hmm_train -t gaussian -i /tmp/out-emissions.csv -l /tmp/out-states.csv -n 6
$ hmm_viterbi -m output_hmm.xml -i /tmp/out-emissions.csv
-}
runHMMTrainingSupervised ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Flags -> TrainingFlags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runHMMTrainingSupervised flags trainingFlags input output =
withSound flags input $ \fmtIn sig -> do
featSigs <-
featureSignals
(trainingSignalProcessing trainingFlags)
(trainingFeature trainingFlags) input sig
let featureRate = Signal.sampleRate $ fst featSigs
intervals <-
fmap Signal.body .
userErrorFromExc . LabelTrack.discretizeTrack featureRate =<<
LabelTrack.readFile (Path.dropExtension input <.> "txt")
hmmTrainings flags trainingFlags
input fmtIn sig intervals output featSigs
fineSnappedFromCoarseIntervals ::
Feature.Class -> Params.T -> Rate.Feature -> Signal.Sox ->
LabelTrack.T Double String ->
ME.Exceptional String (LabelChain.T Int String)
fineSnappedFromCoarseIntervals feature params rate sig =
Feature.fineSnappedFromCoarseIntervals feature params rate sig .
fmap Class.fromLabel
runHMMTrainingSupervisedCoarse ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Params.T -> Flags -> TrainingFlags ->
Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runHMMTrainingSupervisedCoarse params flags trainingFlags input output =
withSound flags input $ \fmtIn sig -> do
let feature = trainingFeature trainingFlags
let sigProc = trainingSignalProcessing trainingFlags
featSigs <- featureSignals sigProc feature input sig
let featureRate = Signal.sampleRate $ fst featSigs
fineIntervals <-
userErrorFromExc .
fineSnappedFromCoarseIntervals feature params featureRate sig =<<
LabelTrack.readFile (Path.dropExtension input <-> "coarse.txt")
LabelChain.writeFileInt featureRate
(Path.dropExtension output <-> "fine.txt") fineIntervals
hmmTrainings flags trainingFlags
input fmtIn sig fineIntervals output featSigs
{- |
This function requires absolute paths
in order to check for files with coinciding base name.
Optimally we would have canonicalized paths (e.g. links resolved).
-}
makePathMap :: [Path.AbsFile] -> IO (Map Path.AbsFile Path.AbsFile)
makePathMap paths = do
let (uniquePaths, clashingPaths) =
clashingMapFromList $
map (\path -> (Path.dropExtension path, path)) paths
checkClash "audio files with the same stem:" $
Map.map (fmap Path.toString) clashingPaths
return uniquePaths
{-
Clashing Map even contains lists with at least two elements
but we cannot make use of it. Thus, no nested NonEmpty.
-}
clashingMapFromList :: (Ord k) => [(k,a)] -> (Map k a, Map k (NonEmpty.T [] a))
clashingMapFromList =
Map.mapEither
(\ps ->
case ps of
NonEmpty.Cons p [] -> Left p
_ -> Right ps) .
Map.fromListWith NonEmptyC.append .
map (mapSnd NonEmpty.singleton)
checkClash ::
(PathClass.AbsRel ar) =>
String -> Map (Path.FilePath ar) (NonEmpty.T [] String) -> IO ()
checkClash msg clashing =
when (not $ Map.null clashing) $
ioError $ userError $ unlines $
msg :
(Map.elems $
Map.mapWithKey
(\path ps ->
Path.toString path ++ ": " ++
List.intercalate ", " (NonEmpty.flatten ps))
clashing)
nonEmptyMapForWithKeyM_ ::
(Monad m, Ord k) => NonEmptyMap.T k a -> (k -> a -> m ()) -> m ()
nonEmptyMapForWithKeyM_ xs f =
Fold.sequence_ $ NonEmptyMap.mapWithKey f xs
nonEmptyMapForWithKeyM ::
(Monad m, Ord k) =>
NonEmptyMap.T k a -> (k -> a -> m b) -> m (NonEmptyMap.T k b)
nonEmptyMapForWithKeyM xs f =
Trav.sequence $ NonEmptyMap.mapWithKey f xs
mapForWithKeyM_ ::
(Monad m, Ord k) => Map k a -> (k -> a -> m ()) -> m ()
mapForWithKeyM_ xs f = Fold.sequence_ $ Map.mapWithKey f xs
mapForWithKeyM ::
(Monad m, Ord k) => Map k a -> (k -> a -> m b) -> m (Map k b)
mapForWithKeyM xs f = Trav.sequence $ Map.mapWithKey f xs
completeDirectories ::
(PathClass.AbsRel ar) =>
[Path.FileDir ar] -> IO [Path.FilePath ar]
completeDirectories =
let isFile =
Find.fileType ==? Find.RegularFile ||?
Find.fileType ==? Find.SymbolicLink
in fmap (map Path.path . concat) .
mapM (Find.find Find.always isFile . Path.toString)
scanTrainingInputs ::
(PathClass.AbsRel ar) =>
Flags -> [Path.FileDir ar] -> IO [Path.FilePath ar]
scanTrainingInputs flags inputDirs = do
inputs <- completeDirectories inputDirs
Option.infoMsg flags $
filesMessage "training using following files:" inputs
return inputs
filesMessage ::
(PathClass.AbsRel ar) =>
String -> [Path.FilePath ar] -> String
filesMessage header paths =
unlines $ header : map Path.toString paths
isSuffixOfPath ::
(PathClass.AbsRel ar) =>
String -> Path.FilePath ar -> Bool
isSuffixOfPath suffix path =
List.isSuffixOf suffix $ Path.toString $ Path.takeFileName path
maybeSuffixOfPath ::
(PathClass.AbsRel ar) =>
String -> Path.FilePath ar -> Maybe (Path.FilePath ar)
maybeSuffixOfPath suffix path =
toMaybe (isSuffixOfPath suffix path) $
Path.mapFileName (Match.dropRev suffix) path
{- |
For all label files in the list of input files
we start a supervised training with respect
to the corresponding signal file.
Then an unsupervised training with all signals is performed.
All input signals must have the same sample rate
or the 'Feature.Class' must convert to a specific sample rate.
-}
runHMMTrainingMixedMulti ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
SPMethods.T -> Feature.Class -> Bool ->
Params.T -> Flags -> HMM.Convergence ->
[Path.FileDir ar0] -> Path.DirPath ar1 -> IO ()
runHMMTrainingMixedMulti sigProc feature plot params flags cvg inputDirs output = do
Dir.createDirectoryIfMissing True output
inputs <- scanTrainingInputs flags inputDirs
inputsAbs <- Trav.mapM Path.genericMakeAbsoluteFromCwd inputs
let (labelPaths, signalPaths) =
ListHT.partition (isSuffixOfPath ".txt") inputsAbs
intervalss <- Trav.mapM LabelTrack.readFile labelPaths
featSigsMap <- readFeatureSignalMap sigProc feature flags signalPaths output
rateLocFeatSigs@(Signal.Cons lowRate _locFeatSigs) <-
bundleFeatureSignals $ snd . fst <$> featSigsMap
let (coarseIntervalsMap, fineIntervalsMap) =
mapPair
(Map.fromList, Map.fromList . map (mapFst Path.dropExtension)) $
ListHT.partitionMaybe
(FuncHT.mapFst (maybeSuffixOfPath "-coarse.txt")) $
zip labelPaths intervalss
case Set.toAscList $
Set.intersection
(Map.keysSet coarseIntervalsMap)
(Map.keysSet fineIntervalsMap) of
[] -> return ()
clashing ->
ioError $ userError $
filesMessage "clashing fine and coarse label files:" clashing
let perFileExc =
userErrorFromExc . Trav.sequence .
Map.mapWithKey
(\name -> ME.mapException (printf "%s: %s" $ Path.toString name))
refinedIntervalsMap <-
perFileExc $
Map.intersectionWith
(fineSnappedFromCoarseIntervals feature params lowRate)
(fst.fst <$> featSigsMap) coarseIntervalsMap
mapForWithKeyM_ refinedIntervalsMap $ \fileName intervals ->
LabelChain.writeFileInt lowRate
(output </> Path.takeBaseName fileName <-> "fine.txt") intervals
intervalsMap <-
fmap (Map.union refinedIntervalsMap) $ perFileExc $
fmap (fmap Signal.body . LabelTrack.discretizeTrack lowRate) fineIntervalsMap
{-
That's not the same as (Map.keysSet intervalsMap)
since some filenames may already have been removed by
Map.intersectionWith in refinedIntervalsMap
-}
let allIntervalsNamesSet =
Set.union
(Map.keysSet fineIntervalsMap)
(Map.keysSet coarseIntervalsMap)
case Set.toAscList $
Set.difference allIntervalsNamesSet (Map.keysSet featSigsMap) of
[] -> return ()
missing ->
ioError $ userError $
filesMessage
"missing signal files for following label files:" missing
mapForWithKeyM_ intervalsMap $ checkEmptyIntervals lowRate
let labelCounts = histogram $ Fold.foldMap Fold.toList intervalsMap
(stateFromLabelMap, labelFromStateMap) =
HMM.mapsFromLabels $ map fst labelCounts
Option.infoAction flags $ do
putStrLn "encountered labels with assigned state number and frequency"
printLabelCounts stateFromLabelMap labelCounts
labelledSignals <-
userErrorFromExc $
ME.fromMaybe
"no matching label and signal files for supervised training" $
NonEmptyMap.fetch $
Map.intersectionWith (,)
(Signal.body . snd . fst <$> featSigsMap) intervalsMap
waits0 <-
plotStateEmissionsMulti plot supervisedName
stateFromLabelMap labelFromStateMap labelledSignals
hmmsTrained <-
userErrorFromExc $ Trav.sequence $
Par.withStrategy (Par.parTraversable Par.rdeepseq) $
NonEmptyMap.mapWithKey
(uncurry . HMM.trainSupervised stateFromLabelMap)
labelledSignals
forM_ (NonEmptyMap.toAscList hmmsTrained) $ uncurry $
checkAdmissibilityTrans
(Feature.admissibleTransitions feature) labelFromStateMap
let hmm = HMM0.trainMany id $ NonEmptyMap.elems hmmsTrained
hmmNamed =
HMMNamed.Cons {
HMMNamed.nameFromStateMap = labelFromStateMap,
HMMNamed.stateFromNameMap = stateFromLabelMap,
HMMNamed.model = hmm
}
featureHMM =
Feature.HMM {
Feature.hmmClass = feature,
Feature.hmmodel = hmmNamed
}
Feature.writeHMM (output </> Path.path hmmSupervisedName) featureHMM
Option.infoMsg flags $ HMM0.toCSV hmm
Option.notice flags "classify using trained model"
supervisedTracks <- writeAnalyzedTracks hmmNamed rateLocFeatSigs output
(waits1, unsupervisedTracks) <-
hmmTrainingsUnsupervised featureHMM plot flags cvg rateLocFeatSigs output
let fineTracks =
projectLabelChain "fine" . LabelChain.realTimes lowRate <$>
intervalsMap
writeMultiTrainingProject (fmap snd featSigsMap)
[fineTracks, supervisedTracks, unsupervisedTracks] output
waitPlots $ waits0 ++ waits1
runHMMTrainingUnsupervisedMulti ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
SPMethods.T -> Feature.HMM -> Bool -> Params.T -> Flags -> HMM.Convergence ->
[Path.FileDir ar0] -> Path.DirPath ar1 -> IO ()
runHMMTrainingUnsupervisedMulti
sigProc featureHMM plot _params flags cvg inputDirs output = do
Dir.createDirectoryIfMissing True output
inputs <- scanTrainingInputs flags inputDirs
inputsAbs <- Trav.mapM Path.genericMakeAbsoluteFromCwd inputs
featSigsMap <-
readFeatureSignalMap
sigProc (Feature.hmmClass featureHMM) flags inputsAbs output
rateLocFeatSigs <- bundleFeatureSignals $ snd . fst <$> featSigsMap
Option.notice flags "classify using old model"
supervisedTracks <-
writeAnalyzedTracks (Feature.hmmodel featureHMM) rateLocFeatSigs output
(waits, unsupervisedTracks) <-
hmmTrainingsUnsupervised featureHMM plot flags cvg rateLocFeatSigs output
writeMultiTrainingProject (fmap snd featSigsMap)
[supervisedTracks, unsupervisedTracks] output
waitPlots waits
writeAnalyzedTracks ::
(Rate.C rate, PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
HMM.NamedGaussian ->
Signal.T rate (NonEmptyMap.T (Path.FilePath ar0) [Named.NonEmptySignal]) ->
Path.DirPath ar1 -> IO (Map (Path.FilePath ar0) Audacity.Track)
writeAnalyzedTracks hmmNamed (Signal.Cons featRate locFeatSigs) output =
mapForWithKeyM (NonEmptyMap.flatten locFeatSigs) $ \fileName featSigs ->
writeLabelTrackInt featRate
(output </> Path.takeBaseName fileName) supervisedName $
HMM.analyze hmmNamed featSigs
writeMultiTrainingProject ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Map (Path.FilePath ar0)
(Double,
ProjectWaveSummary.Monad IO (Audacity.Track, [Audacity.Track])) ->
[Map (Path.FilePath ar0) Audacity.Track] -> Path.DirPath ar1 -> IO ()
writeMultiTrainingProject featSigsMap labelTrackMaps output =
mapForWithKeyM_ featSigsMap $ \fileName (zoom, waveTracksSum) -> do
let outputStem = output </> Path.takeBaseName fileName
((audPath, audFormat), (inputTrack, featSigTracks)) <-
waveSummaryEval outputStem waveTracksSum
PathIO.writeFile audPath $ audFormat $
createProject zoom $
inputTrack :
featSigTracks ++
mapMaybe (Map.lookup fileName) labelTrackMaps ++
[]
readFeatureSignalMap ::
(PathClass.AbsRel ar, MonadIO m) =>
SPMethods.T -> Feature.Class -> Flags -> [Path.AbsFile] -> Path.DirPath ar ->
IO (Map Path.AbsFile
((Signal.Sox, Signal.T Rate.Feature [Named.NonEmptySignal]),
(Double,
ProjectWaveSummary.Monad m (Audacity.Track, [Audacity.Track]))))
readFeatureSignalMap sigProc feature flags inputs output = do
inputPathMap <- makePathMap inputs
forM inputPathMap $ \input ->
withSound flags input $ \ fmtIn sig ->
case rnf sig of
() -> do
(featSigs, featSigsNE) <-
featureSignals sigProc feature input sig
featSigTrack <-
writeFeatureTracks fmtIn
(output </> Path.takeBaseName input <.> "wav")
(Feature.scale feature) featSigs
let waveTracks =
liftM2 (,)
(projectWaveTrackInput (sig, input)) featSigTrack
return
((sig, featSigsNE <$ featSigs),
(zoomFullSignal sig, waveTracks))
bundleFeatureSignals ::
(Ord loc) =>
Map loc (Signal.T rate signal) ->
IO (Signal.T rate (NonEmptyMap.T loc signal))
bundleFeatureSignals locFeatSigs =
userErrorFromExc $
ME.fromMaybe "missing training signals" $
(\nonEmptyFeatSigs ->
Signal.Cons
(Signal.sampleRate $ snd $ fst $
NonEmptyMap.minViewWithKey nonEmptyFeatSigs)
(fmap Signal.body nonEmptyFeatSigs)) <$>
NonEmptyMap.fetch locFeatSigs
hmmTrainingsUnsupervised ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Feature.HMM -> Bool -> Flags -> HMM.Convergence ->
Signal.T Rate.Feature
(NonEmptyMap.T (Path.FilePath ar0) [Named.NonEmptySignal]) ->
Path.DirPath ar1 ->
IO ([PlotProcess], Map (Path.FilePath ar0) Audacity.Track)
hmmTrainingsUnsupervised
featureHMM plot flags cvg (Signal.Cons lowRate locFeatSigs) output = do
Option.notice flags "unsupervised training"
let hmmNamed = Feature.hmmodel featureHMM
prep = NonEmptyMap.elems $ fmap HMM.prepare locFeatSigs
step model = HMM.trainMany (HMM0.trainUnsupervised model) prep
hmms =
HMM.takeUntilConvergence cvg $ iterate step $ HMMNamed.model hmmNamed
lastHMM = last hmms
lastHMMNamed = hmmNamed{HMMNamed.model = lastHMM}
mapM_ (Option.infoMsg flags . HMM0.toCSV) hmms
Option.noticeAction flags $
printModelDifference (HMMNamed.model hmmNamed) lastHMM
Option.notice flags "classify using trained model"
Feature.writeHMM (output </> Path.path hmmUnsupervisedName) $
(featureHMM {Feature.hmmodel = lastHMMNamed})
let labelleds =
fmap
(\featSigs -> (featSigs, HMM.analyze lastHMMNamed featSigs))
locFeatSigs
labelTracks <-
mapForWithKeyM (NonEmptyMap.flatten labelleds) $ \fileName (_, labelled) ->
writeLabelTrackInt lowRate
(output </> Path.takeBaseName fileName)
unsupervisedName labelled
waits <-
plotStateEmissionsMulti
plot unsupervisedName
(HMMNamed.stateFromNameMap hmmNamed)
(HMMNamed.nameFromStateMap hmmNamed)
labelleds
return (waits, labelTracks)
runDetectAdvertiseBandpass ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runDetectAdvertiseBandpass flags input output =
withSound flags input $ \fmtIn sig@(Signal.Cons rate _) ->
writeChannels fmtIn rate output $
flip map [38,69] $ \f ->
Causal.apply
(Bin.fromCanonicalWith Real.roundSimple
^<<
bandpass rate 10 (Freq f)) $
Named.body $
filterBand 2 (Freq 2000) sig
runDetectAdvertiseComb ::
(PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>
Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()
runDetectAdvertiseComb flags input output =
withSound flags input $ \fmtIn sig@(Signal.Cons rate _) ->
writeChannels fmtIn rate output $
flip map [38,69] $ \f ->
SVL.map (Bin.fromCanonicalWith Real.roundSimple) $
combFilter rate 0.9 (Time $ recip f) $
Named.body $
filterBand 2 (Freq 2000) sig
orderOption :: OP.Parser (IO (Sort path))
orderOption =
let attachNumbers sort = return $ return . zip [0..] . sort
in OP.option (fmap readCustomOrder Option.path)
(OP.long "custom-order" <>
OP.metavar "PATH" <>
OP.help "sort animals according to explicit list from file")
<|>
OP.flag' (attachNumbers $ List.sortBy (comparing fst))
(OP.long "lexicographic-order" <>
OP.help "sort animals in lexicographic order")
<|>
OP.flag
(attachNumbers $ Key.sort (numericPattern . fst))
(attachNumbers $ Key.sort (numericPattern . fst))
(OP.long "numeric-order" <>
OP.help "sort animals in number-aware lexicographic order")
emitTableOption :: OP.Parser Format.Flags
emitTableOption =
let switch = uncurry . Option.switch
(Format.Flags formulaNumberFlags tableFormats recordingFlags divTH) =
Format.defaultFlags
in pure Format.Flags
<*> (bisequenceA $ biliftA2 switch switch formulaNumberFlags $
CalcForm.Tracked
("emit-formula", "emit table files containing formulas")
("emit-number", "emit table files containing numbers"))
<*> (Trav.sequenceA $ OP.liftA2 switch tableFormats $
Format.TableFormats
("emit-csv", "emit table files in CSV format")
("emit-html", "emit table files in HTML format")
("emit-xml-2003", "emit table files in Excel 2003 XML format"))
<*> (Trav.sequenceA $ OP.liftA2 switch recordingFlags $
Format.RecordingFlags
("emit-single", "emit table files per recording and sound type")
("emit-multi", "emit table files per recording"))
<*> Option.switch divTH "divided-table-head"
"use two rows and merged cells for summary table headers"
emitOption :: OP.Parser (Format.Flags, Bool)
emitOption =
liftA2 (,)
emitTableOption
(Option.switch False "emit-track"
"emit audio and label tracks as individual files")
parseAction2 :: Params.T -> Option.Commands (Flags -> IO ())
parseAction2 params =
(Option.transferActionApp "trains" "supervised training" $
fmap
(\getTrainingFlags flags input output -> do
trainingFlags <- getTrainingFlags
runHMMTrainingSupervised flags trainingFlags input output)
(Option.trainingFlags SPOption.opt params))
<>
(Option.transferActionApp
"trainsc" "training with coarsely labelled recordings" $
fmap
(\getTrainingFlags flags input output -> do
trainingFlags <- getTrainingFlags
runHMMTrainingSupervisedCoarse params flags trainingFlags input output)
(Option.trainingFlags SPOption.opt params))
<>
(Option.transferActionApp "trainu" "unsupervised training" $
OP.liftA2
(\getTrainingFlags numStates flags input output -> do
trainingFlags <- getTrainingFlags
runHMMTrainingUnsupervised flags trainingFlags numStates input output)
(Option.trainingFlags SPOption.opt params)
Option.numStates)
<>
(Option.transferActionApp "hmm" "detect sounds using HMM" $
pure
(\sigProc readHMM fmtFlags flags input output -> do
hmm <- readHMM
runDetectHMM (sigProc, hmm, fmtFlags, params, flags) input output)
<*> SPOption.opt
<*> Option.model
<*> emitOption)
<>
(Option.transferActionApp "hmmm" "batched sound detection using HMM" $
pure
(\initOrder sigProc readHMM fmtFlags flags input output -> do
hmm <- readHMM
order <- initOrder
runDetectHMMMulti order
(sigProc, hmm, fmtFlags, params, flags) input output)
<*> orderOption
<*> SPOption.opt
<*> Option.model
<*> emitOption)
<>
(Option.transferActionApp
"measurem" "batched measurement of classified sounds" $
pure
(\initOrder sigProc fmtFlags flags input output -> do
order <- initOrder
runMeasureMulti order sigProc fmtFlags params flags input output)
<*> orderOption
<*> SPOption.opt
<*> emitOption)
<>
(Option.transferActionApp "match" "match with patterns" $
fmap
(\pattern -> runMatchPatterns pattern params)
(OP.option Option.path $ OP.long "pattern" <> OP.metavar "PATH"))
<>
Option.transferAction "dehum" "remove pink noise from recording" runDehum
<>
Option.transferAction "slope" "detect rasping clicks by steep attacks"
(runDetectAdvertiseSlope params)
<>
Option.transferAction "band" "detect rasping by a bandpass at click rate"
runDetectAdvertiseBandpass
<>
Option.transferAction "comb" "detect rasping by a comb filter at click rate"
runDetectAdvertiseComb
<>
Option.transferAction "extract" "extract patterns from labelled tracks"
(runExtractPatterns params)
parseActionMulti :: Params.T -> Option.Commands (Flags -> IO ())
parseActionMulti params =
(Option.multiAction "trainm"
"supervised and unsupervised training with multiple recordings" $
pure
(\sigProc cvg lookupFeature plot input output flags -> do
feature <- lookupFeature
runHMMTrainingMixedMulti
sigProc feature plot params flags cvg input output)
<*>
SPOption.opt
<*>
HMM.convergenceOptions
<*>
Option.feature params)
<>
(Option.multiAction "trainum"
"unsupervised training with multiple recordings" $
pure
(\sigProc cvg readHMM plot inputs output flags -> do
hmm <- readHMM
runHMMTrainingUnsupervisedMulti
sigProc hmm plot params flags cvg inputs output)
<*>
SPOption.opt
<*>
HMM.convergenceOptions
<*>
Option.model)
main :: IO ()
main = SoxLib.formatWith $ do
let params = Params.deflt
action <-
OP.execParser $ Option.info $
pure (flip ($))
<*> Option.parseFlags
<*> OP.subparser (parseActionMulti params <> parseAction2 params)
action