{-# 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, direntry)) <$> 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