diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2015, Henning Thielemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/classify-frog.cabal b/classify-frog.cabal new file mode 100644 --- /dev/null +++ b/classify-frog.cabal @@ -0,0 +1,177 @@ +Name: classify-frog +Version: 0.2.3 +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://code.haskell.org/~thielema/classify-frog/ +Category: Bioinformatics +Synopsis: Classify sounds produced by Xenopus laevis +Description: + This program is part of the Xenocall project. + Researchers observed that the amount and duration of calls + of the African clawed frog (Xenopus laevis) change + when exposed to hormonal effective substances. + The Xenocall project checks whether this effect + can be used as an endpoint in animal tests + instead of dissecting animals after the experiments. + . + An experiment for one substance + may produce about 100 hours of audio recordings. + It is a very tedious and error-prone work + to examine this amount of data visually or by listening. + The purpose of this program is to examine the recordings automatically + and generate tables with basic statistical parameters. + . + Read the full report at + . +Tested-With: GHC==7.4.2, GHC==7.8.4 +Cabal-Version: >=1.6 +Build-Type: Simple + +Extra-Source-Files: + data/directory-order.txt + data/advertisement.gp + data/advertisement.sh + data/advertisement-hourly.gp + +Data-Files: + model/diclo/hmm-global-supervised.csv + model/diclo/hmm-global-unsupervised.csv + model/diclo/hmm-growling-supervised.csv + model/diclo/hmm-supervised.csv + +Source-Repository this + Tag: 0.2.3 + Type: darcs + Location: http://hub.darcs.net/thielema/classify-frog + +Source-Repository head + Type: darcs + Location: http://hub.darcs.net/thielema/classify-frog + +Flag buildSketch + Description: Enable some sketch programs + Default: False + +Flag llvm + Description: Enable efficient signal processing using LLVM + Default: True + +Executable classify-frog + Main-Is: Main.hs + Other-Modules: + HiddenMarkovModel + HiddenMarkovModel.Hardwired + Label + Class + ClassRecord + Durations + Evaluation + Measurement + SpectralDistribution + SignalProcessingSpecific + SignalProcessing + SignalProcessingMethods + SignalProcessingOption + Sox + Audacity + Audacity.TrackName + Spreadsheet.Formula + Spreadsheet.Row + Spreadsheet.Palisade + Spreadsheet.Format + Quantile + Time + Fourier + Arithmetic + LabelTrack + LabelChain + LabelChainShifted + LabelPattern + Signal + Rate + Named + Parameters + Feature + Option + Hs-Source-Dirs: src + + Build-Depends: + hmm-hmatrix >=0.0 && <0.1, + hmatrix >=0.16 && <0.17, + text >=1.1 && <1.3, + lazy-csv >=0.5 && <0.6, + tagchup >=0.4 && <0.5, + xml-basic >=0.1.1 && <0.2, + synthesizer-core >=0.7.1 && <0.9, + audacity >=0.0.1 && <0.1, + soxlib >=0.0 && <0.1, + gnuplot >=0.5 && <0.6, + parallel >=3.2 && <3.3, + pooled-io >=0.0.2 && <0.1, + concurrent-split >=0.0 && <0.1, + fft >=0.1.8 && <0.2, + carray >=0.1.5 && <0.2, + storablevector-carray >=0.0 && <0.1, + -- for NFData instance + storablevector >=0.2.11 && <0.3, + storable-record >=0.0 && <0.1, + array >=0.4 && <0.6, + time >=1.5 && <1.9, + Cabal >=1.14 && <3, + optparse-applicative >=0.11 && <0.15, + filemanip >=0.3.6 && <0.4, + pathtype >=0.8 && <0.9, + non-empty >=0.3 && <0.4, + semigroups >=0.1 && <1.0, + containers >=0.4 && <0.6, + explicit-exception >=0.1.8 && <0.2, + transformers >=0.2 && <0.6, + bifunctors >=5 && <6, + semigroups >=0.8.4.1 && <0.19, + utility-ht >=0.0.12 && <0.1, + numeric-prelude >=0.4 && <0.5, + deepseq >=1.3 && <1.5, + base >=4 && <5 + + If flag(llvm) + Hs-Source-Dirs: llvm/yes + Other-Modules: + SignalProcessingSpecificLLVM + SignalProcessingLLVM + Build-Depends: + synthesizer-llvm >=0.8 && <0.9, + llvm-extra >=0.6 && <0.8, + llvm-tf >=3.0 && <3.2 + Else + Hs-Source-Dirs: llvm/no + + GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates + GHC-Options: -rtsopts -threaded + GHC-Prof-Options: -fprof-auto -rtsopts + + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Extensions: CPP + +Executable spectral-distribution + Main-Is: SpectralDistributionTest.hs + Other-Modules: + SpectralDistribution + Hs-Source-Dirs: src + If flag(buildSketch) + Build-Depends: + synthesizer-core, + storablevector >=0.2.10 && <0.3, + utility-ht, + numeric-prelude >=0.4 && <0.5, + base >=4 && <5 + Else + Buildable: False + + GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -rtsopts + + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind diff --git a/data/advertisement-hourly.gp b/data/advertisement-hourly.gp new file mode 100644 --- /dev/null +++ b/data/advertisement-hourly.gp @@ -0,0 +1,16 @@ +set terminal pdf +set xdata time +set timefmt "%Y-%m-%d %H" +set format x "%m-%d\n%H:00" +set ylabel "% advertisement calling" +set key below +set offset graph 0.10, 0.10 +plot "/tmp/meto/Nacht 1 ohne hCG/advertisement-hourly-MetoKo.ssv" \ + using (timecolumn(1)-500):($5*100):($4*100):($6*100) \ + title "Ko" with errorlines, \ + "/tmp/meto/Nacht 1 ohne hCG/advertisement-hourly-Meto10-8M.ssv" \ + using 1:($5*100):($4*100):($6*100) \ + title "10-8M" with errorlines, \ + "/tmp/meto/Nacht 1 ohne hCG/advertisement-hourly-Meto10-10M.ssv" \ + using (timecolumn(1)+500):($5*100):($4*100):($6*100) \ + title "10-10M" with errorlines diff --git a/data/advertisement.gp b/data/advertisement.gp new file mode 100644 --- /dev/null +++ b/data/advertisement.gp @@ -0,0 +1,15 @@ +set macro +set ylabel "% advertisement calling" +set key below +set offset graph 0.10, 0.10 +plot "/tmp/meto/advertisement-MetoKo.ssv" \ + every @rng using 0:(NaN):xticlabels(1) notitle with points, \ + "/tmp/meto/advertisement-MetoKo.ssv" \ + every @rng using ($0-0.1):($4*100):($3*100):($5*100) \ + title "Ko" with errorlines, \ + "/tmp/meto/advertisement-Meto10-8M.ssv" \ + every @rng using 0:($4*100):($3*100):($5*100) \ + title "10-8M" with errorlines, \ + "/tmp/meto/advertisement-Meto10-10M.ssv" \ + every @rng using ($0+0.1):($4*100):($3*100):($5*100) \ + title "10-10M" with errorlines diff --git a/data/advertisement.sh b/data/advertisement.sh new file mode 100644 --- /dev/null +++ b/data/advertisement.sh @@ -0,0 +1,4 @@ +gnuplot -e "set terminal pdf color; rng='::0::2'" advertisement.gp >/tmp/advertisement-ohne-hcg-color.pdf +gnuplot -e "set terminal pdf monochrome; rng='::0::2'" advertisement.gp >/tmp/advertisement-ohne-hcg-monochrome.pdf +gnuplot -e "set terminal pdf color; rng='::3::6'" advertisement.gp >/tmp/advertisement-mit-hcg-color.pdf +gnuplot -e "set terminal pdf monochrome; rng='::3::6'" advertisement.gp >/tmp/advertisement-mit-hcg-monochrome.pdf diff --git a/data/directory-order.txt b/data/directory-order.txt new file mode 100644 --- /dev/null +++ b/data/directory-order.txt @@ -0,0 +1,31 @@ +Ko 1 +MetoKo1 +MetoKo-2 +MetoKo-3 +MetoKo4 +MetoKo-5 +MetoKo-6 +MetoKo-7 +MetoKo-8 +MetoKo9 +MetoKo-10 +Meto10-8M-1 +Meto10-8M-2 +Meto10-8M-3 +Meto10-8M-4 +Meto10-8M-5 +Meto10-8M-6 +Meto10-8M-7 +Meto10-8M-8 +Meto10-8M-9 +Meto10-8M-10 +Meto10-10M-1 +Meto10-10M-2 +Meto10-10M-3 +Meto10-10M-4 +Meto10-10M-5 +Meto10-10M-6 +Meto10-10M-7 +Meto10-10M-8 +Meto10-10M-9 +Meto10-10M-10 diff --git a/llvm/no/SignalProcessingOption.hs b/llvm/no/SignalProcessingOption.hs new file mode 100644 --- /dev/null +++ b/llvm/no/SignalProcessingOption.hs @@ -0,0 +1,10 @@ +module SignalProcessingOption where + +import qualified Options.Applicative as OP + +import qualified SignalProcessingMethods as SPMethods +import qualified SignalProcessingSpecific as SPS + + +opt :: OP.Parser SPMethods.T +opt = OP.pure SPS.methods diff --git a/llvm/yes/SignalProcessingLLVM.hs b/llvm/yes/SignalProcessingLLVM.hs new file mode 100644 --- /dev/null +++ b/llvm/yes/SignalProcessingLLVM.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RebindableSyntax #-} +module SignalProcessingLLVM where + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Memory as Memory +import LLVM.Core (Value, ) + +import Foreign.Storable (Storable, ) + +import qualified Control.Category as Cat +import Control.Arrow (arr, (<<<), (^<<), (&&&), ) +import Control.Applicative (pure, ) + +import Data.Tuple.HT (fst3, snd3, thd3, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +zerothMoment :: CausalP.T p (Value Float) (Value Float) +zerothMoment = CausalP.delay1Zero + +firstMoment :: CausalP.T p (Value Float) (Value Float) +firstMoment = + ((arr thd3 - arr fst3) / 2) <<< lag2 + +secondMoment :: CausalP.T p (Value Float) (Value Float) +secondMoment = + (arr thd3 - 2 * arr snd3 + arr fst3) <<< lag2 + +lag2 :: CausalP.T p (Value Float) (Value Float, Value Float, Value Float) +lag2 = lag2Init $ pure (zero :: Float) + +lag2Init :: + (Storable a, Class.MakeValueTuple a, Memory.C al, Class.ValueTuple a ~ al) => + Param.T p a -> CausalP.T p al (al,al,al) +lag2Init x = + (\((x0,x1),x2) -> (x0,x1,x2)) + ^<< + (CausalP.delay1 x &&& Cat.id <<< CausalP.delay1 x) &&& Cat.id diff --git a/llvm/yes/SignalProcessingOption.hs b/llvm/yes/SignalProcessingOption.hs new file mode 100644 --- /dev/null +++ b/llvm/yes/SignalProcessingOption.hs @@ -0,0 +1,16 @@ +module SignalProcessingOption where + +import Option (switch, ) +import qualified Options.Applicative as OP + +import qualified SignalProcessingMethods as SPMethods +import qualified SignalProcessingSpecific as SPS +import qualified SignalProcessingSpecificLLVM as SPSLLVM + +import Control.Applicative ((<$>), ) + + +opt :: OP.Parser SPMethods.T +opt = + (\b -> if b then SPSLLVM.methods else SPS.methods) <$> + switch True "llvm" "use LLVM to accelerate signal processing" diff --git a/llvm/yes/SignalProcessingSpecificLLVM.hs b/llvm/yes/SignalProcessingSpecificLLVM.hs new file mode 100644 --- /dev/null +++ b/llvm/yes/SignalProcessingSpecificLLVM.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE RebindableSyntax #-} +module SignalProcessingSpecificLLVM where + +import qualified Parameters as Params +import Parameters (Freq(Freq), ) + +import qualified SpectralDistribution as SD +import qualified SignalProcessingMethods as Methods +import qualified SignalProcessingLLVM as SPLLVM +import qualified SignalProcessing as SP +import qualified Signal +import qualified Rate +import SignalProcessingMethods (Triple, ) +import SignalProcessing (fanout3, ) + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Fold as Fold +import qualified Synthesizer.LLVM.Frame.Binary as Bin +import qualified Synthesizer.LLVM.Parameter as Param +import Synthesizer.LLVM.Causal.Process (($*), ($<), ) + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilt +import Synthesizer.Plain.Filter.Recursive (Pole(Pole), ) + +import qualified Sound.SoxLib as SoxLib +import qualified Data.StorableVector.Lazy as SVL + +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Core (Value, ) + +import Control.Arrow (arr, (&&&), (<<<), (^<<), ) +import Control.Applicative (pure, liftA2, (<$>), ) +import Data.Tuple.HT (mapSnd, fst3, snd3, thd3, uncurry3, ) + +import NumericPrelude.Numeric hiding (sum1) +import NumericPrelude.Base + +import Data.Word (Word32, ) + + +type Causal p = CausalP.T (SoxLib.Rate, p) +type Param p = Param.T (SoxLib.Rate, p) + +dehum :: Causal p (Value Float) (Value Float) +dehum = + UniFilter.highpass + ^<< + UniFilter.causal + $< SigP.constant (UniFilt.parameter . Pole 1 <$> freq (pure (Freq 800))) + +rumble :: Causal p (Value Float) (Value Float) +rumble = + UniFilter.lowpass + ^<< + UniFilter.causal + $< SigP.constant (UniFilt.parameter . Pole 5 <$> freq (pure (Freq 220))) + +bandpass :: + Param p Float -> Param p Freq -> Causal p (Value Float) (Value Float) +bandpass q f = + UniFilter.bandpass + ^<< + UniFilter.causal + $< SigP.constant (UniFilt.parameter <$> liftA2 Pole q (freq f)) + +freq :: Param p Freq -> Param p Float +freq f = liftA2 Params.freq (arr (Rate.Sample . fst)) f + + +_downSampleMaxAbsFrac :: + Param.T p Double -> SigP.T p (Value Float) -> SigP.T p (Value Float) +_downSampleMaxAbsFrac sizeFrac xs = + Causal.foldChunksPartial Fold.maxAbs xs $* + SigP.fromStorableVectorLazy (downSampleChunkSizes <$> sizeFrac) + +downSampleMaxAbsFrac :: + SigP.T p (Value Float) -> Double -> p -> SVL.Vector Float +downSampleMaxAbsFrac xs = + let folds = + CausalP.applyStorableChunky (Causal.foldChunksPartial Fold.maxAbs xs) + in \sizeFrac p -> folds p (downSampleChunkSizes sizeFrac) + +downSampleChunkSizes :: Double -> SVL.Vector Word32 +downSampleChunkSizes = + SigG.fromState SigG.defaultLazySize . + fmap fromIntegral . SP.downSampleChunkSizes + +bandsDerivativesProc :: + Param.T (SoxLib.Rate, p) (Triple Freq) -> + CausalP.T + (SoxLib.Rate, p) + (Value Float) + (Triple (Value Float), Triple (Value Float)) +bandsDerivativesProc bandFreqs = + let band f = bandpass 10 (f <$> bandFreqs) + in fanout3 (band fst3) (band snd3) (band thd3) + &&& + fanout3 SPLLVM.zerothMoment SPLLVM.firstMoment SPLLVM.secondMoment + +bandsDerivatives :: + Triple Freq -> Signal.Sampled Float -> + SVL.Vector (Triple Float, Triple Float) +bandsDerivatives bandFreqs = + let proc = CausalP.applyStorableChunky $ bandsDerivativesProc $ arr snd + in \(Signal.Cons rate sig) -> proc (Rate.unpack rate, bandFreqs) sig + +intervalSizes :: [Int] -> SVL.Vector Word32 +intervalSizes = + SigG.fromList SigG.defaultLazySize . map fromIntegral + +allSums :: + SigP.T p (Triple (Value Float), Triple (Value Float)) -> + [Int] -> p -> [(Triple Float, Triple Float)] +allSums xs = + let foldSumAbs = Fold.premap A.abs Fold.sum + foldSumAbs3 = Fold.triple foldSumAbs foldSumAbs foldSumAbs + folds = + CausalP.applyStorableChunky + (Causal.foldChunksPartial (Fold.pair foldSumAbs3 foldSumAbs3) xs) + in \sizes p -> SVL.unpack $ folds p $ intervalSizes sizes + + +spectralBandDistr :: Triple Freq -> Triple Float -> (Float, Float) +spectralBandDistr + (Freq bandFreq0, Freq bandFreq1, Freq bandFreq2) (sum0, sum1, sum2) = + mapSnd sqrt $ + SP.centroidVariance3 + (bandFreq0, sum0) + (bandFreq1, sum1) + (bandFreq2, sum2) + +bandParameters :: + Triple Freq -> (Triple Float, Triple Float) -> ((Float, Float), SD.T Float) +bandParameters bandFreqs (bandSums, diffSums) = + (spectralBandDistr bandFreqs bandSums, + uncurry3 SD.spectralDistribution1 diffSums) + + +methods :: Methods.T +methods = + Methods.Cons { + Methods.dehum = + let run = + CausalP.applyStorableChunky + (dehum <<< Causal.map Bin.toCanonical) + in \(Signal.Cons rate xs) -> + Signal.Cons rate $ run (Rate.unpack rate, ()) xs, + + Methods.rumble = + let run = + CausalP.applyStorableChunky + (rumble <<< Causal.map Bin.toCanonical) + in \(Signal.Cons rate xs) -> + Signal.Cons rate $ run (Rate.unpack rate, ()) xs, + + Methods.downSampleAbs = + let run = + downSampleMaxAbsFrac $ + SigP.fromStorableVectorLazy (arr snd) + in \featRate (Signal.Cons rate xs) -> + run (Rate.unpack rate / featRate) (Rate.unpack rate, xs), + + Methods.bandpassDownSample = + let run = + downSampleMaxAbsFrac $ + CausalP.apply + (bandpass 10 (arr (fst.snd)) <<< Causal.map Bin.toCanonical) + (SigP.fromStorableVectorLazy (arr (snd.snd))) + in \featRate f (Signal.Cons rate xs) -> + run (Rate.ratio rate featRate) (Rate.unpack rate, (f, xs)), + + Methods.bandParameters = + let run = + allSums $ + CausalP.apply + (bandsDerivativesProc (arr (fst.snd))) + (SigP.fromStorableVectorLazy (arr (snd.snd))) + in \bandFreqs (Signal.Cons rate xs) sizes -> + map (bandParameters bandFreqs) $ + run sizes (Rate.unpack rate, (bandFreqs, xs)) + } diff --git a/model/diclo/hmm-global-supervised.csv b/model/diclo/hmm-global-supervised.csv new file mode 100644 --- /dev/null +++ b/model/diclo/hmm-global-supervised.csv @@ -0,0 +1,27 @@ +global,1200Hz,2000Hz,low rate,200Hz,block size,5 +chirping,growling,p,rasping +0.1,0.2,0.5,0.2 +0.9092827004219408,1.7985611510791366e-2,5.928853754940711e-3,3.601440576230492e-2 +1.6877637130801686e-2,0.960431654676259,2.569169960474308e-2,1.2004801920768306e-3 +2.109704641350211e-3,1.9784172661870505e-2,0.9367588932806323,2.4009603841536612e-2 +7.172995780590717e-2,1.7985611510791368e-3,3.162055335968379e-2,0.9387755102040816 +,,, +0.8587364400992413,1.4232983619351929,7.338302583634098, +0.37618100020750006,0.3303891388355467,-0.15695059129166744, +0.0,0.761113627386951,-0.2383077009820257, +0.0,0.0,1.7976586946549482, +,,, +1.915046286593648,6.615332768250197,4.3444321736078075, +0.3033090089584653,0.628862584638055,0.1789626247534727, +0.0,1.32531418386663,-0.3086778219708213, +0.0,0.0,1.0813382222444057, +,,, +0.5016917140462778,2.3917899698106853,2.9387258145014052, +0.2750444201238891,0.5153981440298611,0.2557314768917813, +0.0,0.9551385194413451,5.2061246425613404e-2, +0.0,0.0,0.8888464803100031, +,,, +1.5758024277232532,3.473913098500072,6.813986195434483, +0.404957679895657,-0.12314488883509744,0.5884665034934281, +0.0,1.3085334794619674,-0.6429168763903721, +0.0,0.0,1.766639995775783, diff --git a/model/diclo/hmm-global-unsupervised.csv b/model/diclo/hmm-global-unsupervised.csv new file mode 100644 --- /dev/null +++ b/model/diclo/hmm-global-unsupervised.csv @@ -0,0 +1,27 @@ +global,1200Hz,2000Hz,low rate,200Hz,block size,5 +chirping,growling,p,rasping +0.0,2.5182677828407726e-39,0.7516877496065736,0.24831225039342655 +0.8832105323287546,1.5693732128492243e-2,1.7667043248381836e-2,6.46767390259016e-2 +2.5492490550710352e-2,0.9401954364242668,1.7302502685456498e-2,2.8628504778003622e-2 +2.659956972233448e-3,8.718281414902813e-3,0.9401446952247045,1.1719482873687945e-2 +8.863702014830155e-2,3.539255003233807e-2,2.488575884145718e-2,0.894975273322407 +,,, +0.7488273464777045,1.24079995162256,6.9523340312012465, +0.2809788531413077,0.16405312861622548,0.4447958307183242, +0.0,0.2551609464157609,0.1881060460055203, +0.0,0.0,2.003608882341692, +,,, +1.7820889138469223,6.149753597789371,4.945415046755182, +0.2746470467280688,0.2252428295722046,0.20079381238569424, +0.0,1.1608041672048595,-0.35421223059056617, +0.0,0.0,1.0949321088890642, +,,, +0.44822689311988695,2.2597933074377385,2.933059975538248, +0.1271168079500722,-4.4273581861703264e-2,-6.048436965402269e-2, +0.0,0.4461413271415143,1.9323992704078315e-2, +0.0,0.0,0.5860114444501294, +,,, +1.4743993393293948,3.219060810449654,6.501203215444358, +0.3639275159883088,-6.800455306372202e-2,0.8292696304547397, +0.0,0.9507450274051655,-0.12749508318037758, +0.0,0.0,1.706880611979072, diff --git a/model/diclo/hmm-growling-supervised.csv b/model/diclo/hmm-growling-supervised.csv new file mode 100644 --- /dev/null +++ b/model/diclo/hmm-growling-supervised.csv @@ -0,0 +1,38 @@ +band,1200Hz,2000Hz,low rate,200Hz,sqrt +ch,cp,g0,g1,p,r0,r1 +0.0,0.0,0.0,0.2,0.6000000000000001,0.0,0.2 +0.9802661771454796,0.0,0.0,5.120327700972862e-3,1.1682242990654205e-3,0.0,1.2583892617449664e-2 +1.973382285452042e-2,0.7971698113207547,0.0,0.0,0.0,0.0,0.0 +0.0,3.773584905660377e-2,0.3711843711843712,0.2529441884280594,5.0623052959501555e-3,0.0,4.1946308724832214e-4 +0.0,0.0,0.6288156288156288,0.7357910906298003,0.0,0.0,0.0 +0.0,4.7169811320754715e-3,0.0,5.6323604710701485e-3,0.9875389408099688,0.0,8.389261744966443e-3 +0.0,0.16037735849056603,0.0,5.120327700972862e-4,6.230529595015576e-3,0.5799086757990868,0.2873322147651007 +0.0,0.0,0.0,0.0,0.0,0.4200913242009132,0.6912751677852349 +,,,,,, +0.9550183803567979,2.2859005687323224,,,,, +0.19524390507481648,-1.2393091495619494e-2,,,,, +0.0,0.45341351961456355,,,,, +,,,,,, +0.7067445279714071,1.6467289224548158,,,,, +0.25036045720184585,0.2220873541185848,,,,, +0.0,0.6692064476280676,,,,, +,,,,,, +2.11645829459516,1.803474807521192,,,,, +0.4505252618934032,3.8883740752153895e-2,,,,, +0.0,0.3049370489689819,,,,, +,,,,,, +1.583775902162194,1.301590493251224,,,,, +0.5562444931501922,0.1991733399386165,,,,, +0.0,0.25284096017155894,,,,, +,,,,,, +1.2816906989269894,1.4535234969490374,,,,, +0.22928568193736565,8.090579770808067e-2,,,,, +0.0,0.2457968791040043,,,,, +,,,,,, +1.5335102065649207,2.2115089248984914,,,,, +0.3426988228331401,-5.483041894071192e-2,,,,, +0.0,0.42960665641503176,,,,, +,,,,,, +0.9782469885904084,1.4426482854649205,,,,, +0.3509634221742646,0.1288353892318251,,,,, +0.0,0.4786606234655372,,,,, diff --git a/model/diclo/hmm-supervised.csv b/model/diclo/hmm-supervised.csv new file mode 100644 --- /dev/null +++ b/model/diclo/hmm-supervised.csv @@ -0,0 +1,28 @@ +band,1200Hz,2000Hz,low rate,200Hz,sqrt +ch,cp,p,r0,r1 +0.0,0.0,0.75,0.0,0.25 +0.9819474835886214,0.0,1.5045135406218657e-3,0.0,1.4211274277593557e-2 +1.8052516411378554e-2,0.7870967741935484,0.0,0.0,0.0 +0.0,1.2903225806451613e-2,0.9909729187562688,0.0,7.579346281383231e-3 +0.0,0.2,7.522567703109328e-3,0.661904761904762,0.280909521553766 +0.0,0.0,0.0,0.3380952380952381,0.6972998578872572 +,,,, +0.9368601738428392,2.270088559623881,,, +0.17760211937277373,-3.0445023371788348e-2,,, +0.0,0.4616682895546417,,, +,,,, +0.8478956213881893,1.4212917872013584,,, +0.500306885072571,3.3980997724841415e-2,,, +0.0,0.5445140035569593,,, +,,,, +1.2955354219624322,1.4758575685214088,,, +0.21800316741240738,3.5504609649847065e-2,,, +0.0,0.2332111684329513,,, +,,,, +1.3925725036197238,2.2883030459994362,,, +0.35474193945399723,4.772943733071615e-2,,, +0.0,0.3354287181232641,,, +,,,, +1.0404438883715281,1.3178025116918213,,, +0.43411299248183316,0.1432972470646394,,, +0.0,0.3546874178976907,,, diff --git a/src/Arithmetic.hs b/src/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Arithmetic.hs @@ -0,0 +1,28 @@ +module Arithmetic where + +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (id) + +import Prelude () + + +det2 :: (Ring.C a) => ((a, a), (a, a)) -> a +det2 ((a00,a01), (a10,a11)) = a00*a11 - a10*a01 + +solve2 :: + (Field.C a) => + ((a, a), (a, a)) -> (a, a) -> (a, a) +solve2 a@(a0,a1) b = + let d = det2 a + in (det2 (b,a1) / d, det2 (a0,b) / d) + +linearRegression :: (Field.C a) => [(a,a)] -> (a, a) +linearRegression xys = + let (xs,ys) = unzip xys + s = sum xs + s2 = sum $ map (^2) xs + in solve2 + ((fromIntegral $ length xs, s), (s, s2)) + (sum ys, sum $ zipWith (*) xs ys) diff --git a/src/Audacity.hs b/src/Audacity.hs new file mode 100644 --- /dev/null +++ b/src/Audacity.hs @@ -0,0 +1,362 @@ +module Audacity where + +import qualified Audacity.TrackName as TrackName +import qualified LabelTrack +import qualified LabelChain +import qualified Named +import qualified Parameters as Params +import qualified Signal +import qualified Rate + +import qualified Synthesizer.Generic.Cut as CutG +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.Track.Wave as ProjectWaveTrack +import qualified Sound.Audacity.Project as Audacity +import qualified Sound.SoxLib as SoxLib +import Sox (writeFeatures) + +import qualified Data.StorableVector.Lazy as SVL + +import qualified Text.HTML.Tagchup.Parser as TagParser +import qualified Text.HTML.Tagchup.Tag as Tag +import qualified Text.XML.Basic.Attribute as Attr +import qualified Text.XML.Basic.Name.MixedCase as Name + +import Spreadsheet.Format ((<->), ) + +import qualified Control.Monad.Exception.Synchronous as ME +import Control.Monad.IO.Class (MonadIO, liftIO, ) +import Control.Monad.HT ((<=<), ) +import Control.Monad (guard, liftM, ) +import Control.Applicative ((<$>), ) + +import qualified Data.Traversable as Trav +import qualified Data.List.HT as ListHT +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.Map as Map +import Data.Zip (transposeClip, ) +import Data.Traversable (forM, ) +import Data.Monoid (mconcat, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (mapMaybe, listToMaybe, isJust, ) + +import qualified System.Path.PartClass as PathClass +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 Text.Read.HT (maybeRead, ) +import Text.Printf (printf, ) + + + +zoomWidth :: Double +zoomWidth = 850 + +zoomFullSignal :: + (Rate.C rate, CutG.Read signal) => Signal.T rate signal -> Double +zoomFullSignal sig = zoomWidth / Signal.duration sig + +createProject :: Double -> [Audacity.Track] -> Audacity.T +createProject zoom tracks = + Audacity.deflt { + Audacity.zoom_ = zoom, + Audacity.tracks_ = tracks + } + + +projectLabelTrack :: String -> LabelTrack.T Double String -> Audacity.Track +projectLabelTrack name labels = + Audacity.LabelTrack + (ProjectLabelTrack.deflt { + ProjectLabelTrack.name_ = name, + ProjectLabelTrack.track_ = labels + }) + +projectLabelChain :: String -> LabelChain.T Double String -> Audacity.Track +projectLabelChain name = projectLabelTrack name . LabelTrack.fromLabelChain + + +summary :: SVL.Vector Float -> [ProjectWaveSummary.T] +summary = ProjectWaveSummary.sequenceFromStorableVector 262144 + +summaryDuration :: + (Rate.C rate) => Signal.T rate [ProjectWaveSummary.T] -> Double +summaryDuration (Signal.Cons rate xs) = + Params.toTime rate $ sum $ map ProjectWaveSummary.length_ xs + + +pcmAliasSequenceFromSummary :: + (PathClass.AbsRel ar, MonadIO m) => + Path.FilePath ar -> Int -> + [ProjectWaveSummary.T] -> + ProjectWaveSummary.Monad m ProjectWaveTrack.Sequence +pcmAliasSequenceFromSummary aliasFile channel sig = do + aliasFileAbs <- liftIO $ Path.genericMakeAbsoluteFromCwd aliasFile + ProjectWaveTrack.pcmAliasSequenceFromSummary + (Path.toString aliasFileAbs) channel sig + +projectWaveTrack :: + (Rate.C rate, PathClass.AbsRel ar, MonadIO m) => + Int -> Bool -> + (Signal.T rate (Named.T [ProjectWaveSummary.T]), Path.FilePath ar) -> + ProjectWaveSummary.Monad m Audacity.Track +projectWaveTrack channel active + (Signal.Cons rate (Named.Cons name sig), aliasFile) = do + sequ <- pcmAliasSequenceFromSummary aliasFile channel sig + return $ + Audacity.WaveTrack $ + ProjectWaveTrack.deflt { + ProjectWaveTrack.name_ = name, + ProjectWaveTrack.rate_ = round $ Rate.unpack rate, + ProjectWaveTrack.mute_ = not active, + ProjectWaveTrack.clips_ = + [ProjectWaveTrack.Clip { + ProjectWaveTrack.offset_ = 0, + ProjectWaveTrack.sequence_ = sequ + }] + } + +projectWaveTrackFeatures :: + (Rate.C rate, PathClass.AbsRel ar, MonadIO m) => + (([Float], Signal.T rate [Named.Signal]), Path.FilePath ar) -> + ProjectWaveSummary.Monad m [Audacity.Track] +projectWaveTrackFeatures ((scales, featSigs), output) = + forM (zip3 [0..] scales $ Trav.sequenceA featSigs) $ \(n, scale, featSig) -> + projectWaveTrack n False + (Signal.map (summary . SVL.map (scale*) <$>) featSig, output) + +projectWaveTrackInputSummary :: + (Rate.C rate, PathClass.AbsRel ar, MonadIO m) => + (Signal.T rate [ProjectWaveSummary.T], Path.FilePath ar) -> + ProjectWaveSummary.Monad m Audacity.Track +projectWaveTrackInputSummary (sig, input) = + projectWaveTrack 0 True + (Signal.map (Named.Cons TrackName.recording) sig, input) + +projectWaveTrackInput :: + (PathClass.AbsRel ar, MonadIO m) => + (Signal.Sox, Path.FilePath ar) -> + ProjectWaveSummary.Monad m Audacity.Track +projectWaveTrackInput (sig, input) = + projectWaveTrackInputSummary + (Signal.map (summary . SVL.map Bin.toCanonical) sig, input) + +projectWaveTrackConcat :: + (Rate.C rate, PathClass.AbsRel ar, + MonadIO m, NonEmptyC.Zip f, NonEmptyC.Repeat f) => + f String -> + [(Path.FilePath ar, + (Signal.T rate [ProjectWaveSummary.T], f (LabelTrack.T Double String)))] -> + ProjectWaveSummary.Monad m + (Double, Audacity.Track, f (Audacity.Track), Audacity.Track) +projectWaveTrackConcat labelNames sigs = do + sequs <- + forM sigs $ \(aliasFile, (Signal.Cons _ sig, _)) -> + pcmAliasSequenceFromSummary aliasFile 0 sig + let durs = map (summaryDuration . fst . snd) sigs + let starts = scanl (+) 0 durs + setRate <- + case map (Rate.unpack . Signal.sampleRate . fst . snd) sigs of + [] -> return id + rt@(r:rs) -> + if all (r==) rs + then return $ \track -> track {ProjectWaveTrack.rate_ = round r} + else liftIO $ ioError $ userError $ unlines $ + ["differing sample rates", show rt] + return + (sum durs + , + Audacity.WaveTrack $ setRate $ + ProjectWaveTrack.deflt { + ProjectWaveTrack.name_ = TrackName.recording, + ProjectWaveTrack.clips_ = zipWith ProjectWaveTrack.Clip starts sequs + } + , + NonEmptyC.zipWith projectLabelTrack labelNames $ + fmap mconcat $ transposeClip $ + zipWith + (\start (_,(_,labv)) -> LabelTrack.shift start <$> labv) starts sigs +{- + zipWith + (\dur (_,(_,labv)) -> LabelTrack.trim (0,dur) <$> labv) durs sigs +-} + , + projectLabelChain TrackName.origin $ + LabelChain.fromAdjacentChunks $ + zip durs $ map (Path.toString . Path.takeBaseName . fst) sigs) + + +writeLabelTrackInt :: + (Rate.C rate, PathClass.AbsRel ar) => + rate -> Path.FilePath ar -> String -> + LabelChain.T Int String -> IO Audacity.Track +writeLabelTrackInt rate stem part trackInt = do + let track = LabelChain.realTimes rate trackInt + LabelChain.writeFile (stem <-> "hmm-labels" <-> part <.> "txt") track + return $ projectLabelChain part track + +writeFeatureTracks :: + (PathClass.AbsRel ar, MonadIO m) => + SoxLib.Format mode -> Path.FilePath ar -> + [Float] -> Signal.T Rate.Feature [Named.Signal] -> + IO (ProjectWaveSummary.Monad m [Audacity.Track]) +writeFeatureTracks fmtIn output scales featSigs = do + writeFeatures fmtIn output scales featSigs + return $ projectWaveTrackFeatures ((scales, featSigs), output) + +waveSummaryEval :: + (PathClass.AbsRel ar, Monad m) => + Path.FilePath ar -> ProjectWaveSummary.Monad m a -> + m ((Path.FilePath ar, Audacity.T -> String), a) +waveSummaryEval outputStem summ = do + let outputSumDir = outputStem <++> "_data" + liftM + ((,) (outputStem <.> "aup", + \audProj -> + Audacity.format + (audProj {Audacity.name_ = + Path.toString (Path.takeFileName outputSumDir)}) "")) $ + ProjectWaveSummary.eval (Path.toString outputSumDir) summ + + + + +type OriginPaths ar = (Path.RelFile, Path.FilePath ar) + +maybePCMAliasTag :: + (PathClass.AbsRel ar) => + Tag.T Name.T String -> Maybe (OriginPaths ar) +maybePCMAliasTag tag = do + (name, attrs) <- Tag.maybeOpen tag + guard $ name == Tag.Name (Name.Cons "pcmaliasblockfile") + path <- Path.maybe =<< Attr.lookupLit "aliasfile" attrs + return (Path.takeFileName path, path) + +originsFromOriginTrack :: + (PathClass.AbsRel ar) => + [Tag.T Name.T String] -> + (String -> IO (LabelTrack.T time String)) -> + IO [ME.Exceptional String (LabelTrack.Interval time (OriginPaths ar))] +originsFromOriginTrack tagsoup lookupTrack = do + let fileMap = + Map.fromList $ map (\pair -> (Path.toString $ fst pair, pair)) $ + mapMaybe maybePCMAliasTag tagsoup + origins <- lookupTrack TrackName.origin + return $ + flip map (LabelTrack.decons origins) $ \(bnds, origin) -> + case Map.lookup origin fileMap of + Just pair -> ME.Success (bnds, pair) + Nothing -> ME.Exception $ printf "missing origin '%s'" origin + + + +waveTrackName :: Tag.Name Name.T +waveTrackName = Tag.Name (Name.Cons "wavetrack") + +maybeWaveTrackTag :: Tag.T Name.T String -> Maybe SoxLib.Rate +maybeWaveTrackTag tag = do + (name, attrs) <- Tag.maybeOpen tag + guard $ name == waveTrackName + trackName <- Attr.lookupLit "name" attrs + guard $ trackName == TrackName.recording + maybeRead =<< Attr.lookupLit "rate" attrs + +maybeWaveTrackCloseTag :: Tag.T Name.T String -> Maybe () +maybeWaveTrackCloseTag tag = do + name <- Tag.maybeClose tag + guard $ name == waveTrackName + +maybeWaveClipTag :: Tag.T Name.T String -> Maybe Double +maybeWaveClipTag tag = do + (name, attrs) <- Tag.maybeOpen tag + guard $ name == Tag.Name (Name.Cons "waveclip") + maybeRead =<< Attr.lookupLit "offset" attrs + +maybeSequenceTag :: Tag.T Name.T String -> Maybe Integer +maybeSequenceTag tag = do + (name, attrs) <- Tag.maybeOpen tag + guard $ name == Tag.Name (Name.Cons "sequence") + maybeRead =<< Attr.lookupLit "numsamples" attrs + +intervalFromWaveClip :: + (PathClass.AbsRel ar) => + SoxLib.Rate -> Double -> [Tag.T Name.T String] -> + Maybe (LabelTrack.Interval Double (OriginPaths ar)) +intervalFromWaveClip rate from tagsoup = do + len <- listToMaybe $ mapMaybe maybeSequenceTag tagsoup + origin <- listToMaybe $ mapMaybe maybePCMAliasTag tagsoup + return ((from, from + fromInteger len / rate), origin) + +originsFromRecordingTrack :: + (PathClass.AbsRel ar0, PathClass.AbsRel ar1) => + Path.FilePath ar0 -> [Tag.T Name.T String] -> + IO [ME.Exceptional String + (LabelTrack.Interval Double (OriginPaths ar1))] +originsFromRecordingTrack path tagsoup = do + (rate, waveTrackStart) <- + case ListHT.segmentBeforeMaybe maybeWaveTrackTag tagsoup of + (_, firstTrack : _) -> return firstTrack + _ -> + ioError $ userError $ + printf "%s: no 'recording' wave track found" $ Path.toString path + + let intervalFromClip (from, clip) = + ME.fromMaybe + (printf + "missing length or origin info for clip starting from %f" from) $ + intervalFromWaveClip rate from clip + + return $ map intervalFromClip $ + snd $ ListHT.segmentBeforeMaybe maybeWaveClipTag $ + takeWhile (not . isJust . maybeWaveTrackCloseTag) waveTrackStart + + + +audacityExt :: String +audacityExt = ".aup" + +dirFromAudPath :: + (PathClass.AbsRel ar) => + Path.FilePath ar -> Maybe (Path.DirPath ar) +dirFromAudPath = + (\(base, ext) -> toMaybe (ext==audacityExt) $ Path.dirFromFile base) . + Path.splitExtension + + +findAudacityProject :: + (PathClass.AbsRel ar) => Path.DirPath ar -> IO [Path.FilePath ar] +findAudacityProject = + let isAup = + Find.fileName ~~? ("*"++audacityExt) &&? + Find.depth ==? 2 &&? + (Find.fileType ==? Find.RegularFile ||? + Find.fileType ==? Find.SymbolicLink) + in fmap (map Path.path) . Find.find (Find.depth Path.DirPath ar -> IO Path.AbsDir +getOriginRoot input = do + let msg = "When searching for root directory of original recordings: " + let loop [] = + ioError $ userError $ + msg ++ "no Audacity project with pointers to original recordings found" + loop (aup:aups) = do + origs <- + originsFromRecordingTrack aup . TagParser.runSoup =<< + PathIO.readFile aup + case mapMaybe ME.toMaybe origs of + [] -> loop aups + (_, (_, orig)):_ -> + case Path.takeSuperDirectory <=< Path.takeSuperDirectory $ + Path.takeDirectory orig of + Nothing -> + ioError $ userError $ + printf "In %s found %s which has no second super directory" + (Path.toString aup) (Path.toString orig) + Just root -> return root + loop =<< findAudacityProject input diff --git a/src/Audacity/TrackName.hs b/src/Audacity/TrackName.hs new file mode 100644 --- /dev/null +++ b/src/Audacity/TrackName.hs @@ -0,0 +1,26 @@ +module Audacity.TrackName where + + +recording :: String +recording = "recording" + +classes :: String +classes = "classes" + +coarse :: String +coarse = "coarse" + +abstract :: String +abstract = "abstract" + +warnings :: String +warnings = "warnings" + +time :: String +time = "absolute times" + +hour :: String +hour = "hours" + +origin :: String +origin = "origin" diff --git a/src/Class.hs b/src/Class.hs new file mode 100644 --- /dev/null +++ b/src/Class.hs @@ -0,0 +1,233 @@ +module Class where + +import qualified Label + +import Control.DeepSeq (NFData, rnf) +import Control.Monad (mplus, mfilter) + +import qualified Data.Foldable as Fold +import qualified Data.List.HT as ListHT +import qualified Data.Map as Map; import Data.Map (Map) +import Data.String.HT (trim) +import Data.Maybe (fromMaybe) +import Data.Maybe.HT (toMaybe) +import Data.Char (isDigit) + + +data Sound rasping chirping ticking growling = + Other String + | Rasping rasping + | Chirping chirping + | Ticking ticking + | Growling growling + +instance + (NFData rasping, NFData chirping, NFData ticking, NFData growling) => + NFData (Sound rasping chirping ticking growling) where + rnf (Other str) = rnf str + rnf (Rasping dat) = rnf dat + rnf (Chirping dat) = rnf dat + rnf (Ticking dat) = rnf dat + rnf (Growling dat) = rnf dat + + +isPause :: Sound rasping chirping ticking growling -> Bool +isPause (Other str) = str == Label.pause +isPause _ = False + + +toName :: Sound rasping chirping ticking growling -> String +toName cl = + case cl of + Other str -> str + Rasping _ -> Label.rasping + Chirping _ -> Label.chirping + Ticking _ -> Label.ticking + Growling _ -> Label.growling + +toLabel :: Sound Int chirping Int Int -> String +toLabel cl = + case cl of + Other str -> str + Rasping numClicks -> Label.rasping ++ ' ' : show numClicks + Chirping _ -> Label.chirping + Ticking numClicks -> Label.ticking ++ ' ' : show numClicks + Growling numClicks -> Label.growling ++ ' ' : show numClicks + + +type SoundParsed = Sound String String String String + +fromLabel :: String -> SoundParsed +fromLabel lab = + fromMaybe (Other lab) $ + fmap (Rasping . trim) (ListHT.maybePrefixOf Label.rasping lab) + `mplus` + fmap (Chirping . trim) (ListHT.maybePrefixOf Label.chirping lab) + `mplus` + fmap (Ticking . trim) (ListHT.maybePrefixOf Label.ticking lab) + `mplus` + fmap (Growling . trim) (ListHT.maybePrefixOf Label.growling lab) + +strToLabel :: SoundParsed -> String +strToLabel cl = + let add ext str = if null ext then str else str ++ ' ' : ext + in case cl of + Other str -> str + Rasping str -> add Label.rasping str + Chirping str -> add Label.chirping str + Ticking str -> add Label.ticking str + Growling str -> add Label.growling str + + +data Purity = Pure | Rumble + deriving (Eq) + +type SoundPurity = Sound Purity Purity Purity Purity + +purityToName :: SoundPurity -> String +purityToName cl = + let ext p = + case p of + Pure -> "" + Rumble -> " rumble" + in case cl of + Other str -> str + Rasping p -> Label.rasping ++ ext p + Chirping p -> Label.chirping ++ ext p + Ticking p -> Label.ticking ++ ext p + Growling p -> Label.growling ++ ext p + +checkPurity :: SoundParsed -> SoundPurity +checkPurity cl = + fromMaybe (Other $ strToLabel cl) $ + let check cons p str = + toMaybe (str==Label.rumble) (cons Rumble) + `mplus` + toMaybe (p str) (cons Pure) + in case cl of + Other str -> Just $ Other str + Rasping str -> check Rasping (all isDigit) str + Chirping str -> check Chirping null str + Ticking str -> check Ticking (all isDigit) str + Growling str -> check Growling (all isDigit) str + +setRumble :: Bool -> SoundPurity -> SoundPurity +setRumble b cl = + let add r = if b then Rumble else r + in case cl of + Other str -> + Other $ + if b + then + if str == Label.pause + then Label.rumble + else str ++ ' ' : Label.rumble + else str + Rasping r -> Rasping $ add r + Chirping r -> Chirping $ add r + Ticking r -> Ticking $ add r + Growling r -> Growling $ add r + + +mapChirping :: + (chirping0 -> chirping1) -> + Sound rasping chirping0 ticking growling -> + Sound rasping chirping1 ticking growling +mapChirping f cl = + case cl of + Other str -> Other str + Rasping r -> Rasping r + Chirping ch -> Chirping $ f ch + Ticking t -> Ticking t + Growling g -> Growling g + +mapRasping :: + (rasping0 -> rasping1) -> + Sound rasping0 chirping ticking growling -> + Sound rasping1 chirping ticking growling +mapRasping f cl = + case cl of + Other str -> Other str + Rasping r -> Rasping $ f r + Chirping ch -> Chirping ch + Ticking t -> Ticking t + Growling g -> Growling g + +mapTicking :: + (ticking0 -> ticking1) -> + Sound rasping chirping ticking0 growling -> + Sound rasping chirping ticking1 growling +mapTicking f cl = + case cl of + Other str -> Other str + Rasping r -> Rasping r + Chirping ch -> Chirping ch + Ticking t -> Ticking $ f t + Growling g -> Growling g + +mapGrowling :: + (growling0 -> growling1) -> + Sound rasping chirping ticking growling0 -> + Sound rasping chirping ticking growling1 +mapGrowling f cl = + case cl of + Other str -> Other str + Rasping r -> Rasping r + Chirping ch -> Chirping ch + Ticking t -> Ticking t + Growling g -> Growling $ f g + + +maybeRasping :: Sound rasping chirping ticking growling -> Maybe rasping +maybeRasping cl = + case cl of + Rasping r -> Just r + _ -> Nothing + +maybeChirping :: Sound rasping chirping ticking growling -> Maybe chirping +maybeChirping cl = + case cl of + Chirping c -> Just c + _ -> Nothing + +maybeTicking :: Sound rasping chirping ticking growling -> Maybe ticking +maybeTicking cl = + case cl of + Ticking r -> Just r + _ -> Nothing + +maybeGrowling :: Sound rasping chirping ticking growling -> Maybe growling +maybeGrowling cl = + case cl of + Growling r -> Just r + _ -> Nothing + +maybeOther :: Sound rasping chirping ticking growling -> Maybe String +maybeOther cl = + case cl of + Other s -> Just s + _ -> Nothing + + +countOthers :: + (Fold.Foldable f) => + f (Sound rasping chirping ticking growling) -> Map String Int +countOthers = + Map.unionsWith (+) . + map (maybe Map.empty (flip Map.singleton 1) . + mfilter (flip notElem [Label.pause, Label.rumble]) . maybeOther) . + Fold.toList + + +data Abstract advert rasping chirping ticking growling = + NoAdvertisement (Sound rasping chirping ticking growling) + | Advertisement advert rasping (Maybe chirping) + + +abstractToLabel :: Abstract time Int chirping Int Int -> String +abstractToLabel cl = + case cl of + NoAdvertisement x -> toLabel x + Advertisement _ numClicks chirp -> + Label.advertisement ++ ' ' : show numClicks ++ + maybe " end" (const "") chirp diff --git a/src/ClassRecord.hs b/src/ClassRecord.hs new file mode 100644 --- /dev/null +++ b/src/ClassRecord.hs @@ -0,0 +1,45 @@ +module ClassRecord where + +import Control.DeepSeq (NFData, rnf) +import Control.Applicative (Applicative, pure, (<*>)) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import Data.Traversable (Traversable, traverse) +import Data.Foldable (Foldable, foldMap) + + +{- | +Columns in the generated spreadsheet tables +are sorted according to the order of the record fields. +-} +data T a = + Cons { + advertisement, rasping, chirping, ticking, growling :: a + } + +names :: T String +names = Cons "Advertisement" "Rasping" "Chirping" "Ticking" "Growling" + + +instance NFData a => NFData (T a) where + rnf = rnf . Fold.toList + +instance Functor T where + fmap = Trav.fmapDefault + +instance Foldable T where + foldMap = Trav.foldMapDefault + +instance Traversable T where + traverse f (Cons xAdvertisement xRasping xChirping xTicking xGrowling) = + pure Cons <*> f xAdvertisement + <*> f xRasping <*> f xChirping <*> f xTicking <*> f xGrowling + +instance Applicative T where + pure a = Cons a a a a a + Cons fAdvertisement fRasping fChirping fTicking fGrowling <*> + Cons xAdvertisement xRasping xChirping xTicking xGrowling = + Cons + (fAdvertisement xAdvertisement) (fRasping xRasping) + (fChirping xChirping) (fTicking xTicking) (fGrowling xGrowling) diff --git a/src/Durations.hs b/src/Durations.hs new file mode 100644 --- /dev/null +++ b/src/Durations.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE RebindableSyntax #-} +module Durations where + +import qualified ClassRecord +import qualified Class + +import qualified Sound.Audacity.LabelTrack as LabelTrack + +import Control.DeepSeq (NFData, rnf, force) +import Control.Applicative (Applicative, liftA2, pure, (<*>)) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import Data.Traversable (Traversable, traverse) +import Data.Foldable (Foldable, foldMap) + +import qualified Algebra.Additive as Additive +import NumericPrelude.Numeric hiding (sum) +import NumericPrelude.Base hiding (readFile, writeFile) + + +data T a = + Cons { + total :: a, + classes :: ClassRecord.T a + } + +names :: T String +names = Cons "Total" ClassRecord.names + +instance NFData a => NFData (T a) where + rnf (Cons totalDur classDurs) = rnf (totalDur, classDurs) + +instance Functor T where + fmap = Trav.fmapDefault + +instance Foldable T where + foldMap = Trav.foldMapDefault + +instance Traversable T where + traverse f (Cons totalDur classDurs) = + liftA2 Cons (f totalDur) (traverse f classDurs) + +instance Applicative T where + pure a = Cons a $ pure a + Cons fTotal fClasses <*> Cons totalDur classDurs = + Cons (fTotal totalDur) (fClasses <*> classDurs) + + +class Track f where + intervalSizes :: (Additive.C t) => f t a -> f t (t, a) + +-- ToDo: move to audacity +instance Track LabelTrack.T where + intervalSizes = + LabelTrack.mapWithTime (\bnds lab -> (uncurry subtract bnds, lab)) + + +sum :: + (Track f, Foldable (f Double)) => + f Double (Class.Abstract advert rasping chirping ticking growling) -> + T Double +sum = + Fold.foldl' + (\(Cons totalDur acc) (dur,cls) -> + let add r select set = set r $ select r + dur + in force $ Cons (totalDur+dur) $ + case cls of + Class.Advertisement _ _ _ -> + add acc ClassRecord.advertisement + (\r d -> r{ClassRecord.advertisement = d}) + Class.NoAdvertisement (Class.Rasping _) -> + add acc ClassRecord.rasping + (\r d -> r{ClassRecord.rasping = d}) + Class.NoAdvertisement (Class.Chirping _) -> + add acc ClassRecord.chirping + (\r d -> r{ClassRecord.chirping = d}) + Class.NoAdvertisement (Class.Ticking _) -> + add acc ClassRecord.ticking + (\r d -> r{ClassRecord.ticking = d}) + Class.NoAdvertisement (Class.Growling _) -> + add acc ClassRecord.growling + (\r d -> r{ClassRecord.growling = d}) + Class.NoAdvertisement (Class.Other _) -> acc) + (pure 0) . + intervalSizes diff --git a/src/Evaluation.hs b/src/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Evaluation.hs @@ -0,0 +1,304 @@ +module Evaluation ( + Result, + fromClicksFineIntervals, + fromGlobalRumbleSolo, + fromGlobalRumbleDuo, + ) where + +import qualified LabelTrack +import qualified LabelChain +import qualified SignalProcessingMethods as SPMethods +import qualified SignalProcessing as SP +import qualified Signal +import qualified Rate +import qualified Named +import qualified Class +import qualified Parameters as Params +import LabelChain (BreakRel(BreakRel), ) +import Parameters (Time(Time), getTime, ) +import Measurement + (ClassFeatures, ChunkFeatures, SpectralParameters, measureSignal, ) + +import qualified Control.Functor.HT as FuncHT +import Control.Monad (join, ) +import Control.Applicative ((<$>), ) +import Control.Functor.HT (void) + +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List.HT as ListHT +import Data.Tuple.HT (mapSnd, ) + +import Text.Printf (printf, ) + +import Algebra.ToRational (realToField) + +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + + +type SoundMeasure t = Class.Sound Int (BreakRel t) Int Int + + +doubleFromTime :: Time -> Double +doubleFromTime = realToField . Params.getTime + +_classFromClicksFloat :: + Params.T -> + LabelChain.T Double String -> + LabelChain.T Double (SoundMeasure Double) +_classFromClicksFloat params = + let skip :: (a -> a) -> (a -> a) + skip _ = id + in fmap + (Class.mapTicking SP.foldLength . + Class.mapRasping SP.foldLength . + Class.mapGrowling SP.foldLength) . + LabelChain.classRelativeFromAbsolute . + LabelChain.fuseTickingBouts join . + LabelChain.tickingsFromRaspings + (ListHT.lengthAtLeast (Params.raspingMinNumClicks params) . + NonEmpty.flatten) . + skip + (LabelChain.breakLongClicks + (realToField (Params.raspingMaxRelativeClickDistance params) *)) . + LabelChain.mergeRaspingGrowling + join (void . concatMap NonEmpty.flatten) . + LabelChain.classFromFineIntervals . + LabelChain.correctShortChirping + (doubleFromTime $ Params.chirpingHackDur params) . + skip + (LabelChain.mergeRaspingShortPause + (doubleFromTime $ Params.hardHighDist params)) + +classFromClicksInt :: + Params.T -> Rate.Sample -> + LabelChain.T Int String -> + LabelChain.T Int (SoundMeasure Int) +classFromClicksInt params rate = + let skip :: (a -> a) -> (a -> a) + skip _ = id + in fmap + (Class.mapTicking SP.foldLength . + Class.mapRasping SP.foldLength . + Class.mapGrowling SP.foldLength) . + LabelChain.classRelativeFromAbsolute . + LabelChain.fuseTickingBouts join . + LabelChain.tickingsFromRaspings + (ListHT.lengthAtLeast (Params.raspingMinNumClicks params) . + NonEmpty.flatten) . + skip + (LabelChain.breakLongClicks + (\median -> + ceiling $ + Params.raspingMaxRelativeClickDistance params + * fromIntegral median)) . + LabelChain.mergeRaspingGrowling + join (void . concatMap NonEmpty.flatten) . + LabelChain.classFromFineIntervals . + LabelChain.correctShortChirping + (Params.time rate $ Params.chirpingHackDur params) . + skip + (LabelChain.mergeRaspingShortPause + (Params.time rate $ Params.hardHighDist params)) + + +classLabelsFromChunkFeatures :: + ChunkFeatures -> + Class.Sound rasping chirping ticking growling -> SoundMeasure Int +classLabelsFromChunkFeatures + ((numClicks, _sumHalfLifes, _numEmphasized), chirpMain) cls = + + case cls of + Class.Rasping _ -> Class.Rasping numClicks + Class.Chirping _ -> Class.Chirping $ BreakRel chirpMain + Class.Ticking _ -> Class.Ticking numClicks + Class.Growling _ -> Class.Growling numClicks + Class.Other str -> Class.Other str + + +checkWarn :: Bool -> a -> [a] +checkWarn cond msg = if cond then [] else [msg] + +checkChirping :: Params.T -> (Double, Double) -> [String] +checkChirping params bnd = + let dur = Time $ realToFrac $ uncurry subtract bnd + minDur = Params.chirpingMinDur params + maxDur = Params.chirpingMaxDur params + in (checkWarn (dur >= minDur) $ + printf "duration must be at least %f" $ getTime minDur) + ++ + (checkWarn (dur <= maxDur) $ + printf "duration must be at most %f" $ getTime maxDur) + +checkTicking :: Int -> [String] +checkTicking numClicks = + checkWarn (numClicks > 0) "zero ticks" + +suspiciousIntervalsFromClicks :: + Params.T -> Rate.Sample -> + LabelTrack.T Double (ChunkFeatures, SoundMeasure Int) -> + LabelTrack.T Double String +suspiciousIntervalsFromClicks params highRate = + let measRate = Params.measureSampleRate params + in LabelTrack.concat . + LabelTrack.mapWithTime + (\bnd (((numClicks, _sumHalfLifes, _numEmphasized), chirpMain), cls) -> + case cls of + Class.Rasping n -> + let minNumClicks = Params.raspingMinNumClicks params + in (checkWarn (n == numClicks) $ + printf "deviating alternative click count: %d" n) + ++ + (checkWarn (numClicks >= minNumClicks) $ + printf "expected at least %d clicks" minNumClicks) + Class.Chirping (BreakRel brk) -> + let maxDev = Params.chirpingMainDurMaxDeviation params + brkTime = Params.toTime highRate brk + mainTime = Params.toTime measRate chirpMain + in checkChirping params bnd + ++ + (checkWarn + ((Time $ realToFrac $ abs $ brkTime-mainTime) + <= maxDev) $ + printf "deviating main duration: %f vs. %f" + brkTime mainTime) + Class.Growling n -> + (checkWarn (n == numClicks) $ + printf "deviating alternative click count: %d" n) + Class.Ticking n -> checkTicking n + _ -> []) + + +type Result = + (LabelChain.T Double (SoundMeasure Int), + LabelTrack.T Double String, + (Signal.LabelChain Rate.Measure + (SpectralParameters Float, ClassFeatures), + ([Float], Signal.T Rate.Measure [Named.Signal]))) + +fromClicks :: + SPMethods.T -> Params.T -> Signal.SoxLabelled (SoundMeasure Int) -> Result +fromClicks sigProc params labelled = + let (sig, classified) = FuncHT.unzip labelled + (chunkFeats, measuresEnvelopes) = measureSignal sigProc params labelled + classifiedMeas = + LabelChain.zipWithList (,) chunkFeats $ + Signal.labelRealTimes classified + in (fmap (uncurry classLabelsFromChunkFeatures) classifiedMeas, + suspiciousIntervalsFromClicks params (Signal.sampleRate sig) $ + LabelTrack.fromLabelChain classifiedMeas, + measuresEnvelopes) + +fromClicksFineIntervals :: + SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result +fromClicksFineIntervals sigProc params sig = + fromClicks sigProc params $ + fmap (mapSnd (classFromClicksInt params (Signal.sampleRate sig))) sig + + +suspiciousIntervalsFromGlobal :: + Params.T -> + LabelTrack.T Double (Class.Sound rasping chirping Int growling) -> + LabelTrack.T Double String +suspiciousIntervalsFromGlobal params = + LabelTrack.concat . + LabelTrack.mapWithTime + (\bnd cls -> + case cls of + Class.Chirping _ -> checkChirping params bnd + Class.Ticking numClicks -> checkTicking numClicks + _ -> []) + + +countClicksGlobal :: + SPMethods.T -> Params.T -> + Signal.SoxLabelled (Class.Sound rasping chirping ticking growling) -> + LabelChain.T Double (Class.Sound Int (BreakRel Int) Int Int) +countClicksGlobal sigProc params sigClassified = + {- ToDo: + comparison could be made more lazy + using lazy chunky numbers from non-negative package + -} + LabelChain.mergeRaspingGrowling NonEmpty.sum sum $ + LabelChain.zipWithList classLabelsFromChunkFeatures + (fst $ measureSignal sigProc params sigClassified) $ + Signal.labelRealTimes $ fmap snd sigClassified + +{- | +Works on sequences like rasping-rumble-rasping. +-} +classFromGlobalRumbleSolo :: + SPMethods.T -> Params.T -> Signal.SoxLabelled String -> + (LabelTrack.T Double String, + LabelChain.T Double (SoundMeasure Int)) +classFromGlobalRumbleSolo sigProc params sigClassified = + let (rumbling, classifiedMeas) = + LabelChain.unzipRumbling $ + {- + The NonEmpty.head selects the information of the first chirping chunk. + That carries a BreakRel value that becomes rather arbitrary + after merging chirping with rumble. + -} + LabelChain.assimilateRumblingSolo + NonEmpty.sum NonEmpty.head NonEmpty.sum + (doubleFromTime $ Params.maxInterimRumblingDur params) $ + countClicksGlobal sigProc params $ + fmap (mapSnd (fmap Class.fromLabel)) sigClassified + in (rumbling, + LabelChain.fuseTickingBouts NonEmpty.sum $ + LabelChain.tickingsFromRaspings + (Params.raspingMinNumClicks params <=) $ + classifiedMeas) + +{- | +Works on sequences like rasping-raspingRumble-rasping. +-} +classFromGlobalRumbleDuo :: + SPMethods.T -> Params.T -> Signal.SoxLabelled String -> + (LabelTrack.T Double String, + LabelChain.T Double (SoundMeasure Int)) +classFromGlobalRumbleDuo sigProc params sigClassified = + let sigRumbleClassified = + mapSnd + (LabelChain.unzipRumbling . + LabelChain.assimilateRumblingDuo . + fmap (Class.checkPurity . Class.fromLabel)) + <$> + sigClassified + in (LabelTrack.mergeNamesakes $ + LabelTrack.realTimes $ fst . snd <$> sigRumbleClassified, + LabelChain.fuseTickingBouts NonEmpty.sum $ + LabelChain.tickingsFromRaspings (Params.raspingMinNumClicks params <=) $ + countClicksGlobal sigProc params $ + mapSnd snd <$> sigRumbleClassified) + +{- ToDo: +Is it possible and sensible to split measureSignal, +such that we need to call it only once? +-} +fromGlobal :: + SPMethods.T -> Params.T -> Signal.Sox -> + (LabelTrack.T Double String, LabelChain.T Double (SoundMeasure Int)) -> + Result +fromGlobal sigProc params sig (rumbling, classifiedMeas) = + (classifiedMeas, + LabelTrack.merge + (suspiciousIntervalsFromGlobal params + (LabelTrack.fromLabelChain classifiedMeas)) + rumbling, + snd $ measureSignal sigProc params $ + Signal.addDiscretizedLabels sig classifiedMeas) + +fromGlobalRumbleSolo :: + SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result +fromGlobalRumbleSolo sigProc params labelled = + fromGlobal sigProc params (fmap fst labelled) $ + classFromGlobalRumbleSolo sigProc params labelled + +fromGlobalRumbleDuo :: + SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result +fromGlobalRumbleDuo sigProc params labelled = + fromGlobal sigProc params (fmap fst labelled) $ + classFromGlobalRumbleDuo sigProc params labelled diff --git a/src/Feature.hs b/src/Feature.hs new file mode 100644 --- /dev/null +++ b/src/Feature.hs @@ -0,0 +1,788 @@ +{-# LANGUAGE RebindableSyntax #-} +module Feature ( + Class(..), + lowRateSqrt, + dictionaryMerged, + + HMM(..), + readHMM, + writeHMM, + hmmHardwired, + ) where + +import qualified HiddenMarkovModel.Hardwired as HMMHard +import qualified HiddenMarkovModel as HMM +import qualified Math.HiddenMarkovModel.Named as HMMNamed + +import qualified Evaluation +import qualified LabelChain +import qualified LabelChainShifted +import qualified LabelTrack +import qualified Label +import qualified Signal +import qualified Rate +import qualified Named +import qualified Class +import qualified Parameters as Params +import Parameters (Freq(Freq), formatFreq, Time(Time), timeCeil, ) + +import qualified SignalProcessingMethods as SPMethods +import qualified SignalProcessingSpecific as SPS +import SignalProcessingSpecific + (bandEnvelopes, bandEnvelopesLowRate, dehum, ) +import SignalProcessing + (differentiate, differentiateMin3, differentiateMin3Init, + bandpass, lowpassTwoPass, centroidVariance3, + downSampleMax, downSampleMaxFrac, sliceOverlapping, ) + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Basic.Binary as Bin + +import qualified Data.StorableVector.Lazy as SVL + +import qualified Control.Monad.Exception.Synchronous as ME +import qualified Control.Functor.HT as FuncHT +import Control.Arrow ((^<<), (<<^), ) +import Control.Monad (liftM2, ) +import Control.Applicative ((<$>), ) + +import qualified Data.List.Reverse.StrictElement as Rev +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import qualified Data.Char as Char +import Data.Map (Map, ); import qualified Data.Map as Map +import Data.Set (Set, ); import qualified Data.Set as Set +import Data.Bool.HT (if', ) +import Data.Maybe (isJust, ) + +import qualified System.Path.PartClass as PathClass +import qualified System.Path.IO as PathIO +import qualified System.Path as Path + +import qualified Text.CSV.Lazy.String as CSV +import Text.Printf (printf, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +data Class = + Class { + name :: [String], + signals :: + SPMethods.T -> Signal.Sox -> Signal.T Rate.Feature [Named.Signal], + scale :: [Float], + fineSnappedFromCoarseIntervals :: + Params.T -> Rate.Feature -> Signal.Sox -> + LabelTrack.T Double Class.SoundParsed -> + ME.Exceptional String (LabelChain.T Int String), + evaluateFromIntervals :: + SPMethods.T -> Params.T -> + Signal.SoxLabelled String -> Evaluation.Result, + admissibleTransitions :: Set (String, String) + } + + +bandName :: [String] +bandName = ["band", "1200Hz", "2000Hz"] + +highRate :: Class +highRate = + Class { + name = bandName ++ ["high rate"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = repeat 0.1, + signals = + \_methods sig@(Signal.Cons rate _) -> + let (_volume, (relEnv12, relEnv20, _relEnv40)) = bandEnvelopes sig + in Signal.Cons (Rate.featureFromSample rate) [relEnv12, relEnv20] + } + + +data HMM = + HMM { + hmmClass :: Class, + hmmodel :: HMMNamed.Gaussian Double + } + +hmmHardwired :: HMM +hmmHardwired = + HMM { + hmmClass = + Class { + name = ["band", "2000Hz"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = repeat 0.1, + signals = \_methods sig@(Signal.Cons rate _) -> + let (_volume, (_relEnv12, relEnv20, _relEnv40)) = + bandEnvelopes sig + in Signal.Cons (Rate.featureFromSample rate) [relEnv20] + }, + hmmodel = HMMHard.hmmNamed + } + + + +reduceSampleRate :: Int -> Rate.Feature -> Rate.Feature +reduceSampleRate k (Rate.Feature rate) = Rate.Feature $ rate / fromIntegral k + + +formatRate :: Rate.Feature -> String +formatRate = printf "%.0fHz" . Rate.unpack + +lowRate :: Rate.Feature -> Class +lowRate rate = + Class { + name = bandName ++ ["low rate", formatRate rate], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = repeat 0.1, + signals = \_methods sig -> + let (_volume, (relEnv12, relEnv20, _relEnv40)) = + bandEnvelopesLowRate rate sig + in Signal.Cons rate [relEnv12, relEnv20] + } + +{- | +Computes the square root of all values +in order to compress high values and expand low values. +This way the emission clusters better fit to the normal distribution. +-} +lowRateSqrt :: Rate.Feature -> Class +lowRateSqrt rate = + Class { + name = bandName ++ ["low rate", formatRate rate, "sqrt"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = repeat (1/3), + signals = \_methods sig -> + let (_volume, (relEnv12, relEnv20, _relEnv40)) = + bandEnvelopesLowRate rate sig + in Signal.Cons rate $ map (fmap (SVL.map sqrt)) [relEnv12, relEnv20] + } + + +attackSignal :: + Rate.Feature -> Signal.Sox -> + (Named.Signal, Named.Signal, Named.Signal, + (Named.Signal, Named.Signal), + (Named.Signal, Named.Signal)) +attackSignal featRate sig = + let rate = Signal.sampleRate sig + dehummed = + Causal.apply (dehum rate <<^ Bin.toCanonical) $ Signal.body sig + envelope = + downSampleMaxFrac (Rate.ratio rate featRate) $ SVL.map abs dehummed + volFreq = Freq 20 + volume = lowpassTwoPass featRate volFreq envelope + relEnv = SVL.zipWith (/) envelope volume + relEnvDiff = Causal.apply differentiate relEnv + band bandFreq = + lowpassTwoPass featRate volFreq $ + downSampleMaxFrac (Rate.ratio rate featRate) $ + Causal.apply (abs ^<< bandpass rate 10 bandFreq) dehummed + relEnvBand f = + Named.Cons ("band " ++ formatFreq f) $ SVL.zipWith (/) (band f) volume + g0 = 1200; g1 = 2000 + centroid = + SVL.zipWith + (\x0 x1 -> ((g0*x0 + g1*x1) / (x0+x1) * 2 - (g0+g1)) / (g1-g0)) + (band (Freq g0)) + (band (Freq g1)) + f0 = 1000; f1 = 2500; f2 = 4000 + spread = + SVL.zipWith3 + (\x0 x1 x2 -> + snd (centroidVariance3 (f0,x0) (f1,x1) (f2,x2)) * (2 / (f2-f0))^2) + (band (Freq f0)) + (band (Freq f1)) + (band (Freq f2)) + in (Named.Cons "envelope" relEnv, + Named.Cons "differentiated envelope" relEnvDiff, + Named.Cons "variance of envelope" $ + lowpassTwoPass featRate volFreq $ SVL.map abs relEnvDiff, + (relEnvBand $ Freq 1200, relEnvBand $ Freq 2000), + (Named.Cons "centroid" centroid, Named.Cons "spread" spread)) + +attacks :: Rate.Feature -> Class +attacks rate = + Class { + name = ["attacks", formatRate rate], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1/2, 1], + signals = \_methods sig -> + let (_relEnv, relEnvDiff, variance, _relVol, _spectral) = + attackSignal rate sig + in Signal.Cons rate [relEnvDiff, variance] + } + +attacksClipped :: Rate.Feature -> Class +attacksClipped rate = + Class { + name = ["attacks", formatRate rate, "clipped"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1, 1], + signals = \_methods sig -> + let (_relEnv, relEnvDiff, variance, _relVol, _spectral) = + attackSignal rate sig + -- (limit (0,1)) would cause a singular matrix in unsupervised training + softLimit x = + if' (x<0) (x/10) $ + if' (x>1) ((x+9)/10) $ + x + in Signal.Cons rate [fmap (SVL.map softLimit) relEnvDiff, variance] + } + +attacksDelayed :: Rate.Feature -> Class +attacksDelayed rate = + Class { + name = ["attacks", formatRate rate, "delayed"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1/2, 1/2, 1], + signals = \_methods sig -> + let (relEnv, _relEnvDiff, variance, _relVol, _spectral) = + attackSignal rate sig + in Signal.Cons rate + [relEnv, + Named.apply "delayed" + (Causal.apply (Causal.consInit zero)) relEnv, + variance] + } + + +attacksFromEnv :: Named.Signal -> Named.Signal +attacksFromEnv = Named.apply "attacks" (Causal.apply differentiateMin3) + +attackSignalMin3 :: + Rate.Feature -> Signal.Sox -> (Named.Signal, Named.Signal, Named.Signal) +attackSignalMin3 featRate sig = + let (relEnv, _relEnvDiff, _variance, _relVol, (_centroid, spread)) = + attackSignal featRate sig + in (relEnv, attacksFromEnv relEnv, spread) + +attacksMin3Spread :: Rate.Feature -> Class +attacksMin3Spread rate = + Class { + name = ["attacks", formatRate rate, "min3", "spread"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1/2, 1], + signals = \_methods sig -> + let (_relEnv, relEnvDiff, spread) = attackSignalMin3 rate sig + in Signal.Cons rate [relEnvDiff, spread] + } + +attacksMin3SpreadSat :: Rate.Feature -> Class +attacksMin3SpreadSat rate = + Class { + name = ["attacks", formatRate rate, "min3", "spread", "sat"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1/2, 1], + signals = \_methods sig -> + let (_relEnv, relEnvDiff, spread) = attackSignalMin3 rate sig + in Signal.Cons rate [fmap (SVL.map saturationRat) relEnvDiff, spread] + } + +attacksMin3Band :: Rate.Feature -> Class +attacksMin3Band rate = + Class { + name = ["attacks", formatRate rate, "min3", "band", "2000hz"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1/2, 1/10], + signals = \_methods sig -> + let (relEnv, _relEnvDiff, _variance, (_relEnv12, relEnv20), _spectral) = + attackSignal rate sig + in Signal.Cons rate [attacksFromEnv relEnv, relEnv20] + } + +attacksMin3BandSat :: Rate.Feature -> Class +attacksMin3BandSat rate = + Class { + name = ["attacks", formatRate rate, "min3", "band", "2000hz", "sat"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1/2, 1/10], + signals = \_methods sig -> + let (relEnv, _relEnvDiff, _variance, (_relEnv12, relEnv20), _spectral) = + attackSignal rate sig + in Signal.Cons rate + [fmap (Causal.apply (saturationRat ^<< differentiateMin3)) relEnv, + relEnv20] + } + +attacksMin3Bands :: Rate.Feature -> Class +attacksMin3Bands rate = + Class { + name = ["attacks", formatRate rate, "min3", "band", "1200hz", "2000hz"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1/2, 1/10, 1/10], + signals = \_methods sig -> + let (relEnv, _relEnvDiff, _variance, (relEnv12, relEnv20), _spectral) = + attackSignal rate sig + in Signal.Cons rate [attacksFromEnv relEnv, relEnv12, relEnv20] + } + +attacksMin3BandsSat :: Rate.Feature -> Class +attacksMin3BandsSat rate = + Class { + name = ["attacks", formatRate rate, "min3", "band", "1200hz", "2000hz", "sat"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [1/2, 1/10, 1/10], + signals = \_methods sig -> + let (relEnv, _relEnvDiff, _variance, (relEnv12, relEnv20), _spectral) = + attackSignal rate sig + in Signal.Cons rate + [fmap (Causal.apply (saturationRat ^<< differentiateMin3)) relEnv, + relEnv12, relEnv20] + } + + +attackBandsSignal :: Rate.Feature -> Signal.Sox -> (Named.Signal, Named.Signal) +attackBandsSignal featRate sig = + let rate = Signal.sampleRate sig + dehummed = + Causal.apply (dehum rate <<^ Bin.toCanonical) $ Signal.body sig + band f = + downSampleMaxFrac (Rate.ratio rate featRate) $ + Causal.apply (abs ^<< bandpass rate 10 f) dehummed + volume = + lowpassTwoPass featRate (Freq 20) $ + downSampleMaxFrac (Rate.ratio rate featRate) $ SVL.map abs dehummed + relEnv f = + Named.Cons ("band " ++ formatFreq f) $ SVL.zipWith (/) (band f) volume + in (relEnv $ Freq 1200, relEnv $ Freq 2000) + +attacksBandsMin3 :: Rate.Feature -> Class +attacksBandsMin3 rate = + Class { + name = ["attacks", "1200Hz", "2000Hz", "low rate", formatRate rate, "min3"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [0.1, 0.1], + signals = \_methods sig -> + let (relEnv12, relEnv20) = attackBandsSignal rate sig + in Signal.Cons rate + [attacksFromEnv relEnv12, attacksFromEnv relEnv20] + } + +attacksBandsMin3Sqrt :: Rate.Feature -> Class +attacksBandsMin3Sqrt rate = + Class { + name = ["attacks", "1200Hz", "2000Hz", "low rate", formatRate rate, "min3", "sqrt"], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, + evaluateFromIntervals = Evaluation.fromClicksFineIntervals, + admissibleTransitions = HMM.admissibleTransitionSet, + scale = [0.1, 0.1], + signals = \_methods sig -> + let (relEnv12, relEnv20) = attackBandsSignal rate sig + in Signal.Cons rate + [Named.apply "attacks" + (Causal.apply (posSqrt ^<< differentiateMin3)) relEnv12, + Named.apply "attacks" + (Causal.apply (posSqrt ^<< differentiateMin3)) relEnv20] + } + +posSqrt :: Float -> Float +posSqrt x = if x>0 then sqrt x else x + +{- +Saturation function helps to separate high and low values +and concentrate the high values. +Otherwise some negative values are associated with the broad cloud of high values. +-} +{- +easier to write, but less efficient +-} +_saturationTanh :: Float -> Float +_saturationTanh x = tanh (x-0.5) + 0.5 + +{- +not as steep as tanh, but can be vectorised +-} +saturationRat :: Float -> Float +saturationRat x = satRat (x-0.5) + 0.5 + +satRat :: Float -> Float +satRat x = x/(1+abs x) + + +globalBandsSignal :: + SPMethods.T -> Rate.Feature -> Int -> Int -> Signal.Sox -> + (Named.Signal, Named.Signal, Named.Signal) +globalBandsSignal methods featRate blockSize preSize sig = + let band f = + SPMethods.bandpassDownSample methods + (reduceSampleRate blockSize featRate) f sig + (volume, relDehum) = + SPMethods.dehummedEnvelopeLowRate methods featRate sig + volumeDown = downSampleMax blockSize volume + relEnv f = + Named.Cons ("band " ++ formatFreq f) $ + SVL.zipWith (/) (band f) volumeDown + + maxAttacks = + Named.Cons "attack" $ + SigG.fromList SigG.defaultLazySize $ fmap SVL.maximum $ + sliceOverlapping blockSize (preSize, 0) $ + Causal.apply + (differentiateMin3Init $ SVL.switchL zero const relDehum) $ + relDehum + in (maxAttacks, relEnv $ Freq 1200, relEnv $ Freq 2000) + +globalBands :: Rate.Feature -> Int -> Int -> Class +globalBands rate blockSize preSize = + Class { + name = + ["global", "1200Hz", "2000Hz", "low rate", formatRate rate, + "block size", show blockSize], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsGlobal, + evaluateFromIntervals = Evaluation.fromGlobalRumbleDuo, + admissibleTransitions = + let states = + [Label.pause, Label.rasping, Label.chirping, Label.growling] + in Set.fromList $ liftM2 (,) states states, + scale = [1/3, 0.1, 0.1], + signals = \methods sig -> + let (maxAttacks, relEnv12, relEnv20) = + globalBandsSignal methods rate blockSize preSize sig + in Signal.Cons (reduceSampleRate blockSize rate) + [maxAttacks, relEnv12, relEnv20] + } + +globalBandsSqrt :: Rate.Feature -> Int -> Int -> Class +globalBandsSqrt rate blockSize preSize = + let cls = globalBands rate blockSize preSize + in cls { + name = name cls ++ ["sqrt"], + signals = \methods sig -> + map (SVL.map sqrt <$>) <$> signals cls methods sig + } + + +{- | +List must be non-empty, but we have no benefit from using NonEmpty.T. +-} +positiveOffset :: (Ord a) => [a] -> a +positiveOffset xs = List.sort xs !! div (length xs) 32 + +removePositiveOffset :: SVL.Vector Float -> SVL.Vector Float +removePositiveOffset xs = + SVL.map (subtract $ positiveOffset $ SVL.unpack xs) xs + +globalBandsRumbleSignal :: + SPMethods.T -> Rate.Feature -> Int -> Signal.Sox -> + (Named.Signal, Named.Signal, Named.Signal, Named.Signal) +globalBandsRumbleSignal methods featRate blockSize sig = + let band f = + SPMethods.bandpassDownSample methods + (reduceSampleRate blockSize featRate) f sig + (volume, relDehum) = + SPMethods.dehummedEnvelopeLowRate methods featRate sig + volumeDown = downSampleMax blockSize volume + relEnv f = + Named.Cons ("band " ++ formatFreq f) $ + SVL.zipWith (/) (band f) volumeDown + + {- + We do not normalize the rumbling track with the volume + because we expect that rumble always occur directly at the microphone + and thus should have similar amplitude. + The rumbles might still differ in amplitude + and microphones might be calibrated differently. + We weaken this influence by taking square roots. + Additionally we remove the influence of background noise + by subtracting a low quantile of the rumble signal. + -} + rumblingEnv = + Named.Cons "rumbling" $ + removePositiveOffset $ SVL.map sqrt $ + SPMethods.downSampleAbs methods + (Rate.unpack featRate / fromIntegral blockSize) $ + SPMethods.rumble methods sig + + maxAttacks = + Named.Cons "attack" $ + SigG.fromList SigG.defaultLazySize $ fmap SVL.maximum $ + sliceOverlapping blockSize (blockSize, 0) $ + Causal.apply + (differentiateMin3Init $ SVL.switchL zero const relDehum) $ + relDehum + in (maxAttacks, rumblingEnv, relEnv $ Freq 1200, relEnv $ Freq 2000) + +globalBandsRumbleSolo :: Rate.Feature -> Int -> Class +globalBandsRumbleSolo rate blockSize = + Class { + name = + ["global", "rumble", "solo", "1200Hz", "2000Hz", + "low rate", formatRate rate, "block size", show blockSize], + fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsGlobal, + evaluateFromIntervals = Evaluation.fromGlobalRumbleSolo, + admissibleTransitions = + let states = + [Label.pause, Label.rumble, + Label.rasping, Label.chirping, Label.growling] + in Set.fromList $ liftM2 (,) states states, + scale = [1/3, 1, 0.1, 0.1], + signals = \methods sig -> + let (maxAttacks, relRumbleEnv, relEnv12, relEnv20) = + globalBandsRumbleSignal methods rate blockSize sig + in Signal.Cons (reduceSampleRate blockSize rate) + [maxAttacks, relRumbleEnv, relEnv12, relEnv20] + } + +globalBandsRumbleDuo :: Rate.Feature -> Int -> Class +globalBandsRumbleDuo rate blockSize = + Class { + name = + ["global", "rumble", "duo", "1200Hz", "2000Hz", + "low rate", formatRate rate, "block size", show blockSize], + fineSnappedFromCoarseIntervals = + fineSnappedFromCoarseIntervalsGlobalRumble, + evaluateFromIntervals = Evaluation.fromGlobalRumbleDuo, + admissibleTransitions = + let states = + [Label.pause, Label.rasping, Label.chirping, Label.growling, + Label.rumble, Label.raspingRumble, + Label.chirpingRumble, Label.growlingRumble] + in Set.fromList $ liftM2 (,) states states, + scale = [1/3, 1, 0.1, 0.1], + signals = \methods sig -> + let (maxAttacks, relRumbleEnv, relEnv12, relEnv20) = + globalBandsRumbleSignal methods rate blockSize sig + in Signal.Cons (reduceSampleRate blockSize rate) + [maxAttacks, relRumbleEnv, relEnv12, relEnv20] + } + +tickingToRasping :: + Class.Sound ticking chirping ticking growling -> + Class.Sound ticking chirping ticking growling +tickingToRasping cls = + case cls of + Class.Ticking x -> Class.Rasping x + _ -> cls + +liftExc :: + Rate.C rate => + (rate -> signal -> LabelChain.T Int a -> b) -> + rate -> signal -> LabelTrack.T Double a -> ME.Exceptional String b +liftExc f rate sig = + fmap (f rate sig . Signal.body) . LabelTrack.discretizeTrack rate + +fineSnappedFromCoarseIntervalsGlobal :: + Params.T -> Rate.Feature -> Signal.Sox -> + LabelTrack.T Double (Class.Sound rasping chirping rasping growling) -> + ME.Exceptional String (LabelChain.T Int String) +fineSnappedFromCoarseIntervalsGlobal _params = liftExc $ \ _rate _sig -> + fmap (Class.toName . tickingToRasping) + + +{- | +Turn overlapping "+rumble" labels into combined labels like "rasping rumble". +-} +mergeRumble :: + (Rate.C rate) => + rate -> + LabelTrack.T Double Class.SoundParsed -> + ME.Exceptional String (LabelChain.T Int Class.SoundPurity) +mergeRumble rate track = do + let (rumble, labels) = + FuncHT.unzip $ + LabelTrack.partition + ((Just Label.overlayedRumble ==) . Class.maybeOther) <$> + LabelTrack.discretizeTimes rate (Class.checkPurity <$> track) + sortedRumble <- LabelTrack.checkOverlap rumble + fmap (\(maybeRumble, cls) -> Class.setRumble (isJust maybeRumble) cls) . + LabelChainShifted.shiftToLabelChain . + LabelChainShifted.subdivideTrack (Signal.body sortedRumble) . + LabelChainShifted.fromLabelChain . Signal.body + <$> LabelTrack.checkGaps labels + +fineSnappedFromCoarseIntervalsGlobalRumble :: + Params.T -> Rate.Feature -> Signal.Sox -> + LabelTrack.T Double Class.SoundParsed -> + ME.Exceptional String (LabelChain.T Int String) +fineSnappedFromCoarseIntervalsGlobalRumble _params rate _sig = + fmap (fmap (Class.purityToName . tickingToRasping)) . mergeRumble rate + +_fineFromCoarseIntervalsBand20 :: + Params.T -> Rate.Feature -> SVL.Vector Float -> + LabelChain.T Int (Class.Sound rasping chirping ticking growling) -> + LabelChain.T Int String +_fineFromCoarseIntervalsBand20 _params rate = + LabelChain.fineFromCoarseIntervalsInt + (case 3::Int of + 0 -> LabelChain.detectClicksExtrema + (timeCeil rate (Time 0.01), + timeCeil rate (Time 0.03)) + 1 -> LabelChain.detectClicksThreshold 2.5 + 2 -> LabelChain.detectClicksLaxMonotony (1.0,1.0) + _ -> LabelChain.detectClicksWeakMonotony (3,3) 0.5) + {- + Threshold 0.5 gives a better separation + of the emission clusters of r0 and r1, + especially in the 1.2 kHz band, + than a higher threshold like 0.7. + However the low threshold risks to leave an empty click end phase. + -} + +fineFromCoarseIntervalsEnv :: + Params.T -> Rate.Feature -> SVL.Vector Float -> + LabelChain.T Int (Class.Sound rasping chirping ticking growling) -> + LabelChain.T Int String +fineFromCoarseIntervalsEnv params _rate = + LabelChain.fineFromCoarseIntervalsInt + (LabelChain.detectClicksWeakMonotony + (Params.weakCounterSlopeSizes params) 0.5) + +_fineSnappedFromCoarseIntervalsBand20 :: + Params.T -> Rate.Feature -> Signal.Sox -> + LabelChain.T Int (Class.Sound rasping chirping ticking growling) -> + LabelChain.T Int String +_fineSnappedFromCoarseIntervalsBand20 params rate sig = + let (_volume, (_relEnv12, Named.Cons _ relEnv20, _relEnv40)) = + bandEnvelopesLowRate rate sig + in _fineFromCoarseIntervalsBand20 params rate relEnv20 . + LabelChain.snapBoundaries relEnv20 + +{- | +This should be prefered to '_fineSnappedFromCoarseIntervalsBand20' +since it also works if the 2 kHz band is weak, e.g. in growling sounds. +-} +fineSnappedFromCoarseIntervalsEnv :: + Params.T -> Rate.Feature -> Signal.Sox -> + LabelTrack.T Double (Class.Sound rasping chirping ticking growling) -> + ME.Exceptional String (LabelChain.T Int String) +fineSnappedFromCoarseIntervalsEnv params = liftExc $ \ rate sig -> + let (_volume, env) = + SPMethods.dehummedEnvelopeLowRate SPS.methods rate sig + in fineFromCoarseIntervalsEnv params rate env . + LabelChain.snapBoundaries env + + +fineSnappedFromCoarseIntervalsDiff :: + Params.T -> Rate.Feature -> Signal.Sox -> + LabelTrack.T Double (Class.Sound rasping chirping ticking growling) -> + ME.Exceptional String (LabelChain.T Int String) +fineSnappedFromCoarseIntervalsDiff _params = liftExc $ \ rate sig -> + let (Named.Cons _ relEnv, Named.Cons _ relEnvDiff, + _variance, _relVol, _spectral) = + attackSignal rate sig + in LabelChain.fineFromCoarseIntervalsInt2 + (LabelChain.detectClicksDiff 0.2 0.8) relEnv relEnvDiff . + LabelChain.snapBoundaries relEnv + +fineSnappedFromCoarseIntervalsMin3 :: + Params.T -> Rate.Feature -> Signal.Sox -> + LabelTrack.T Double (Class.Sound rasping chirping ticking growling) -> + ME.Exceptional String (LabelChain.T Int String) +fineSnappedFromCoarseIntervalsMin3 _params = liftExc $ \ rate sig -> + let (Named.Cons _ relEnv, Named.Cons _ relEnvDiff, _variance) = + attackSignalMin3 rate sig + in LabelChain.fineFromCoarseIntervalsInt2 + (LabelChain.detectClicksThreshold 0.5) relEnv relEnvDiff . + LabelChain.snapBoundaries relEnv + + + +dictionary :: Map [String] Class +dictionary = + Map.fromList $ + map (\cls -> (name cls, cls)) $ + let featRate = Rate.Feature 200 + in highRate : + lowRate featRate : + lowRateSqrt featRate : + attacks featRate : + attacksClipped featRate : + attacksDelayed featRate : + attacksMin3Spread featRate : + attacksMin3SpreadSat featRate : + attacksMin3Band featRate : + attacksMin3BandSat featRate : + attacksMin3Bands featRate : + attacksMin3BandsSat featRate : + attacksBandsMin3 featRate : + attacksBandsMin3Sqrt featRate : + globalBands featRate 5 5 : + globalBands featRate 10 0 : + globalBands featRate 20 0 : + globalBandsSqrt featRate 5 5 : + globalBandsRumbleSolo featRate 5 : + globalBandsRumbleDuo featRate 5 : + [] + +mergeName :: [String] -> String +mergeName = + let lower c = + case c of + ' ' -> '-' + _ -> Char.toLower c + in List.intercalate "-" . map (map lower) + +dictionaryMerged :: Map String Class +dictionaryMerged = Map.mapKeys mergeName dictionary + + +readHMM :: (PathClass.AbsRel ar) => Path.File ar -> IO HMM +readHMM path = do + content <- PathIO.readFile path + case ListHT.breakAfter ('\n'==) content of + (featureRow, model) -> + ME.resolveT (ioError . userError) $ ME.ExceptionalT $ return $ do + hmmNamed <- HMMNamed.fromCSV model + featureDescr <- + case CSV.parseCSV featureRow of + [header] -> + fmap (Rev.dropWhile null . map CSV.csvFieldContent) $ + ME.mapException + (unlines . ("when parsing header:" :) . + map CSV.ppCSVError) $ + ME.fromEither header + _ -> error "CSV parsing of a row should produce exactly one row" + let notFoundMsg = + unlines $ + ("unknown feature set: " ++ featureRow) : + "known sets:" : + (map show $ Map.keys dictionary) + feature <- + ME.fromMaybe notFoundMsg $ + Map.lookup featureDescr dictionary + return $ + HMM { + hmmClass = feature, + hmmodel = hmmNamed + } + +writeHMM :: (PathClass.AbsRel ar) => Path.File ar -> HMM -> IO () +writeHMM path featureHMM = + PathIO.writeFile path $ toCSV featureHMM + +toCSV :: HMM -> String +toCSV featureHMM = + (CSV.ppCSVTable $ snd $ CSV.toCSVTable [name $ hmmClass featureHMM]) + ++ + (HMMNamed.toCSV $ hmmodel featureHMM) diff --git a/src/Fourier.hs b/src/Fourier.hs new file mode 100644 --- /dev/null +++ b/src/Fourier.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE RebindableSyntax #-} +module Fourier where + +import qualified Math.FFT as FFT + +import qualified Synthesizer.Generic.Analysis as Ana + +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.CArray as SVCArr + +import qualified Data.Array.CArray as CArray +import qualified Data.Array.IArray as IArray +import Data.Array.CArray (CArray) +import Data.Array.IArray ((//), (!)) +import Data.Tuple.HT (mapFst) + +import Foreign.Storable (Storable) + +import Control.Monad (liftM2) + +import qualified Data.Complex as Complex + +import qualified Algebra.IntegralDomain as Integral +import qualified Algebra.Additive as Additive +import qualified Algebra.Ring as Ring +import NumericPrelude +import Prelude () + + +-- see synthesizer-core:Synthesizer.Basic.NumberTheory +{- | +It's not awfully efficient, but ok for our uses. +-} +ceilingPower :: (Integral.C a, Ord a) => a -> a -> a +ceilingPower base n = base ^ fromIntegral (ceilingLog base n) + +ceilingLog :: (Integral.C a, Ord a) => a -> a -> Int +ceilingLog base = + length . takeWhile (>0) . iterate (flip div base) . subtract 1 + + +{- | +It must hold @transformSize > chunkSize@. +-} +layoutBlocks :: Int -> Int -> SV.Vector Float -> CArray (Int, Int) Float +layoutBlocks transformSize chunkSize xs = + let numChunks = Integral.divUp (SV.length xs) chunkSize + in CArray.listArray ((0,0), (numChunks-1, transformSize-1)) (repeat 0) + // + zip (liftM2 (,) [0..] (take chunkSize [0..])) (SV.unpack xs) + +mul1d2d :: + (Ring.C a, Storable a) => + CArray Int a -> CArray (Int,Int) a -> CArray (Int,Int) a +mul1d2d xs ys = + IArray.array (IArray.bounds ys) $ + map (\((i,j),y) -> ((i,j), xs!j * y)) $ + IArray.assocs ys + +permuteClip :: + (IArray.Ix i, IArray.Ix j, Additive.C a, Storable a) => + (i -> j) -> (j,j) -> CArray i a -> CArray j a +permuteClip f bnds xs = + IArray.accumArray (+) zero bnds $ + filter (IArray.inRange bnds . fst) $ + map (mapFst f) $ IArray.assocs xs + +sizes :: Int -> (Int, Int) +sizes len = + let transformSize = ceilingPower 2 $ 2 * len + chunkSize = transformSize - len + 1 + in (transformSize, chunkSize) + +padRight :: Int -> SV.Vector Float -> SV.Vector Float +padRight size xs = + SV.append xs $ SV.replicate (size - SV.length xs) 0 + +convolve :: SV.Vector Float -> SV.Vector Float -> SV.Vector Float +convolve xs ys = + let (transformSize, chunkSize) = sizes $ SV.length xs + dims = [1] + in SVCArr.from $ + permuteClip + (\(i,j) -> i*chunkSize+j) + (0, SV.length xs + SV.length ys - 2) $ + FFT.dftCRN dims $ + mul1d2d + (FFT.dftRC $ SVCArr.to $ padRight transformSize xs) + (FFT.dftRCN dims $ layoutBlocks transformSize chunkSize ys) + +correlate :: SV.Vector Float -> SV.Vector Float -> SV.Vector Float +correlate xs ys = + let (transformSize, chunkSize) = sizes $ SV.length xs + dims = [1] + in SVCArr.from $ + permuteClip + (\(i,j) -> i*chunkSize+j - SV.length xs + 1) + (0, SV.length ys - 1) $ + FFT.dftCRN dims $ + mul1d2d + (FFT.dftRC $ SVCArr.to $ padRight transformSize $ SV.reverse xs) + (FFT.dftRCN dims $ layoutBlocks transformSize chunkSize ys) + + +pillow :: Int -> CArray Int Float +pillow n = + CArray.listArray (0, n-1) $ + map (\i -> sin (pi * fromIntegral i / fromIntegral n)) [(0::Int) .. ] + +{- | +The array is not padded. +Instead we choose the longest array that only contains valid data. +-} +layoutOverlapBlocks :: Int -> Int -> SV.Vector Float -> CArray (Int, Int) Float +layoutOverlapBlocks shift chunkSize xs = + let lastChunk = Integral.div (SV.length xs - chunkSize) shift + bnds = ((0,0), (lastChunk, chunkSize-1)) + in CArray.array bnds $ flip map (IArray.range bnds) $ + \(i,j) -> ((i,j), SV.index xs $ i*shift + j) + +absoluteBlockSpectra :: Int -> Int -> SV.Vector Float -> CArray (Int, Int) Float +absoluteBlockSpectra shift chunkSize xs = + CArray.amap Complex.magnitude $ + FFT.dftRCN [1] $ mul1d2d (pillow chunkSize) $ + layoutOverlapBlocks shift chunkSize xs + +slice :: CArray (Int, Int) Float -> [SV.Vector Float] +slice arr = + let ((firstChunk, firstElem), (lastChunk, lastElem)) = IArray.bounds arr + in map (\i -> + SV.sample (IArray.rangeSize (firstElem, lastElem)) $ + \j -> arr ! (i, firstElem+j)) $ + IArray.range (firstChunk, lastChunk) + +spectralFlatness :: SV.Vector Float -> Float +spectralFlatness xs = + 2 ** Ana.average (SV.map (logBase 2) xs) / Ana.average xs diff --git a/src/HiddenMarkovModel.hs b/src/HiddenMarkovModel.hs new file mode 100644 --- /dev/null +++ b/src/HiddenMarkovModel.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE RebindableSyntax #-} +module HiddenMarkovModel where + +import qualified LabelChain +import qualified Label +import qualified Named + +import qualified Math.HiddenMarkovModel.Named as HMMNamed +import qualified Math.HiddenMarkovModel as HMM + +import qualified Numeric.Container as NC +import qualified Data.Packed.Matrix as Matrix +import qualified Data.Packed.Vector as Vector +import Data.Packed.Vector (Vector) + +import qualified Data.StorableVector.Lazy as SVL +import Foreign.Storable (Storable) + +import Text.Printf (printf, ) + +import qualified Options.Applicative as OP +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path + +import qualified Control.Monad.Exception.Synchronous as ME +import qualified Control.Parallel.Strategies as Par + +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Monoid.HT as Mn +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import qualified Data.Map as Map; import Data.Map (Map) +import qualified Data.Set as Set; import Data.Set (Set) +import Data.Traversable (Traversable) +import Data.Foldable (foldMap) +import Data.Monoid ((<>)) +import Data.NonEmpty ((!:)) +import Data.Tuple.HT (swap) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + + +allStates :: [String] +allStates = + List.sort + [Label.clickBegin, Label.clickEnd, + Label.chirpingMain, Label.chirpingPause, Label.growling, Label.pause] + + +admissibleTransitions :: [(String, [String])] +admissibleTransitions = + (Label.pause, + [Label.pause, + Label.chirpingMain, Label.clickBegin, Label.growlingClickBegin]) : + (Label.clickBegin, [Label.clickBegin, Label.clickEnd]) : + (Label.clickEnd, + [Label.clickBegin, Label.clickEnd, + Label.chirpingMain, Label.growlingClickBegin, Label.pause]) : + (Label.chirpingMain, [Label.chirpingMain, Label.chirpingPause]) : + (Label.chirpingPause, + [Label.chirpingMain, Label.chirpingPause, + Label.clickBegin, Label.growlingClickBegin, Label.pause]) : + (Label.growlingClickBegin, + [Label.growlingClickBegin, Label.growlingClickEnd]) : + (Label.growlingClickEnd, + [Label.growlingClickBegin, Label.growlingClickEnd, + Label.chirpingMain, Label.clickBegin, Label.pause]) : + [] + +admissibleTransitionSet :: Set (String, String) +admissibleTransitionSet = + foldMap + (\(from, tos) -> Set.fromList $ map ((,) from) tos) + admissibleTransitions + +forbiddenTransitions :: + Set (String, String) -> + Map HMM.State String -> + HMM.GaussianTrained Double -> Set (String, String) +forbiddenTransitions admissible dict = + flip Set.difference admissible . + foldMap + (foldMap + (\(row, (col, x)) -> + Mn.when (x > 0) $ + Set.singleton + (checkedLookup dict (HMM.state col), + checkedLookup dict (HMM.state row)))) . + zipWith (\k -> map ((,) k) . zip [0..]) [0..] . + Matrix.toLists . HMM.trainedTransition + + +inverseMap :: Map HMM.State String -> Map String HMM.State +inverseMap = + Map.fromListWith (error "duplicate label") . + map swap . Map.toList + +checkedLookup :: (Ord k, Show k) => Map k a -> k -> a +checkedLookup m k = + Map.findWithDefault + (error $ "checkedLookup: unknown key " ++ show k) k m + +mapsFromLabels :: [String] -> (Map String HMM.State, Map HMM.State String) +mapsFromLabels ss = + let m = Map.fromList $ zip (map HMM.state [0..]) ss + in (inverseMap m, m) + + +checkNonEmpty :: + (PathClass.AbsRel ar) => + Path.File ar -> Named.Signal -> + ME.Exceptional String Named.NonEmptySignal +checkNonEmpty path (Named.Cons name sig) = + case SVL.viewL sig of + Nothing -> + ME.throw $ + printf "%s: %s: empty feature signal" (Path.toString path) name + Just (x,xs) -> return $ Named.Cons name $ x !: xs + +flattenStorableVectorLazy :: + (Storable a) => NonEmpty.T SVL.Vector a -> SVL.Vector a +flattenStorableVectorLazy (NonEmpty.Cons x xs) = SVL.cons x xs + +prepare :: [Named.NonEmptySignal] -> NonEmpty.T [] (Vector Double) +prepare nxs = + let xs = map Named.body nxs + vecFromList = NC.cmap realToFrac . Vector.fromList + in (vecFromList $ map NonEmpty.head xs) + !: + (map vecFromList $ List.transpose $ map (SVL.unpack . NonEmpty.tail) xs) + +label :: HMM.Gaussian Double -> [Named.NonEmptySignal] -> [HMM.State] +label model = NonEmpty.flatten . HMM.reveal model . prepare + +analyze :: + HMMNamed.Gaussian Double -> + [Named.NonEmptySignal] -> LabelChain.T Int String +analyze model = + fmap (checkedLookup $ HMMNamed.nameFromStateMap model) . + LabelChain.segment . label (HMMNamed.model model) + + +flattenIntervals :: + Map String HMM.State -> + LabelChain.T Int String -> [HMM.State] +flattenIntervals dict = + LabelChain.flattenLabels . fmap (checkedLookup dict) + +trainSupervised :: + (PathClass.AbsRel ar) => + Map String HMM.State -> Path.File ar -> + [Named.NonEmptySignal] -> LabelChain.T Int String -> + ME.Exceptional String (HMM.GaussianTrained Double) +trainSupervised dict input sig labels = do + labelSig <- + ME.fromMaybe + (printf "%s: no labels for supervised training" $ + Path.toString input) $ + NonEmpty.fetch $ flattenIntervals dict labels + return $ + HMM.trainSupervised (Map.size dict) $ + NonEmptyC.zip labelSig (prepare sig) + +trainMany :: + (Traversable f) => + (trainingData -> HMM.GaussianTrained Double) -> + NonEmpty.T f trainingData -> HMM.Gaussian Double +trainMany train = + HMM.finishTraining . NonEmpty.foldl1 HMM.mergeTrained . + Par.withStrategy (Par.parTraversable Par.rdeepseq) . fmap train + + +data Convergence = + Convergence { + cvgMaxIter, cvgSubIter :: Int, + cvgTolerance :: Double + } + +convergenceOptions :: OP.Parser Convergence +convergenceOptions = + OP.liftA3 Convergence + (OP.option OP.auto $ + OP.value 100 + <> OP.long "max-iterations" + <> OP.metavar "NUMBER" + <> OP.help "maximal number of iterations for unsupervised training") + (OP.option OP.auto $ + OP.value 10 + <> OP.long "sub-iterations" + <> OP.metavar "NUMBER" + <> OP.help "number of sub-iterations per iteration") + (OP.option OP.auto $ + OP.value 1e-5 + <> OP.long "tolerance" + <> OP.metavar "PROB" + <> OP.help "convergence tolerance for unsupervised training") + +takeUntilConvergence :: + Convergence -> [HMM.Gaussian Double] -> [HMM.Gaussian Double] +takeUntilConvergence opt = + (\(hmm:hmms) -> + (hmm :) $ map snd . take (cvgMaxIter opt) . takeWhile fst $ + ListHT.mapAdjacent + (\hmm0 hmm1 -> (HMM.deviation hmm0 hmm1 > cvgTolerance opt, hmm1)) + hmms) . + ListHT.sieve (cvgSubIter opt) diff --git a/src/HiddenMarkovModel/Hardwired.hs b/src/HiddenMarkovModel/Hardwired.hs new file mode 100644 --- /dev/null +++ b/src/HiddenMarkovModel/Hardwired.hs @@ -0,0 +1,158 @@ +module HiddenMarkovModel.Hardwired where + +import HiddenMarkovModel (inverseMap) +import qualified Label + +import qualified Math.HiddenMarkovModel.Distribution as Distr +import qualified Math.HiddenMarkovModel.Pattern as Pat +import qualified Math.HiddenMarkovModel.Named as HMMNamed +import qualified Math.HiddenMarkovModel as HMM + +import qualified Numeric.Container as NC +import qualified Data.Packed.Matrix as Matrix +import qualified Data.Packed.Vector as Vector +import Data.Packed.Matrix (Matrix) + +import qualified Data.Map as Map; import Data.Map (Map) +import Data.Semigroup ((<>)) +import Data.Tuple.HT (mapFst) + + + +pause, clickBegin, clickEnd, chirping, chirpingPause, growling :: HMM.State +pause = HMM.state 0 +clickBegin = HMM.state 1 +clickEnd = HMM.state 2 +chirping = HMM.state 3 +chirpingPause = HMM.state 4 +growling = HMM.state 5 + +numberOfStates :: Int +numberOfStates = 6 + +formatState :: Distr.State -> String +formatState (Distr.State s) = + case s of + 1 -> "click begin" + 2 -> "click end" + 3 -> "chirping loop" + 4 -> "chirping pause" + 5 -> "growling" + _ -> "pause" + +labelFromStateMap :: Map HMM.State String +labelFromStateMap = + Map.fromList $ map (mapFst HMM.state) $ + (0, Label.pause) : + (1, Label.clickBegin) : + (2, Label.clickEnd) : + (3, Label.chirpingMain) : + (4, Label.chirpingPause) : + (5, Label.growling) : + [] + +stateFromLabelMap :: Map String HMM.State +stateFromLabelMap = + inverseMap labelFromStateMap + + + +infixr 7 *<> + +(*<>) :: Int -> Pat.T Double -> Pat.T Double +(*<>) = Pat.replicate + + +rasping :: Pat.T Double +rasping = + 15 *<> + (600 *<> Pat.atom clickBegin + <> + 600 *<> Pat.atom clickEnd) + +pattern :: Pat.T Double +pattern = + 10000 *<> Pat.atom pause + <> + 15 *<> + (rasping + <> + 6000 *<> Pat.atom chirping + <> + 1500 *<> Pat.atom chirpingPause) + <> + rasping + <> + 60000 *<> Pat.atom pause + <> + 7 *<> + (150 *<> Pat.atom growling + <> + 1000 *<> Pat.atom pause) + + + +hmm :: HMM.Gaussian Double +hmm = hmmTrained + +hmmTrained :: HMM.Gaussian Double +hmmTrained = + HMM.Cons { + HMM.initial = + Vector.fromList [0.0,0.0,0.0,1.0,0.0,0.0], + HMM.transition = + Matrix.fromLists $ + [0.9994586913864266,0.0,2.100090303883067e-5,0.0,0.0,1.0218978102189781e-2] : + [0.0,0.9855812349085892,4.09517609257198e-3,0.0,2.4915465385299874e-3,0.0] : + [0.0,1.4418765091410832e-2,0.9956108112648844,0.0,0.0,0.0] : + [0.0,0.0,2.730117395047987e-4,0.9994628194305887,0.0,0.0] : + [0.0,0.0,0.0,5.371805694114036e-4,0.99750845346147,0.0] : + [5.413086135733135e-4,0.0,0.0,0.0,0.0,0.9897810218978101] : + [], + HMM.distribution = + Distr.gaussian $ + (Vector.fromList [0.9513191890047871], covariance [[0.17689006357223516]]) : + (Vector.fromList [1.5879408507110250], covariance [[0.600575479836784]]) : + (Vector.fromList [0.7454942099113683], covariance [[0.4088353694711163]]) : + (Vector.fromList [1.0231037870319346], covariance [[0.19801719658707737]]) : + (Vector.fromList [0.6214106323233616], covariance [[0.3085570412459857]]) : + (Vector.fromList [1.5574159338071116], covariance [[0.6221472768351596]]) : + []} + +hmmPattern :: HMM.Gaussian Double +hmmPattern = + (HMM.finishTraining $ + Pat.finish numberOfStates (Distr.GaussianTrained Map.empty) pattern) + {HMM.distribution = + Distr.gaussian $ + (Vector.fromList [1.00], covariance [[0.17]]) : + (Vector.fromList [1.60], covariance [[0.60]]) : + (Vector.fromList [0.75], covariance [[0.40]]) : + (Vector.fromList [1.00], covariance [[0.20]]) : + (Vector.fromList [0.60], covariance [[0.30]]) : + (Vector.fromList [1.60], covariance [[0.60]]) : + []} + +hmmNamed :: HMMNamed.Gaussian Double +hmmNamed = + HMMNamed.Cons { + HMMNamed.model = hmm, + HMMNamed.nameFromStateMap = labelFromStateMap, + HMMNamed.stateFromNameMap = stateFromLabelMap + } + + +covariance :: [[Double]] -> Matrix Double +covariance xs = + let m = Matrix.fromLists xs + in Matrix.trans m NC.<> m + + +scaleStdDev :: Double -> HMM.Gaussian Double -> HMM.Gaussian Double +scaleStdDev k model = + model { + HMM.distribution = + let Distr.Gaussian arr = HMM.distribution model + in Distr.Gaussian $ + fmap (\(center,dev,c) -> (center, NC.scale k dev, c/k)) arr + } diff --git a/src/Label.hs b/src/Label.hs new file mode 100644 --- /dev/null +++ b/src/Label.hs @@ -0,0 +1,36 @@ +module Label where + + +clickBegin, clickEnd, chirpingMain, chirpingPause, + growlingClickBegin, growlingClickEnd, pause :: String +clickBegin = "r0" +clickEnd = "r1" +chirpingMain = "ch" +chirpingPause = "cp" +growlingClickBegin = "g0" +growlingClickEnd = "g1" +pause = "p" + +clickParts :: (String, String) +clickParts = (clickBegin, clickEnd) + +growlingClickParts :: (String, String) +growlingClickParts = (growlingClickBegin, growlingClickEnd) + + +advertisement, rasping, chirping, ticking, growling, + rumble, raspingRumble, chirpingRumble, growlingRumble, + overlayedRumble :: String + +advertisement = "advertisement" +rasping = "rasping" +chirping = "chirping" +ticking = "ticking" +growling = "growling" + +rumble = "rumble" +raspingRumble = rasping ++ ' ' : rumble +chirpingRumble = chirping ++ ' ' : rumble +growlingRumble = growling ++ ' ' : rumble + +overlayedRumble = "+rumble" diff --git a/src/LabelChain.hs b/src/LabelChain.hs new file mode 100644 --- /dev/null +++ b/src/LabelChain.hs @@ -0,0 +1,984 @@ +{-# LANGUAGE RebindableSyntax #-} +module LabelChain ( + T(..), + fromAdjacentChunks, + singleton, + lift, + segment, + flattenLabels, + toLabelTrack, + fromLabelTrack, + intervalSizes, + mapTime, + mapWithBounds, + zipWithList, + realTimes, + concat, + takeTime, + trim, + adjustLength, + collectExceptions, + writeFile, + writeFileInt, + + splitChirping, + + -- click detection + detectClicksDiff, + detectClicksExtrema, + detectClicksMonotony, + detectClicksLaxMonotony, + detectClicksThreshold, + detectClicksWeakMonotony, + fineFromCoarseIntervalsInt, + fineFromCoarseIntervalsInt2, + snapBoundaries, + + chopMonotony, + spanWeakFalling, + spanWeakRising, + + -- testing + propSpanWeak, + propExtremaSizes, + propMaximaSizes, + + -- classification post-processing + BreakRel(..), + ClickAbs(..), + ClickRels, + abstractFromSoundClassIntervals, + classFromFineIntervals, + classRelativeFromAbsolute, + + -- fix of classification glitches + correctShortChirping, + fuseTickingBouts, + mergeRaspingShortPause, + tickingsFromRaspings, + breakLongClicks, + mergeRaspingGrowling, + assimilateRumblingSolo, Rumbling(..), + assimilateRumblingDuo, + unzipRumbling, + ) where + +import qualified SignalProcessing as SP +import qualified Class +import qualified Rate +import qualified Parameters as Params +import qualified Durations as Durs +import qualified LabelPattern as Pat +import qualified Label +import LabelPattern ((&)) + +import qualified Sound.Audacity.LabelTrack as LabelTrack + +import qualified Data.StorableVector.Lazy as SVL + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path + +import qualified Control.Monad.Exception.Synchronous as ME +import qualified Control.Functor.HT as FuncHT +import Control.DeepSeq (NFData, rnf) +import Control.Monad (liftM3, guard) +import Control.Applicative (Applicative, pure, (<*>), (<$>), (<$), (<|>)) + +import qualified Data.NonEmpty.Mixed as NonEmptyM +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import qualified Data.List.Reverse.StrictSpine as RevSpine +import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Semigroup (Semigroup, (<>)) +import Data.Foldable (foldMap) +import Data.NonEmpty ((!:)) +import Data.Maybe.HT (toMaybe) +import Data.Maybe (maybeToList) +import Data.Tuple.HT (mapFst, mapSnd, mapPair) +import Data.Ord.HT (comparing) +import Data.Eq.HT (equating) + +import qualified Algebra.RealRing as Real +import qualified Algebra.Additive as Additive +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (readFile, writeFile, null, concat) + + +{- | +Time stamps must be in ascending order. +-} +newtype T t a = Cons {decons :: [(t,a)]} + +instance Functor (T t) where + fmap f = lift $ map (mapSnd f) + +instance Fold.Foldable (T t) where + foldMap f = Fold.foldMap (f . snd) . decons + +instance Trav.Traversable (T t) where + sequenceA = fmap Cons . Trav.traverse (FuncHT.mapSnd id) . decons + +instance (NFData t, NFData a) => NFData (T t a) where + rnf = rnf . decons + +singleton :: t -> a -> T t a +singleton t a = Cons [(t,a)] + +mapTime :: (t -> s) -> T t a -> T s a +mapTime f = Cons . mapTimePlain f . decons + +mapTimePlain :: (t -> s) -> [(t,a)] -> [(s,a)] +mapTimePlain f = map (mapFst f) + +mapWithBounds :: (Additive.C t) => ((t,t) -> a -> b) -> T t a -> T t b +mapWithBounds f = + fromLabelTrack . LabelTrack.mapWithTime f . toLabelTrack + +zipWithList :: (a -> b -> c) -> [a] -> T t b -> T t c +zipWithList f = lift . zipWith (mapSnd . f) + +realTimes :: (Rate.C rate) => rate -> T Int a -> T Double a +realTimes sampleRate = mapTime (Params.toTime sampleRate) + +duration :: (Additive.C t) => T t a -> t +duration = ListHT.switchR zero (\_ (t,_) -> t) . decons + +-- Attention: This deviates from LabelTrack.mconcat since it shifts the parts +concat :: (Additive.C t) => [T t a] -> T t a +concat = + Cons . concatMap decons . + uncurry (zipWith (\offset xs -> mapTime (offset+) xs)) . + mapFst (scanl (+) zero) . unzip . map (\xs -> (duration xs, xs)) + + +fromAdjacentChunks :: (Additive.C t) => [(t, a)] -> T t a +fromAdjacentChunks = + Cons . snd . + Trav.mapAccumL (\t0 (d, lab) -> let t1=t0+d in (t1, (t1, lab))) zero + +lift :: ([(t0,a)] -> [(t1,b)]) -> T t0 a -> T t1 b +lift f (Cons xs) = Cons $ f xs + + +segmentChunks :: (Eq a) => [a] -> [(Int, a)] +segmentChunks = + map (\ss -> (length (NonEmpty.flatten ss), NonEmpty.head ss)) . + NonEmptyM.groupBy (==) + +segment :: (Eq a) => [a] -> T Int a +segment = fromAdjacentChunks . segmentChunks + +flattenLabels :: T Int a -> [a] +flattenLabels = foldMap (uncurry replicate) . intervalSizes + +intervalSizes :: (Additive.C t) => T t a -> T t (t, a) +intervalSizes = + Cons . ListHT.mapAdjacent1 (\n0 n1 lab -> (n1, (n1-n0, lab))) zero . decons + +instance Durs.Track T where intervalSizes = intervalSizes + +toLabelTrack :: (Additive.C t) => T t a -> LabelTrack.T t a +toLabelTrack = + LabelTrack.Cons . + ListHT.mapAdjacent1 (\l r lab -> ((l,r), lab)) Additive.zero . decons + +{- | +Only allowed for consecutive intervals starting at zero. +This is not checked. +-} +fromLabelTrack :: LabelTrack.T t a -> T t a +fromLabelTrack = Cons . map (mapFst snd) . LabelTrack.decons + + +takeTime :: (Additive.C t, Ord t) => t -> T t a -> T t a +takeTime = + let go _ _ [] = [] + go t left (x@(right,lab):xs) = + if t<=left + then [] + else + if t t -> T t a -> T t a +trim maxDur (Cons xt) = + applyPattern Pat.flatten1 + (Pat.mapMaybe + (\(x0,x1) -> toMaybe (Pat.dur x1 <= maxDur) (Pat.intervalLabel x0)) $ + Pat.atEnd $ Pat.fuse Pat.next Pat.next) + $ + Cons $ + case xt of + (t0,_) : xs -> if t0<=maxDur then xs else xt + [] -> [] + +{- | +Extend or cut such that the chain has the desired length. +-} +adjustLength :: (Ord t) => t -> T t a -> T t a +adjustLength dur = + let go (x0@(t,a), xs) = + maybe [(dur,a)] (x0 :) $ do + guard $ t ListHT.viewL xs + in Cons . maybe [] go . ListHT.viewL . decons + +collectExceptions :: T t (ME.Exceptional e a) -> ME.Exceptional [e] (T t a) +collectExceptions = + (\(es,as) -> if List.null es then ME.Success (Cons as) else ME.throw es) . + ListHT.unzipEithers . + map (\(bnds,label) -> ME.switch Left (Right . (,) bnds) label) . + decons + + +writeFile :: + (PathClass.AbsRel ar) => + Path.File ar -> T Double String -> IO () +writeFile path = + LabelTrack.writeFile (Path.toString path) . toLabelTrack + +writeFileInt :: + (Rate.C rate, PathClass.AbsRel ar) => + rate -> Path.File ar -> T Int String -> IO () +writeFileInt rate path = + LabelTrack.writeFileInt (Rate.unpack rate) (Path.toString path) . + toLabelTrack + + + +splitChirping :: SVL.Vector Float -> T Int String +splitChirping xs = + let len = SVL.length xs + chirpLength = len - SP.chirpingPauseDur xs + in Cons $ + (chirpLength, Label.chirpingMain) : + (len, Label.chirpingPause) : + [] + + +applyPattern :: + Additive.C t => + Pat.Flatten bnds fa t a -> Pat.T t a bnds fa -> T t a -> T t a +applyPattern flatten p = + fromLabelTrack . Pat.apply flatten p . toLabelTrack + +applyPatternDefault :: + (Additive.C t) => + Pat.Flatten bnds fb t b -> (a -> b) -> Pat.T t a bnds fb -> T t a -> T t b +applyPatternDefault flatten f p = + fromLabelTrack . Pat.applyDefault flatten f p . toLabelTrack + + +mergeNamesakes :: (Eq a) => T t a -> T t a +mergeNamesakes = + lift $ + map (mapPair (NonEmpty.last, NonEmpty.head) . FuncHT.unzip) . + NonEmptyM.groupBy (equating snd) + +removeEmptyIntervals :: T Int a -> T Int a +removeEmptyIntervals = + fmap snd . lift (filter ((>0) . fst . snd)) . intervalSizes + +avoidEmptyClickParts :: T Int String -> T Int String +avoidEmptyClickParts = + applyPattern Pat.flatten2 $ + let p2 = + Pat.alt + (Pat.match2 Label.clickParts) + (Pat.match2 Label.growlingClickParts) + whenDur p = Pat.guard (\(x0,x1) -> p (Pat.dur x0) (Pat.dur x1)) + in mapPair (Pat.intervalLabel, Pat.intervalLabel) <$> + Pat.alt + (whenDur (\dur0 dur1 -> dur0==0 && dur1>1) (Pat.move 1 p2)) + (whenDur (\dur0 dur1 -> dur0>1 && dur1==0) (Pat.move (-1) p2)) + +removeIsolatedClickParts :: Additive.C t => T t String -> T t String +removeIsolatedClickParts = + let matchBegin (lab0, lab1) (labelBegin, labelEnd) = + lab0 == labelBegin && lab1 /= labelEnd + matchEnd (lab0, lab1) (labelBegin, labelEnd) = + lab0 /= labelBegin && lab1 == labelEnd + p1 = fmap Pat.intervalLabel Pat.next + + in applyPattern Pat.flatten1 $ + Pat.mapMaybe + (\labs -> + toMaybe + (matchEnd labs Label.clickParts || + matchEnd labs Label.growlingClickParts) + (fst labs) + <|> + toMaybe + (matchBegin labs Label.clickParts || + matchBegin labs Label.growlingClickParts) + (snd labs)) + (Pat.fuse p1 p1) + +{- | +This is a quick fix. +It would be better to write click detection in a way +that avoids empty intervals. +-} +fixDetectedClicks :: T Int String -> T Int String +fixDetectedClicks = + mergeNamesakes . removeEmptyIntervals . + avoidEmptyClickParts . removeIsolatedClickParts + + +threshold :: (Ord b) => (a, a) -> b -> [b] -> [a] +threshold (low,high) thr = + map (\y -> if y (NonEmpty a, [a]) ? +type Span a = [a] -> ([a], [a]) + +spanRising :: (Ord a) => Span a +spanRising xs = + Match.splitAt (takeWhile id $ ListHT.mapAdjacent (<=) xs) xs + +spanFalling :: (Ord a) => Span a +spanFalling xs = + Match.splitAt (takeWhile id $ ListHT.mapAdjacent (>=) xs) xs + + +{- +This one accepts negative steps above a certain threshold. +This way we accept many small successive negative steps. +Better use 'spanWeakRising'. +-} +spanLaxRising :: (Ord a, Additive.C a) => a -> Span a +spanLaxRising d xs = + Match.splitAt (takeWhile (>= -d) $ ListHT.mapAdjacent subtract xs) xs + +spanLaxFalling :: (Ord a, Additive.C a) => a -> Span a +spanLaxFalling d xs = + Match.splitAt (takeWhile (>= -d) $ ListHT.mapAdjacent (-) xs) xs + + +-- ToDo: could we benefit from a ArgMax semigroup? +{- +This one remembers the maximum value and position seen so far. +Every following value must be above a certain difference below that maximum. +This way we allow small negative steps, but not runs of small steps. +We only keep the values until the maximum. + +If a run of falling steps accumulates too much, +we abort that run and return to the last maximum value. +An exception is the handling at the end of the signal: +If we reach the end within a flat run of falling steps, +then we append this run to the rising sequence. +Otherwise the following alternating 'spanWeakFalling' and 'spanWeakRising' steps +will divide the remaining signal into smaller and smaller chunks. +-} +spanWeakRising :: (Ord a, Additive.C a) => a -> Span a +spanWeakRising d = spanWeak SP.argMax (<=d) + +spanWeakFalling :: (Ord a, Additive.C a) => a -> Span a +spanWeakFalling d = spanWeak SP.argMin (>= -d) + +spanWeak :: + (Additive.C a) => + ((Int,a) -> (Int,a) -> (Int,a)) -> (a -> Bool) -> Span a +spanWeak _ _ [] = ([], []) +spanWeak argextr cmp xt0@(x0:xs0) = + let slope = + NonEmpty.mapTail + (takeWhile (\(x, (_kmax, xmax)) -> cmp $ xmax - x)) $ + NonEmptyC.zip (x0!:xs0) $ + NonEmpty.scanl argextr (0,x0) (zip [1..] xs0) + len = length xt0 + pos = + if length (NonEmpty.flatten slope) == len + then len + else 1 + (fst $ snd $ NonEmpty.last slope) + in splitAt pos xt0 + +propSpanWeak :: Double -> [Double] -> Bool +propSpanWeak d xs = + mapPair (map negate, map negate) (spanWeakRising d xs) + == + spanWeakFalling d (map negate xs) + + +{- | +@lookAhead@ must be at least 1. +-} +spanUntilMaximum :: (Ord a) => Int -> Span a +spanUntilMaximum lookAhead xs = + splitAt + (fst $ List.maximumBy (comparing snd) $ zip [0..] $ take lookAhead xs) + xs + +spanUntilMinimum :: (Ord a) => Int -> Span a +spanUntilMinimum lookAhead xs = + splitAt + (fst $ List.minimumBy (comparing snd) $ zip [0..] $ take lookAhead xs) + xs + + +chopMonotony :: (Span a, Span a) -> [a] -> [[a]] +chopMonotony (spanRise, spanFall) = + let rising [] = [] + rising [x] = [[x]] + rising xs = + let (ys,zs) = spanRise xs + in ys : falling zs + falling [] = [] + falling [x] = [[x]] + falling xs = + let (ys,zs) = spanFall xs + in ys : rising zs + in rising + +{- | +It is important to round the first number up and the second one down. +Since an attack phase has often only one sample period, +only this way the maximum will be the first value of a click. +-} +extremaSizes :: (Span a, Span a) -> [a] -> [Int] +extremaSizes fs = + NonEmpty.mapAdjacent (\n m -> div m 2 - div (-n) 2) + . + NonEmpty.cons 0 . map length . chopMonotony fs + +propExtremaSizes :: (Ord a) => [a] -> Bool +propExtremaSizes xs = + sum (extremaSizes (spanRising, spanFalling) xs) == length xs + + +mergePhases :: [[a]] -> [[a]] +mergePhases = + let go (x0:x1:xs) = (x0++x1) : go xs + go xs = xs + in go + +{- | +Alternative to 'extremaSizes' which focuses on maxima. +It does not handle minima and maxima in the same way, as 'extremaSizes' does. +Instead it chooses all values around a local maxima down to a certain threshold. +-} +maximaSizes :: (Real.C a) => (Span a, Span a) -> a -> [a] -> [Int] +maximaSizes fs thres = + List.concat + . + NonEmpty.mapAdjacent (\(_,_,r) (l,m,_) -> [r+l,m]) + . + ((0,0,0)!:) . (++ [(0,0,0)]) + . + map + (\xs -> + let xmax = maximum xs + (left, right) = +{- + (if head xs < last xs + then mapFst (max 1) + else mapSnd (max 1)) $ +-} + mapPair + (length . RevSpine.dropWhile (thres*xmax <=), + length . List.dropWhile (thres*xmax <=)) $ + break (xmax==) xs + in (left, length xs - (left+right), right)) + . + mergePhases + . + chopMonotony fs + +propMaximaSizes :: (Real.C a) => a -> [a] -> Bool +propMaximaSizes thres xs = + sum (maximaSizes (spanRising, spanFalling) thres xs) == length xs + + +data ClickPhase = ClickBegin | ClickEnd + deriving (Eq, Ord, Show) + +type DetectClicks label a = (label,label) -> [a] -> T Int label + +clickLabelsDet :: (String, String) +clickLabelsDet = (Label.clickEnd, Label.clickBegin) + +growlingClickLabelsDet :: (String, String) +growlingClickLabelsDet = (Label.growlingClickEnd, Label.growlingClickBegin) + +detectClicksThreshold :: (Eq label, Ord a) => a -> DetectClicks label a +detectClicksThreshold thr labels = + segment . threshold labels thr + +detectClicksMonotony :: Ord a => DetectClicks label a +detectClicksMonotony labels = + fromAdjacentChunks . attachClickLabels labels . + extremaSizes (spanRising, spanFalling) + +detectClicksLaxMonotony :: + (Ord a, Additive.C a) => (a,a) -> DetectClicks label a +detectClicksLaxMonotony (dr,df) labels = + fromAdjacentChunks . attachClickLabels labels . + extremaSizes (spanLaxRising dr, spanLaxFalling df) + +detectClicksWeakMonotony :: + (Real.C a) => (a,a) -> a -> DetectClicks label a +detectClicksWeakMonotony (dr,df) thres labels = + fromAdjacentChunks . + RevSpine.dropWhile ((0==) . fst) . + dropWhile ((0==) . fst) . + attachClickLabels labels . + maximaSizes (spanWeakRising dr, spanWeakFalling df) thres + +detectClicksExtrema :: Ord a => (Int, Int) -> DetectClicks label a +detectClicksExtrema (lookAheadMaximum, lookAheadMinimum) labels = + fromAdjacentChunks . attachClickLabels labels . + extremaSizes + (spanUntilMaximum lookAheadMaximum, + spanUntilMinimum lookAheadMinimum) + +attachClickLabels :: (label,label) -> [bnd] -> [(bnd, label)] +attachClickLabels (low,high) xs = zip xs (cycle [low, high]) + + +localMinimaAtBoundaries :: (Ord a) => [a] -> (Maybe (Int, a), Maybe (Int, a)) +localMinimaAtBoundaries = + let nextMinimum xs = + case spanFalling xs of + (falling, x:_) -> Just (length falling, x) + _ -> Nothing + in \xs -> (nextMinimum xs, nextMinimum $ reverse xs) + +snapBoundaries :: + SVL.Vector Float -> + T Int (Class.Sound rasping chirping ticking growling) -> + T Int (Class.Sound rasping chirping ticking growling) +snapBoundaries env intervals = + let (chunkSizes, labels) = + unzip $ Fold.toList $ intervalSizes intervals + modifiedTimes = + (\(acc,ts) -> NonEmpty.tail $ NonEmpty.snoc ts (fst acc)) $ + List.mapAccumL + (\(t0,mdr0i) (lab, d, (chunk,(mdl1i,mdr1))) -> + let mmd = + guard + (case lab of + Class.Rasping _ -> True + Class.Chirping _ -> True + Class.Growling _ -> True + _ -> False) + >> + liftM3 + (\(n0,y0) (n1,y1) (yh,_) -> + (toMaybe (y0 maybe 0 fst mdl1 + (Just (dr0,_), Nothing) -> + if 0 < d-dr0 then -dr0 else 0 + (Just (dr0,y0), Just (dl1,y1)) -> + if (dr0,y0) < (dl1,y1) && 0 < d-dr0 + then -dr0 + else dl1 + in ((t0+d, mdr1), t0 + maybe 0 offset mmd)) + (0,Nothing) $ + zip3 labels chunkSizes $ + map (\chunk -> (chunk, localMinimaAtBoundaries $ SVL.unpack chunk)) $ + SP.chop env chunkSizes + in Cons $ zip modifiedTimes labels + +fineFromCoarseIntervalsInt :: + DetectClicks String Float -> SVL.Vector Float -> + T Int (Class.Sound rasping chirping ticking growling) -> + T Int String +fineFromCoarseIntervalsInt detectClicks env intervals = + let detClicks parts = detectClicks parts . SVL.unpack + f bnds chunk lab = + case lab of + Class.Rasping _ -> detClicks clickLabelsDet chunk + Class.Ticking _ -> detClicks clickLabelsDet chunk + Class.Growling _ -> detClicks growlingClickLabelsDet chunk + Class.Chirping _ -> splitChirping chunk + Class.Other str -> singleton (uncurry subtract bnds) str + (bounds, (chunkSizes, labels)) = + mapSnd unzip $ unzip $ LabelTrack.decons $ + toLabelTrack $ intervalSizes intervals + in fixDetectedClicks $ concat $ + zipWith3 f bounds (SP.chop env chunkSizes) labels + + +detectClicksDiff :: + (Real.C a) => a -> a -> DetectClicks label a +detectClicksDiff thresSingle thresSum (low,high) = + fromAdjacentChunks . + map + (\chunk -> + (sum $ map snd $ NonEmpty.flatten chunk, + if fst $ NonEmpty.head chunk then high else low)) . + NonEmptyM.groupBy (equating fst) . + map + (\chunk -> + (fst (NonEmpty.head chunk) && + sum (map snd (NonEmpty.flatten chunk)) >= thresSum, + SP.foldLength chunk)) . + NonEmptyM.groupBy (equating fst) . + map (\x -> (x>=thresSingle, x)) + +fineFromCoarseIntervalsInt2 :: + DetectClicks String Float -> + SVL.Vector Float -> SVL.Vector Float -> + T Int (Class.Sound rasping chirping ticking growling) -> + T Int String +fineFromCoarseIntervalsInt2 detectClicks env diffEnv intervals = + let detClicks parts = detectClicks parts . SVL.unpack + f bnds diffChunk chunk lab = + case lab of + Class.Rasping _ -> detClicks clickLabelsDet diffChunk + Class.Ticking _ -> detClicks clickLabelsDet diffChunk + Class.Growling _ -> detClicks growlingClickLabelsDet diffChunk + Class.Chirping _ -> splitChirping chunk + Class.Other str -> singleton (uncurry subtract bnds) str + (bounds, (chunkSizes, labels)) = + mapSnd unzip $ unzip $ LabelTrack.decons $ + toLabelTrack $ intervalSizes intervals + in fixDetectedClicks $ concat $ + List.zipWith4 f + bounds (SP.chop diffEnv chunkSizes) (SP.chop env chunkSizes) labels + + + +intervalFromClickAbss :: ClickAbss t -> Pat.Interval t (ClickAbss t) +intervalFromClickAbss clicks = + Pat.Interval + (case (NonEmpty.head clicks, NonEmpty.last clicks) of + (ClickAbs start _ _, ClickAbs _ _ stop) -> (start, stop)) + clicks + +data ClickAbs t = ClickAbs t t t +type ClickAbss t = NonEmpty.T [] (ClickAbs t) + +newtype BreakAbs t = BreakAbs t + +instance (NFData t) => NFData (BreakAbs t) where + rnf (BreakAbs t) = rnf t + + +classFromFineIntervals :: + (Additive.C t) => + T t String -> + T t (Class.Sound (ClickAbss t) (BreakAbs t) ticking (ClickAbss t)) +classFromFineIntervals = + applyPatternDefault Pat.flatten1 Class.Other $ + let collectClicks clickParts = + Pat.snocMaybe + (Pat.many1 $ + (\(Pat.Interval bnd0 _lab0, Pat.Interval bnd1 _lab1) -> + uncurry ClickAbs bnd0 (snd bnd1)) <$> + (Pat.fusedMatch2 clickParts)) + (Pat.optional $ + (\(Pat.Interval bnd0 _lab0) -> + uncurry ClickAbs bnd0 (snd bnd0)) <$> + Pat.atEnd (Pat.match (fst clickParts))) + in (Class.Chirping . BreakAbs . snd . Pat.intervalBounds + <$> + (fst <$> Pat.fusedMatch2 (Label.chirpingMain, Label.chirpingPause) + `Pat.alt` + Pat.atEnd (Pat.match Label.chirpingMain))) + `Pat.alt` + (Class.Rasping <$> collectClicks Label.clickParts) + `Pat.alt` + (Class.Growling <$> collectClicks Label.growlingClickParts) + + +mergeClickLists :: + (Ord count) => + (NonEmpty.T [] clicks -> clicks) -> + ([clicks] -> count) -> + NonEmpty.T [] (Bool, clicks) -> + Class.Sound clicks chirping ticking clicks +mergeClickLists merge count clickLists = + let rel = + uncurry (comparing (count . map snd)) $ + ListHT.partition fst $ NonEmpty.flatten clickLists + in (case rel of GT -> Class.Growling; _ -> Class.Rasping) $ + merge $ fmap snd clickLists + +{- | +Merge adjacent rasping and growling sounds +and label the concatenation according to the majority of clicks. +-} +mergeRaspingGrowling :: + (Additive.C t, Ord count) => + (NonEmpty.T [] clicks -> clicks) -> + ([clicks] -> count) -> + T t (Class.Sound clicks chirping ticking clicks) -> + T t (Class.Sound clicks chirping ticking clicks) +mergeRaspingGrowling merge count = + applyPattern Pat.flatten1 $ + fmap (mergeClickLists merge count) $ + Pat.many1 $ Pat.maybeLabel $ \cls -> + (,) False <$> Class.maybeRasping cls + <|> + (,) True <$> Class.maybeGrowling cls + + +data + Rumbling t a = + Rumbling {rumblingIntervals :: [Pat.Bounds t], unrumbling :: a} + +instance Functor (Rumbling t) where + fmap f (Rumbling rumbles a) = Rumbling rumbles $ f a + +instance Applicative (Rumbling t) where + pure = Rumbling [] + Rumbling frumbles f <*> Rumbling rumbles a = + Rumbling (frumbles ++ rumbles) (f a) + +instance (Semigroup a) => Semigroup (Rumbling t a) where + Rumbling r0 a0 <> Rumbling r1 a1 = Rumbling (r0++r1) (a0<>a1) + + +unzipRumbling :: + T t (Class.Sound + (Rumbling t rasping) (Rumbling t chirping) + ticking (Rumbling t growling)) -> + (LabelTrack.T t String, + T t (Class.Sound rasping chirping ticking growling)) +unzipRumbling xs = + (LabelTrack.Cons $ map (flip (,) Label.rumble) $ + flip foldMap xs $ \cl -> + case cl of + Class.Other _ -> [] + Class.Rasping x -> rumblingIntervals x + Class.Chirping x -> rumblingIntervals x + Class.Ticking _ -> [] + Class.Growling x -> rumblingIntervals x + , + Class.mapRasping unrumbling . + Class.mapChirping unrumbling . + Class.mapGrowling unrumbling + <$> + xs) + + +{- | +Eliminate short rumbles within other sounds +and keep rumble positions for creation of warnings. +-} +assimilateRumblingSolo :: + (Additive.C t, Ord t) => + (NonEmpty.T [] rasping -> rasping) -> + (NonEmpty.T [] chirping -> chirping) -> + (NonEmpty.T [] growling -> growling) -> + t -> + T t (Class.Sound rasping chirping ticking growling) -> + T t (Class.Sound + (Rumbling t rasping) (Rumbling t chirping) + ticking (Rumbling t growling)) +assimilateRumblingSolo mergeRasping mergeChirping mergeGrowling maxDur = + applyPatternDefault Pat.flatten1 + (Class.mapRasping (Rumbling []) . + Class.mapChirping (Rumbling []) . + Class.mapGrowling (Rumbling [])) $ + let alternating unpack = + Pat.terminatedBy + (\(call,rumble) ~(Rumbling rumbles calls) -> + Rumbling + (Pat.intervalBounds rumble : rumbles) + (NonEmptyC.cons call calls)) + (Pat.fuse + (Pat.maybeLabel unpack) + (Pat.guard (\x -> Pat.dur x <= maxDur) $ + Pat.check ((Just Label.rumble ==) . Class.maybeOther))) + (Rumbling [] . NonEmpty.singleton <$> Pat.maybeLabel unpack) + in Class.Rasping . fmap mergeRasping <$> + alternating Class.maybeRasping + `Pat.alt` + Class.Chirping . fmap mergeChirping <$> + alternating Class.maybeChirping + `Pat.alt` + Class.Growling . fmap mergeGrowling <$> + alternating Class.maybeGrowling + +{- | +Process rumbles that overlaps with frog sounds. +-} +assimilateRumblingDuo :: + (Additive.C t, Ord t) => + T t (Class.Sound Class.Purity Class.Purity ticking Class.Purity) -> + T t (Class.Sound (Rumbling t ()) (Rumbling t ()) ticking (Rumbling t ())) +assimilateRumblingDuo = + applyPatternDefault Pat.flatten1 + (Class.mapRasping (const $ Rumbling [] ()) . + Class.mapChirping (const $ Rumbling [] ()) . + Class.mapGrowling (const $ Rumbling [] ())) $ + let alternating unpack = + fmap (FuncHT.void . Trav.sequenceA . NonEmpty.flatten) $ + Pat.many1 $ + (\(Pat.Interval bnds x) -> + flip Rumbling () $ + case x of + Class.Pure -> [] + Class.Rumble -> [bnds]) <$> + Pat.maybe unpack + in Class.Rasping <$> alternating Class.maybeRasping + `Pat.alt` + Class.Chirping <$> alternating Class.maybeChirping + `Pat.alt` + Class.Growling <$> alternating Class.maybeGrowling + + +breakLongClicks :: + (Real.C t) => + (t -> t) -> + T t (Class.Sound (ClickAbss t) chirping ticking (ClickAbss t)) -> + T t (Class.Sound (ClickAbss t) chirping ticking (ClickAbss t)) +breakLongClicks relMaxDur = + applyPattern Pat.flattenFoldable $ Pat.expand $ + let branch pack unpack = + map (fmap pack) . breakLongClicksIntervals relMaxDur + <$> + Pat.maybeLabel unpack + in branch Class.Rasping Class.maybeRasping + `Pat.alt` + branch Class.Growling Class.maybeGrowling + +breakLongClicksIntervals :: + (Real.C t) => (t -> t) -> ClickAbss t -> [Pat.Interval t (ClickAbss t)] +breakLongClicksIntervals relMaxDur = + map intervalFromClickAbss . + uncurry (++) . mapSnd (maybeToList . NonEmpty.fetch) . + breakLongClicksList relMaxDur . NonEmpty.flatten + +breakLongClicksList :: + (Real.C t) => (t -> t) -> [ClickAbs t] -> ([ClickAbss t], [ClickAbs t]) +breakLongClicksList relMaxDur clicks = + let dist (ClickAbs start _end next) = next-start + maxDur = relMaxDur $ almostMedian $ map dist clicks + in NonEmptyM.segmentAfter (\click -> dist click > maxDur) clicks + +almostMedian :: (Ord a) => [a] -> a +almostMedian xs = + case drop (div (length xs) 2) $ List.sort xs of + [] -> error "almostMedianKey: empty list" + x:_ -> x + + +{- +The input ticking type must also be 'clicks', +since we cannot simply throw away ticking phases. +-} +tickingsFromRaspings :: + (clicks -> Bool) -> + T t (Class.Sound clicks chirping clicks growling) -> + T t (Class.Sound clicks chirping clicks growling) +tickingsFromRaspings validRasping = + fmap + (\cls -> + case cls of + Class.Rasping clicks -> + if validRasping clicks + then cls + else Class.Ticking clicks + _ -> cls) + + +fuseTickingBouts :: + (Additive.C t) => + (NonEmpty.T [] clicks -> clicks) -> + T t (Class.Sound rasping chirping clicks growling) -> + T t (Class.Sound rasping chirping clicks growling) +fuseTickingBouts merge = + applyPattern Pat.flatten1 $ + Class.Ticking . merge <$> + let tick = Pat.maybeLabel Class.maybeTicking + in Pat.precededBy tick $ + Pat.terminatedBy (flip const) (Pat.check Class.isPause) tick + + +data ClickRel t = ClickRel t t +type ClickRels t = NonEmpty.T [] (ClickRel t) + +newtype BreakRel t = BreakRel t + +instance (NFData t) => NFData (BreakRel t) where + rnf (BreakRel t) = rnf t + + +clickRelFromAbs :: (Additive.C t) => ClickAbs t -> ClickRel t +clickRelFromAbs (ClickAbs start end next) = + ClickRel (end-start) (next-end) + +{- | +This does not maintain the pauses between ticks. +-} +classRelativeFromAbsolute :: + (Additive.C t) => + T t (Class.Sound (ClickAbss t) (BreakAbs t) (ClickAbss t) (ClickAbss t)) -> + T t (Class.Sound (ClickRels t) (BreakRel t) (ClickRels t) (ClickRels t)) +classRelativeFromAbsolute = + mapWithBounds $ \(from,_to) cls -> + case cls of + Class.Rasping clicks -> Class.Rasping $ fmap clickRelFromAbs clicks + Class.Ticking clicks -> Class.Ticking $ fmap clickRelFromAbs clicks + Class.Growling clicks -> Class.Growling $ fmap clickRelFromAbs clicks + Class.Chirping (BreakAbs brk) -> Class.Chirping $ BreakRel (brk-from) + Class.Other str -> Class.Other str + + +abstractFromSoundClassIntervals :: + (Additive.C t) => + T t (Class.Sound clicks chirping ticking clicks) -> + T t (Class.Abstract t clicks chirping ticking clicks) +abstractFromSoundClassIntervals = + let checkRasping = + (\(Pat.Interval bnds x) -> Class.Advertisement (snd bnds) x) + <$> + (Pat.maybe $ + \cls -> Class.maybeRasping cls <|> Class.maybeGrowling cls) + checkChirping = Pat.maybeLabel Class.maybeChirping + in applyPatternDefault + (Pat.flattenPair Pat.flatten1 Pat.flattenFoldable) + Class.NoAdvertisement $ + + Pat.combine + (Pat.fuseWith ($) checkRasping (Just <$> checkChirping)) + (Pat.optional + (fmap ($Nothing) checkRasping + `Pat.notFollowedBy` checkChirping)) + + +{- | +This is a hack to restore rasping-clicks +that were misclassified as chirpings. +-} +correctShortChirping :: + (Real.C t) => t -> T t String -> T t String +correctShortChirping maxDur = + applyPattern Pat.flatten2 $ Label.clickParts <$ + (Pat.guard (\(x0,x1) -> Pat.dur (x0&x1) <= maxDur) $ + Pat.match2 (Label.chirpingMain, Label.chirpingPause)) + +{- | +In r0-r1-p-r0-r1 merge the p with the preceding r1 +if the resulting r0-r1 is short enough to be admissible. +-} +mergeRaspingShortPause :: + (Real.C t) => t -> T t String -> T t String +mergeRaspingShortPause maxDur = + applyPattern Pat.flatten2 $ + Pat.mapMaybe + (\(x0,(x1,x2)) -> do + let x01 = x0&x1 + guard $ Pat.dur (x01&x2) <= maxDur + return $ Pat.intervalLabel x01) $ + + Pat.match Label.clickBegin + `Pat.combine` + Pat.fusedMatch2 (Label.clickEnd, Label.pause) + `Pat.followedBy` + Pat.match2 Label.clickParts diff --git a/src/LabelChainShifted.hs b/src/LabelChainShifted.hs new file mode 100644 --- /dev/null +++ b/src/LabelChainShifted.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE RebindableSyntax #-} +module LabelChainShifted ( + T(..), + fromLabelChain, + shiftToLabelChain, + toLabelTrack, + chopChain, + chopClosest, + subdivideTrack, + mask, + ) where + +import qualified Durations as Durs +import qualified LabelChain + +import qualified Sound.Audacity.LabelTrack as LabelTrack + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Control.Monad.Exception.Synchronous as ME +import Control.Applicative ((<$>)) + +import qualified Data.Monoid.HT as Mn +import qualified Data.Foldable as Fold +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Maybe.HT (toMaybe) +import Data.Tuple.HT (mapFst, mapSnd) + +import qualified Algebra.Absolute as Absolute +import qualified Algebra.Additive as Additive +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (readFile, writeFile, null) + + +{- | +A chain of labels with a starting time that may differ from zero. +-} +data T t a = Cons {offset :: t, chain :: [(t,a)]} + +instance Functor (T t) where + fmap f (Cons t xs) = Cons t $ map (mapSnd f) xs + +instance Fold.Foldable (T t) where + foldMap f = Fold.foldMap (f . snd) . chain + +fromLabelChain :: (Additive.C t) => LabelChain.T t a -> T t a +fromLabelChain = Cons zero . LabelChain.decons + +shiftToLabelChain :: (Additive.C t) => T t a -> LabelChain.T t a +shiftToLabelChain (Cons t xs) = + LabelChain.Cons $ map (mapFst (subtract t)) xs + +instance Durs.Track T where + intervalSizes (Cons t xs) = + Cons t $ ListHT.mapAdjacent1 (\n0 n1 lab -> (n1, (n1-n0, lab))) t xs + +toLabelTrack :: T t a -> LabelTrack.T t a +toLabelTrack (Cons t xs) = + LabelTrack.Cons . ListHT.mapAdjacent1 (\l r lab -> ((l,r), lab)) t $ xs + + +chopChain :: (Ord t) => LabelChain.T t a -> T t b -> [(a, T t b)] +chopChain ts xs0 = + SigG.crochetL + (\(t,a) xs -> toMaybe (not $ null xs) $ mapFst ((,) a) $ splitAtTime t xs) + xs0 (LabelChain.decons ts) + +_chopPattern0, _chopPattern1 :: (Ord t) => [t] -> T t a -> [T t a] +_chopPattern0 ts xs0 = + SigG.crochetL (\t xs -> toMaybe (not $ null xs) $ splitAtTime t xs) xs0 ts + +_chopPattern1 ts0 = + let go [] _ = [] + go (t:ts) xs = + if null xs + then [] + else + case splitAtTime t xs of + (ys,zs) -> ys : go ts zs + in go ts0 + + +subdivideTrack :: (Ord t) => LabelTrack.T t a -> T t b -> T t (Maybe a, b) +subdivideTrack ts xs0 = + (\(suffix, subd) -> + Cons (offset xs0) $ concat subd ++ chain (fmap ((,) Nothing) suffix)) $ + List.mapAccumL + (\xs ((t0,t1),a) -> + let (prefix, (ys, suffix)) = + mapSnd (splitAtTime t1) $ splitAtTime t0 xs + in (suffix, + chain ((,) Nothing <$> prefix) ++ + chain ((,) (Just a) <$> ys))) + xs0 (LabelTrack.decons ts) + + +null :: T t a -> Bool +null = List.null . chain + +splitAtTime :: (Ord t) => t -> T t a -> (T t a, T t a) +splitAtTime t = + let go xs@(Cons _ []) = (xs, Cons t []) + go xt@(Cons left ((right,lab):xs)) = + if t<=left + then (Cons t [], xt) + else + mapFst (cons left lab) $ + if t + t -> LabelChain.T t () -> T t a -> [ME.Exceptional (Maybe t) (T t a)] +chopClosest maxDev ts xs0 = + (\(remainingXs, zss) -> + zss ++ Mn.when (not $ null remainingXs) [ME.throw Nothing]) $ + List.mapAccumL + (\xs (t,()) -> + let (ys,zs) = splitAtClosestTime t xs + in (zs, + if abs (t - offset zs) <= maxDev + then ME.Success ys + else ME.Exception (Just t))) + xs0 (LabelChain.decons ts) + +splitAtClosestTime :: (Additive.C t, Ord t) => t -> T t a -> (T t a, T t a) +splitAtClosestTime t = + let go xs@(Cons _ []) = (xs, xs) + go (Cons left ((right,lab):xs)) = + if t<=right + then + mapFst (Cons left) $ + if t+t < left+right + then ([], Cons left ((right,lab):xs)) + else ([(right,lab)], Cons right xs) + else mapFst (cons left lab) $ go $ Cons right xs + in \xt@(Cons left _xs) -> + if t t -> T t a -> (T t a, T t a) +_splitAtClosestTime t = + let go xs@(Cons _ []) = (xs, Cons t []) + go (Cons left ((right,lab):xs)) = + if t<=right + then + if t+t < left+right + then (Cons t [], Cons t ((right,lab):xs)) + else (Cons left [(t,lab)], Cons t xs) + else mapFst (cons left lab) $ go $ Cons right xs + in \xt@(Cons left _xs) -> + if t a -> T t a -> T t a +cons t x xs = Cons t $ (offset xs, x) : chain xs + +mask :: (Ord t) => (t,t) -> T t a -> T t a +mask (l,r) = snd . splitAtTime l . fst . splitAtTime r diff --git a/src/LabelPattern.hs b/src/LabelPattern.hs new file mode 100644 --- /dev/null +++ b/src/LabelPattern.hs @@ -0,0 +1,306 @@ +{- | +Non-monadic parsers of intervals +where we use a restricted set of operations that preserve the invariants: + +* replacing intervals match the outer bounds of the replaced intervals + +* produced intervals do not overlap. +-} +module LabelPattern ( + Interval(..), + dur, + (&), + + Bounds, + fuseBounds, + + T, + next, + check, + match, + match2, + fusedMatch2, + maybe, + maybeLabel, + + alt, + combine, + expand, + fuse, + fuseWith, + guard, + many1, + mapMaybe, + move, + optional, + followedBy, + notFollowedBy, + atEnd, + precededBy, + terminatedBy, + snocMaybe, + + apply, + applyDefault, + Flatten, + flatten1, + flatten2, + flattenFoldable, + flattenPair, + ) where + +import qualified Sound.Audacity.LabelTrack as LabelTrack + +import qualified Control.Monad.Trans.State as MS +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad as Monad +import qualified Control.Functor.HT as FuncHT +import Control.Applicative (liftA2, (<$>), (<|>)) +import Control.Functor.HT (void) + +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List.HT as ListHT +import qualified Data.Foldable as Fold +import Data.Traversable (Traversable, traverse) +import Data.Foldable (Foldable) +import Data.Tuple.HT (mapPair, mapFst, mapSnd) +import Data.Maybe (isNothing) + +import qualified Algebra.Additive as Additive +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (maybe, map) + +import qualified Prelude as P + + +data Interval t a = Interval {intervalBounds :: Bounds t, intervalLabel :: a} + +type Bounds t = (t,t) + +instance Functor (Interval t) where + fmap f (Interval bnds a) = Interval bnds $ f a + +instance Foldable (Interval t) where + foldMap f (Interval _bnds a) = f a + +instance Traversable (Interval t) where + traverse f (Interval bnds a) = fmap (Interval bnds) $ f a + +pairFromInterval :: Interval t a -> LabelTrack.Interval t a +pairFromInterval (Interval bnds a) = (bnds, a) + +dur :: (Additive.C t) => Interval t a -> t +dur = uncurry subtract . intervalBounds + +{- | +The two intervals must be adjacent. +This is not checked. +-} +(&) :: + Interval t a -> + Interval t b -> + Interval t (a,b) +Interval bnds0 a & Interval bnds1 b = + Interval (fuseBounds bnds0 bnds1) (a,b) + +fuseBounds :: Bounds t -> Bounds t -> Bounds t +fuseBounds bnds0 bnds1 = (fst bnds0, snd bnds1) + + + +newtype + T t a bnds fb = Cons (MS.StateT (LabelTrack.T t a) Maybe (bnds, fb)) + +instance Functor (T t a bnds) where + fmap = map + +map :: (b -> c) -> T t a bnds b -> T t a bnds c +map f (Cons m) = Cons $ fmap (mapSnd f) m + + +viewL :: LabelTrack.T t a -> Maybe (Interval t a, LabelTrack.T t a) +viewL (LabelTrack.Cons xt) = + fmap (mapPair (uncurry Interval, LabelTrack.Cons)) $ ListHT.viewL xt + +next :: T t a (Bounds t) (Interval t a) +next = + Cons $ fmap (\x -> (intervalBounds x, x)) $ MS.StateT viewL + + +-- like Monoid.<> +infixr 6 `combine` + +combine :: T t a bnds0 b -> T t a bnds1 c -> T t a (bnds0,bnds1) (b,c) +combine (Cons f) (Cons g) = + Cons $ + liftA2 + (\(bnds0,x0) (bnds1,x1) -> ((bnds0,bnds1), (x0,x1))) + f g + +fuseCombined :: T t a (Pair (Bounds t)) b -> T t a (Bounds t) b +fuseCombined (Cons f) = Cons $ fmap (mapFst (uncurry fuseBounds)) f + +fuseWith :: + (b -> c -> d) -> + T t a (Bounds t) b -> T t a (Bounds t) c -> T t a (Bounds t) d +fuseWith h p q = uncurry h <$> fuse p q + +fuse :: T t a (Bounds t) b -> T t a (Bounds t) c -> T t a (Bounds t) (b,c) +fuse p q = fuseCombined $ combine p q + +move :: + (Additive.C t) => t -> T t a (Pair (Bounds t)) b -> T t a (Pair (Bounds t)) b +move d (Cons m) = + Cons $ fmap (mapFst (mapPair (mapSnd (d+), mapFst (d+)))) m + +guard :: (b -> Bool) -> T t a bnds b -> T t a bnds b +guard p (Cons m) = Cons $ Monad.mfilter (p . snd) m + +check :: (a -> Bool) -> T t a (Bounds t) (Interval t a) +check p = guard (p . intervalLabel) next + +match :: (Eq a) => a -> T t a (Bounds t) (Interval t a) +match a = check (a==) + +type Pair a = (a,a) + +match2 :: (Eq a) => Pair a -> T t a (Pair (Bounds t)) (Pair (Interval t a)) +match2 (x,y) = combine (match x) (match y) + +fusedMatch2 :: (Eq a) => Pair a -> T t a (Bounds t) (Pair (Interval t a)) +fusedMatch2 = fuseCombined . match2 + +infixl 3 `alt` + +alt :: T t a f b -> T t a f b -> T t a f b +alt (Cons x) (Cons y) = Cons (x<|>y) + +mapMaybe :: (b -> Maybe c) -> T t a bnds b -> T t a bnds c +mapMaybe f (Cons m) = Cons $ MT.lift . FuncHT.mapSnd f =<< m + +maybe :: (a -> Maybe b) -> T t a (Bounds t) (Interval t b) +maybe f = mapMaybe (traverse f) next + +maybeLabel :: (a -> Maybe b) -> T t a (Bounds t) b +maybeLabel f = mapMaybe (f . intervalLabel) next + +optional :: T t a bnds fa -> T t a (Maybe bnds) (Maybe fa) +optional (Cons m) = + Cons $ mapPair (Just, Just) <$> m <|> return (Nothing, Nothing) + +{- | +This is dangerous, +because it is not checked whether the outer interval bounds match. +-} +expand :: + (Functor f) => + T t a (Bounds t) (f (Interval t b)) -> T t a (f (Bounds t)) (f b) +expand (Cons m) = Cons (FuncHT.unzip . fmap pairFromInterval . snd <$> m) + + +infixr 6 `followedBy`, `notFollowedBy` + +followedBy :: T t a bnds0 b -> T t a bnds1 c -> T t a bnds0 b +followedBy (Cons p) (Cons q) = + Cons $ do + x0 <- p + s <- MS.get + void q + MS.put s + return x0 + +notFollowedBy :: T t a bnds0 b -> T t a bnds1 c -> T t a bnds0 b +notFollowedBy (Cons p) (Cons q) = + Cons $ do + x0 <- p + Monad.guard =<< MS.gets (isNothing . MS.evalStateT q) + return x0 + +atEnd :: T t a bnds b -> T t a bnds b +atEnd (Cons f) = + Cons $ do + x <- f + Monad.guard . LabelTrack.null =<< MS.get + return x + + +oneMore :: + T t a (Bounds t) b -> + T t a (Bounds t) (NonEmpty.T [] b) -> + T t a (Bounds t) (NonEmpty.T [] b) +oneMore p q = + alt + (fuseWith NonEmpty.cons p (NonEmpty.flatten <$> q)) + (NonEmpty.singleton <$> p) + +many1 :: T t a (Pair t) b -> T t a (Pair t) (NonEmpty.T [] b) +many1 p = + let go = oneMore p go + in go + +precededBy :: + T t a (Pair t) b -> T t a (Pair t) b -> T t a (Pair t) (NonEmpty.T [] b) +precededBy q p = oneMore q $ many1 p + +terminatedBy :: + (b -> c -> c) -> T t a (Pair t) b -> T t a (Pair t) c -> T t a (Pair t) c +terminatedBy f q p = + let go = alt (fuseWith f q go) p + in go + + +snocMaybe :: + T t a (Bounds t) (NonEmpty.T [] b) -> + T t a (Maybe (Bounds t)) (Maybe b) -> + T t a (Bounds t) (NonEmpty.T [] b) +snocMaybe (Cons p) (Cons q) = + Cons $ do + (bndx, x) <- p + (mbndy, my) <- q + return + (P.maybe bndx (fuseBounds bndx) mbndy, + P.maybe x (NonEmptyC.snoc x) my) + + + +newtype + Flatten bnds fa t a = + Flatten {runFlatten :: bnds -> fa -> [LabelTrack.Interval t a]} + +flatten1 :: Flatten (Bounds t) a t a +flatten1 = Flatten $ \bnds a -> [(bnds,a)] + +flatten2 :: Flatten (Pair (Bounds t)) (Pair a) t a +flatten2 = Flatten $ \(bnds0,bnds1) (a0,a1) -> [(bnds0,a0), (bnds1,a1)] + +flattenFoldable :: (Foldable f) => Flatten (f (Bounds t)) (f a) t a +flattenFoldable = + Flatten $ \bndss as -> zip (Fold.toList bndss) (Fold.toList as) + +flattenPair :: + Flatten bnds0 a0 t fa -> Flatten bnds1 a1 t fa -> + Flatten (bnds0, bnds1) (a0, a1) t fa +flattenPair (Flatten flattenFst) (Flatten flattenSnd) = + Flatten $ + \(bnds0,bnds1) (a0,a1) -> flattenFst bnds0 a0 ++ flattenSnd bnds1 a1 + + +apply :: + Flatten iv fa t a -> T t a iv fa -> LabelTrack.T t a -> LabelTrack.T t a +apply flatten = applyDefault flatten id + +applyDefault :: + Flatten iv fb t b -> + (a -> b) -> T t a iv fb -> LabelTrack.T t a -> LabelTrack.T t b +applyDefault flatten f (Cons p) = + let go xt = + case MS.runStateT p xt of + Just ((bnds,labs),xs) -> + LabelTrack.lift (runFlatten flatten bnds labs ++) $ go xs + Nothing -> + case viewL xt of + Just (x,xs) -> + LabelTrack.lift (pairFromInterval (fmap f x) :) $ go xs + Nothing -> LabelTrack.empty + in go diff --git a/src/LabelTrack.hs b/src/LabelTrack.hs new file mode 100644 --- /dev/null +++ b/src/LabelTrack.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE RebindableSyntax #-} +module LabelTrack ( + LabelTrack.T(..), + LabelTrack.Interval, + fromLabelChain, + maybeToLabelChain, + + LabelTrack.mapWithTime, + discretizeTimes, + discretizeTrack, + checkGaps, + checkOverlap, + realTimes, + shift, + LabelTrack.concat, + mergeNamesakes, + merge, + partition, + sortTime, + + -- in/out + readFile, + writeFile, + writeFileInt, + ) where + +import qualified LabelPattern as Pat +import qualified LabelChain +import qualified Rate + +import qualified Sound.Audacity.LabelTrack as ALabelTrack +import qualified Sound.Audacity.LabelTrack as LabelTrack +import qualified Signal +import Parameters (toTime) + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path +import Text.Printf (printf, ) + +import qualified Control.Monad.Exception.Synchronous as ME +import qualified Control.Functor.HT as FuncHT +import Control.Applicative ((<$), (<$>)) + +import qualified Data.NonEmpty.Mixed as NonEmptyM +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Foldable as Fold +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Function.HT (compose2) +import Data.Tuple.HT (swap, mapPair) +import Data.Ord.HT (comparing) +import Data.Maybe.HT (toMaybe) +import Data.Maybe (catMaybes) + +import qualified Algebra.RealRing as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (readFile, writeFile) + + +fromLabelChain :: (Additive.C t) => LabelChain.T t a -> LabelTrack.T t a +fromLabelChain = LabelChain.toLabelTrack + +shift :: (Ring.C t) => t -> LabelTrack.T t a -> LabelTrack.T t a +shift d = LabelTrack.mapTime (d+) + +concat :: LabelTrack.T time [a] -> LabelTrack.T time a +concat = + Fold.fold . + LabelTrack.mapWithTime + (\bnd msgs -> Fold.foldMap (LabelTrack.singleton bnd) msgs) + +_resizeChunks :: Double -> [Int] -> [Int] +_resizeChunks ratio = + snd . + List.mapAccumL + (\frac size -> + swap $ Real.splitFraction $ fromIntegral size * ratio + frac) + 0 + + +{- | +Sort labels with respect to start time and fail if intervals overlap. +-} +checkOverlap :: + (Rate.C rate) => + Signal.LabelTrack rate a -> ME.Exceptional String (Signal.LabelTrack rate a) +checkOverlap (Signal.Cons rate xs) = do + let sorted = sortTime xs + overlaps = + catMaybes $ + ListHT.mapAdjacent + (\(f0,t0) (f1,t1) -> + toMaybe (t0>f1) $ + printf "\nintervals (%f,%f) and (%f,%f) overlap" + (toTime rate f0) (toTime rate t0) + (toTime rate f1) (toTime rate t1)) $ + map fst $ LabelTrack.decons sorted + if null overlaps + then return $ Signal.Cons rate sorted + else ME.throw $ List.concat overlaps + +checkGaps :: + (Rate.C rate) => + Signal.LabelTrack rate a -> ME.Exceptional String (Signal.LabelChain rate a) +checkGaps sig@(Signal.Cons rate xs) = do + let gaps = + catMaybes . + ListHT.mapAdjacent1 + (\(_,t0) (t1,_) _lab -> + toMaybe (t0 /= t1) $ + printf "\ngap between: %f and %f" + (toTime rate t0) (toTime rate t1)) + (0,0) . + LabelTrack.decons + $ xs + + if null gaps + then return $ LabelChain.fromLabelTrack <$> sig + else ME.throw $ List.concat gaps + +discretizeTimes :: + (Rate.C rate) => rate -> LabelTrack.T Double a -> Signal.LabelTrack rate a +discretizeTimes sampleRate = + Signal.Cons sampleRate . + LabelTrack.mapTime (round . (Rate.unpack sampleRate *)) + +discretizeTrack :: + (Rate.C rate) => + rate -> LabelTrack.T Double a -> + ME.Exceptional String (Signal.LabelChain rate a) +discretizeTrack sampleRate = + checkGaps . discretizeTimes sampleRate + +maybeToLabelChain :: + (Rate.C rate) => + rate -> LabelTrack.T Double a -> + ME.Exceptional String (LabelChain.T Double a) +maybeToLabelChain rate xs = + LabelChain.fromLabelTrack xs <$ discretizeTrack rate xs + + +realTimes :: + (Rate.C rate) => Signal.LabelTrack rate label -> LabelTrack.T Double label +realTimes (Signal.Cons rate xs) = ALabelTrack.realTimes (Rate.unpack rate) xs + + +fuseMany :: NonEmpty.T [] (Pat.Bounds t) -> Pat.Bounds t +fuseMany bnds = Pat.fuseBounds (NonEmpty.head bnds) (NonEmpty.last bnds) + +mergeNamesakes :: (Eq t, Eq a) => LabelTrack.T t a -> LabelTrack.T t a +mergeNamesakes = + LabelTrack.lift $ + map (mapPair (fuseMany, NonEmpty.head) . FuncHT.unzip) . + NonEmptyM.groupBy + (\(bnds0,lab0) (bnds1,lab1) -> snd bnds0 == fst bnds1 && lab0 == lab1) + +merge :: (Ord t) => LabelTrack.T t a -> LabelTrack.T t a -> LabelTrack.T t a +merge = LabelTrack.lift2 $ ListHT.mergeBy (compose2 (<=) fst) + +partition :: + (a -> Bool) -> LabelTrack.T t a -> (LabelTrack.T t a, LabelTrack.T t a) +partition p = + mapPair (LabelTrack.Cons, LabelTrack.Cons) . + List.partition (p . snd) . LabelTrack.decons + +sortTime :: (Ord t) => LabelTrack.T t a -> LabelTrack.T t a +sortTime = LabelTrack.lift $ List.sortBy (comparing fst) + + +readFile :: + (PathClass.AbsRel ar) => + Path.File ar -> IO (LabelTrack.T Double String) +readFile = ALabelTrack.readFile . Path.toString + +writeFile :: + (PathClass.AbsRel ar) => + Path.File ar -> LabelTrack.T Double String -> IO () +writeFile = ALabelTrack.writeFile . Path.toString + +writeFileInt :: + (Rate.C rate, PathClass.AbsRel ar) => + rate -> Path.File ar -> LabelTrack.T Int String -> IO () +writeFileInt rate = ALabelTrack.writeFileInt (Rate.unpack rate) . Path.toString diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,2042 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +module Main where + +import qualified HiddenMarkovModel as HMM +import qualified Math.HiddenMarkovModel.Distribution as Distr +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 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.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.Container as NC + +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 -> Map HMM0.State String -> + String -> [(HMM0.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 :: + Map HMM0.State String -> + String -> [(HMM0.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 (HMM.checkedLookup dict state) LineSpec.deflt) <$> + Plot2D.list Graph2D.points emissions) $ + Array.assocs $ + Array.accumArray (flip (:)) [] + (fst $ Map.findMin dict, fst $ Map.findMax 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 -> + Map HMM0.State String -> + [(String, [(Float, Float)])] -> + [HMM0.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 HMM0.State -> + Map HMM0.State 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) -> Map HMM0.State String -> + Path.FilePath ar -> HMM0.GaussianTrained Double -> 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 HMM0.State -> [(String, Int)] -> IO () +printLabelCounts stateFromLabelMap labelCounts = + forM_ labelCounts $ \(label,count) -> do + printf "%003d %s\t%5d\n" + (case stateFromLabelMap Map.! label of Distr.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 :: HMM0.Gaussian Double -> HMM0.Gaussian Double -> IO () +printModelDifference hmmSup hmmUnsup = + void $ printf "difference between supervised and unsupervised: %f\n" $ + NC.maxElement $ NC.cmap abs $ + NC.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 -> [HMM0.State] -> IO () +writeMLPackStates outputStem part = + PathIO.writeFile (outputStem <-> "mlpack" <-> part <.> "csv") . unlines . + map (\(Distr.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 $ + HMM.checkedLookup 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 = HMM0.state 0 !: take (numStates-1) [HMM0.state 1 ..] + hmms = + HMM.takeUntilConvergence cvg $ iterate step $ + HMM0.uniform $ HMM0.distribution $ + HMM0.finishTraining $ HMM0.trainSupervised numStates $ + NonEmptyC.zip (NonEmpty.cycle states) prep + hmm = last hmms + labelFromStateMap = + Map.fromList $ map (\s -> (s, show $ fromEnum s)) $ + 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 $ + (\(Distr.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) => + HMMNamed.Gaussian Double -> + 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 diff --git a/src/Measurement.hs b/src/Measurement.hs new file mode 100644 --- /dev/null +++ b/src/Measurement.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE RebindableSyntax #-} +module Measurement where + +import qualified LabelChain +import qualified Fourier +import qualified Class +import qualified Named +import qualified SpectralDistribution as SD +import qualified Arithmetic as Arith +import qualified Parameters as Params +import qualified Rate +import qualified Signal +import qualified SignalProcessingMethods as SPMethods +import qualified SignalProcessing as SP +import SignalProcessingMethods (Triple, ) +import Parameters (Freq(Freq), ) + +import qualified Synthesizer.Generic.Analysis as AnaG +import qualified Synthesizer.Basic.Binary as Bin + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Control.Applicative.HT as AppHT +import qualified Control.Functor.HT as FuncHT +import Control.DeepSeq (NFData, rnf, ) +import Control.Applicative (Applicative, pure, (<*>), ) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import qualified Data.NonEmpty as NonEmpty +import Data.Tuple.HT (mapPair, ) +import Data.Maybe (mapMaybe, ) + +import qualified Algebra.Field as Field +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (id) + + +-- | LabelChain.mergePhases drops a trailing isolated chunk +mergeClickPhases :: [[a]] -> [[a]] +mergeClickPhases = + let go (x0:x1:xs) = (x0++x1) : go xs + go _ = [] + in go + +halfLife :: (Ord a, Field.C a) => NonEmpty.T [] a -> Int +halfLife xs = + let xm = NonEmpty.maximum xs + in length $ takeWhile (>= xm / 2) $ + dropWhile ( [Float] -> Int +countEmphasized params clickAmplitudes = + let progression = iterate (one+) zero + (c0,c1) = Arith.linearRegression $ zip progression clickAmplitudes + in length $ takeWhile (zero<) $ zipWith (-) clickAmplitudes $ + map (\k -> Params.emphasisExcess params * (c0+c1*k)) progression + + +type ClassFeatures = Class.Sound (Int, Int, Int) Int Int (Int, Int, Int) + +type ChunkFeatures = ((Int, Int, Int), Int) + +chunkFeatures :: + Params.T -> SVL.Vector Float -> SVL.Vector Float -> ChunkFeatures +chunkFeatures params volume featSig = + let clicks = + mergeClickPhases $ + LabelChain.chopMonotony + (mapPair (LabelChain.spanWeakRising, LabelChain.spanWeakFalling) $ + Params.weakCounterSlopeSizes params) $ + SVL.unpack featSig + in ((length clicks, + sum $ map halfLife $ mapMaybe NonEmpty.fetch clicks, + countEmphasized params $ + map NonEmpty.maximum $ mapMaybe (NonEmpty.fetch . SVL.unpack) $ + flip SP.chop (map length clicks) $ + SVL.zipWith (*) volume featSig), + SP.chirpingMainDur featSig) + + +bandFreq0, bandFreq1, bandFreq2 :: Float +bandFreq0 = 1000 +bandFreq1 = 2500 +bandFreq2 = 4000 + +bandFreqs :: Triple Freq +bandFreqs = (Freq bandFreq0, Freq bandFreq1, Freq bandFreq2) + + +data SpectralParameters a = + SpectralParameters { + spectralFlatness, spectralMaximum :: a, + spectralBandParams :: (a,a), + spectralDistribution :: (SD.T a) + } deriving Show + +instance (NFData a) => NFData (SpectralParameters a) where + rnf (SpectralParameters specFlat specMax bands distr) = + rnf (specFlat, specMax, bands, distr) + +instance Functor SpectralParameters where + fmap = Trav.fmapDefault + +instance Fold.Foldable SpectralParameters where + foldMap = Trav.foldMapDefault + +instance Trav.Traversable SpectralParameters where + traverse f (SpectralParameters specFlat specMax bands distr) = + pure SpectralParameters + <*> f specFlat <*> f specMax + <*> AppHT.mapPair (f,f) bands + <*> Trav.traverse f distr + +instance Applicative SpectralParameters where + pure x = SpectralParameters x x (x,x) (pure x) + SpectralParameters fSpecFlat fSpecMax fbands fdistr <*> + SpectralParameters specFlat specMax bands distr = + SpectralParameters + (fSpecFlat specFlat) (fSpecMax specMax) + (mapPair fbands bands) (fdistr <*> distr) + + +spectralParameters :: + (Float, Float) -> ((Float, Float), SD.T Float) -> + SpectralParameters Float +spectralParameters (flat, maxf) (bp, distr) = + SpectralParameters flat maxf bp distr + +spectrogramParameters :: [SV.Vector Float] -> (Float, Float) +spectrogramParameters specs = + (let blockFlats = map Fourier.spectralFlatness specs + in if null blockFlats then 1 else AnaG.average blockFlats, + let amax block = + fromIntegral (fst (SP.argMaximum block)) + / + fromIntegral (2 * (SV.length block-1)) + blockMaxs = map amax specs + in if null blockMaxs then 0 else AnaG.average blockMaxs) + + +classFromChunkFeatures :: + ChunkFeatures -> Class.Sound rasping chirping ticking growling -> + ClassFeatures +classFromChunkFeatures (clickMeasure@(numClicks, _, _), chirpMain) cls = + case cls of + Class.Rasping _ -> Class.Rasping clickMeasure + Class.Chirping _ -> Class.Chirping chirpMain + Class.Ticking _ -> Class.Ticking numClicks + Class.Growling _ -> Class.Growling clickMeasure + Class.Other str -> Class.Other str + +measureSignal :: + SPMethods.T -> Params.T -> + Signal.SoxLabelled (Class.Sound rasping chirping ticking growling) -> + ([ChunkFeatures], + (Signal.LabelChain Rate.Measure (SpectralParameters Float, ClassFeatures), + ([Float], Signal.T Rate.Measure [Named.Signal]))) +measureSignal sigProc params labelled = + let (sig, classified) = FuncHT.unzip labelled + intervalSizes = Fold.toList . fmap fst . LabelChain.intervalSizes + measRate = Params.measureSampleRate params + classifiedHighRate = Signal.body classified + classifiedMeasRate = + Signal.body $ Signal.labelResample measRate classified + dehummed = SPMethods.dehum sigProc sig + (volume, relEnv) = SPMethods.envelopeLowRate sigProc measRate dehummed + chunkFeats = + case intervalSizes classifiedMeasRate of + chunkSizes -> + zipWith (chunkFeatures params) + (SP.chop volume chunkSizes) + (SP.chop relEnv chunkSizes) + fourierStep = Params.fourierBlockStep params + fourierSize = Params.fourierBlockSize params + chunkSizesBlockRate = + intervalSizes $ + LabelChain.mapTime (max 0) $ + LabelChain.mapTime + (\n -> div (n + div (fourierStep-fourierSize) 2) fourierStep) $ + classifiedHighRate + spectroParams = + map spectrogramParameters $ + flip SP.chop chunkSizesBlockRate $ + Fourier.slice $ + Fourier.absoluteBlockSpectra fourierStep fourierSize $ + SP.svlConcat $ SVL.map Bin.toCanonical $ Signal.body sig + spectralDists = + zipWith spectralParameters spectroParams $ + SPMethods.bandParameters sigProc bandFreqs dehummed $ + intervalSizes classifiedHighRate + in (chunkFeats, + (Signal.Cons measRate $ + LabelChain.zipWithList (,) spectralDists $ + LabelChain.zipWithList classFromChunkFeatures + chunkFeats classifiedMeasRate, + ([1, 0.4], + Signal.Cons measRate + [Named.Cons "volume" volume, Named.Cons "envelope" relEnv]))) diff --git a/src/Named.hs b/src/Named.hs new file mode 100644 --- /dev/null +++ b/src/Named.hs @@ -0,0 +1,20 @@ +module Named where + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.NonEmpty as NonEmpty +import Control.DeepSeq (NFData, rnf, ) + + +data T a = Cons {name :: String, body :: a} +type Signal = T (SVL.Vector Float) +type NonEmptySignal = T (NonEmpty.T SVL.Vector Float) + +instance NFData body => NFData (T body) where + rnf (Cons rate xs) = rnf (rate, xs) + +instance Functor T where + fmap f (Cons str xs) = Cons str $ f xs + +apply :: String -> (a -> b) -> T a -> T b +apply prefix f (Cons str xs) = + Cons (prefix ++ " " ++ str) $ f xs diff --git a/src/Option.hs b/src/Option.hs new file mode 100644 --- /dev/null +++ b/src/Option.hs @@ -0,0 +1,228 @@ +module Option where + +import qualified Feature +import qualified Parameters as Params +import qualified HiddenMarkovModel as HMM + +import qualified Distribution.Verbosity as Verbosity +import qualified Distribution.ReadE as ReadE +import Distribution.Verbosity (Verbosity) + +import qualified Options.Applicative as OP + +import qualified SignalProcessingMethods as SPMethods +import qualified Data.StorableVector.Lazy as SVL +import qualified Sound.SoxLib as SoxLib + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path +import qualified System.IO as IO +import Text.Printf (printf, ) + +import Control.Monad (when, ) +import Control.Applicative (pure, (<*>), (<$>), (<|>), ) +import Control.Applicative.HT (liftA5, ) + +import qualified Data.Map as Map +import qualified Data.List as List +import Data.Monoid ((<>), ) + + + +data Flags = + Flags { + verbosity :: Verbosity, + chunkSize :: SVL.ChunkSize, + sampleRate :: Maybe SoxLib.Rate + } + deriving (Show) + + +optionVerbosity :: OP.ReadM Verbosity +optionVerbosity = + OP.eitherReader $ ReadE.runReadE Verbosity.flagToVerbosity + +-- cf. Distribution.Simple.Utils +noticeAction :: Flags -> IO () -> IO () +noticeAction flags emit = + when (verbosity flags >= Verbosity.normal) emit + +notice :: Flags -> String -> IO () +notice flags msg = noticeAction flags (putStrLn msg) + +infoAction :: Flags -> IO () -> IO () +infoAction flags emit = + when (verbosity flags >= Verbosity.verbose) emit + +infoMsg :: Flags -> String -> IO () +infoMsg flags msg = infoAction flags (putStrLn msg) + +warn :: Flags -> String -> IO () +warn flags msg = + when (verbosity flags >= Verbosity.normal) $ do + IO.hFlush IO.stdout + IO.hPutStr IO.stderr msg + + +parseFlags :: OP.Parser Flags +parseFlags = + pure Flags + <*> OP.option optionVerbosity + ( OP.value Verbosity.normal + <> OP.short 'v' + <> OP.long "verbose" + <> OP.metavar "0..3" + <> OP.help "verbosity" ) + <*> OP.option (fmap SVL.chunkSize OP.auto) + ( OP.value (SVL.chunkSize 65536) -- crashes SoX' FLAC writer + <> OP.long "chunksize" + <> OP.metavar "NUMSAMPLES" + <> OP.help "size of processing units" ) + <*> OP.option (fmap Just OP.auto) + ( OP.value Nothing + <> OP.long "samplerate" + <> OP.metavar "HERTZ" + <> OP.help "override sample rate of input files" ) + +model :: OP.Parser (IO Feature.HMM) +model = + OP.option (Feature.readHMM <$> path) $ + OP.long "model" <> + OP.metavar "PATH" <> + OP.value (return Feature.hmmHardwired) <> + OP.help "CSV file containing HMM parameters" + +path :: (PathClass.FileDir fd) => OP.ReadM (Path.AbsRel fd) +path = OP.eitherReader Path.parse + +numStates :: OP.Parser Int +numStates = + OP.option + (OP.eitherReader $ \str -> + case reads str of + [(n, "")] -> + if n>0 + then Right n + else Left "not positive" + _ -> Left "not an integer") $ + OP.long "numstates" <> + OP.metavar "NUMBER" <> + OP.help "number of states for Hidden Markov Model" <> + OP.value 6 + + +data TrainingFlags = + TrainingFlags { + trainingSignalProcessing :: SPMethods.T, + trainingFeature :: Feature.Class, + trainingConvergence :: HMM.Convergence, + trainingMLPack :: Bool, + trainingPlot :: Bool + } + +formatBool :: Bool -> String +formatBool b = if b then "yes" else "no" + +switch :: Bool -> String -> String -> OP.Parser Bool +switch deflt name helpMsg = + OP.flag' False (OP.long ("no-" ++ name)) + <|> + OP.flag deflt True + (OP.long name <> + OP.help (printf "%s (default: %s)" helpMsg (formatBool deflt))) + +feature :: Params.T -> OP.Parser (IO Feature.Class) +feature params = + let lookupFeature name = + case Map.lookup name Feature.dictionaryMerged of + Just feat -> return feat + Nothing -> + ioError $ userError $ unlines $ + printf "unknown feature \"%s\"" name : + "known features:" : + Map.keys Feature.dictionaryMerged + in OP.option (fmap lookupFeature OP.str) $ + OP.long "feature" <> + OP.metavar "NAME" <> + OP.value + (return $ Feature.lowRateSqrt $ Params.featureSampleRate params) <> + OP.help + ("one of " ++ + List.intercalate ", " (Map.keys Feature.dictionaryMerged)) + +plot :: OP.Parser Bool +plot = + OP.switch $ + OP.long "plot" <> + OP.help "show feature vectors grouped by model states" + +mlpack :: OP.Parser Bool +mlpack = + OP.switch $ + OP.long "mlpack" <> + OP.help "emit files that let you perform training using mlpack" + +trainingFlags :: + OP.Parser SPMethods.T -> Params.T -> OP.Parser (IO TrainingFlags) +trainingFlags signalProcessing params = + liftA5 + (\sigProc lookupFeature cvg mlp plt -> do + feat <- lookupFeature + return $ TrainingFlags sigProc feat cvg mlp plt) + signalProcessing (feature params) HMM.convergenceOptions mlpack plot + + +type Commands = OP.Mod OP.CommandFields + +simpleAction :: String -> String -> OP.Parser a -> Commands a +simpleAction name helpText act = + OP.command name $ OP.info (OP.helper <*> act) (OP.progDesc helpText) + +withInOutPaths :: + (PathClass.FileDir fd0, PathClass.FileDir fd1) => + (Flags -> Path.AbsRel fd0 -> Path.AbsRel fd1 -> IO ()) -> + (FilePath -> FilePath -> Flags -> IO ()) +withInOutPaths act = + \inputStr outputStr flags -> do + let ioExc = either (ioError . userError) return + input <- ioExc $ Path.parse inputStr + output <- ioExc $ Path.parse outputStr + act flags input output + +transferActionApp :: + (PathClass.FileDir fd0, PathClass.FileDir fd1) => + String -> String -> + OP.Parser + (Flags -> Path.AbsRel fd0 -> Path.AbsRel fd1 -> IO ()) -> + Commands (Flags -> IO ()) +transferActionApp name msg parser = + simpleAction name msg $ + OP.liftA3 withInOutPaths parser + (OP.strArgument (OP.metavar "SRC")) + (OP.strArgument (OP.metavar "DST")) + +transferAction :: + (PathClass.FileDir fd0, PathClass.FileDir fd1) => + String -> String -> + (Flags -> Path.AbsRel fd0 -> Path.AbsRel fd1 -> IO ()) -> + Commands (Flags -> IO ()) +transferAction name msg = transferActionApp name msg . pure + +multiAction :: + (PathClass.FileDir fd0, PathClass.FileDir fd1) => + String -> String -> + OP.Parser (Bool -> [Path.AbsRel fd0] -> Path.AbsRel fd1 -> a) -> + Commands a +multiAction name msg parse = + simpleAction name msg $ + parse + <*> plot + <*> OP.some (OP.argument path (OP.metavar "SRC")) + <*> OP.option path (OP.long "output" <> OP.metavar "DST") + + +info :: OP.Parser a -> OP.ParserInfo a +info parser = + OP.info + (OP.helper <*> parser) + (OP.fullDesc <> OP.progDesc "Classify sounds of xenopus laevis") diff --git a/src/Parameters.hs b/src/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/Parameters.hs @@ -0,0 +1,110 @@ +module Parameters where + +import qualified Rate + +import Text.Printf (printf, ) + + +newtype Time = Time Float + deriving (Eq, Ord, Show) + +newtype Freq = Freq Float + deriving (Eq, Ord, Show) + +getTime :: Time -> Float +getTime (Time t) = t + +getFreq :: Freq -> Float +getFreq (Freq f) = f + + +freq :: (Rate.C rate) => rate -> Freq -> Float +freq sr (Freq f) = f / realToFrac (Rate.unpack sr) + +time :: (Rate.C rate) => rate -> Time -> Int +time sr (Time t) = round (t * realToFrac (Rate.unpack sr)) + +timeCeil :: (Rate.C rate) => rate -> Time -> Int +timeCeil sr (Time t) = ceiling (t * realToFrac (Rate.unpack sr)) + +toTime :: (Rate.C rate) => rate -> Int -> Double +toTime rate n = fromIntegral n / Rate.unpack rate + + +formatFreq :: Freq -> String +formatFreq (Freq f) = printf "%.0fHz" f + + +data T = + Cons { + hardLowDist, hardHighDist, softLowDist, softHighDist :: Time, + minClickAttack :: Float, + halfDiffDist :: Time, + minClickDur :: Time, + volumeFrequency :: Freq, + envelopeFrequency :: Freq, + + emphasisExcess :: Float, + raspingMinNumClicks :: Int, + raspingMaxRelativeClickDistance :: Float, + maxInterimRumblingDur :: Time, + chirpingHackDur, chirpingMinDur, chirpingMaxDur :: Time, + chirpingMainDurMaxDeviation :: Time, + weakCounterSlopeSizes :: (Float, Float), + sampleRate :: Rate.Sample, + featureSampleRate :: Rate.Feature, + measureSampleRate :: Rate.Measure, + fourierBlockSize, fourierBlockStep :: Int + } + +deflt :: T +deflt = + Cons { + {- + mode for high part of the advertisement call: + 0.015 + + separation between low and high part of advertisement call: + 0.018 + + modes for rasping: + 0.026, 0.031 + + interval for regular values: + 0.022 - 0.034 + + some outlier distances at the beginning: + 0.049, 0.044, 0.047, 0.049, 0.048 + + some outlier distances within the rasping sound: + 0.053, 0.082, 0.053 + -} + hardLowDist = Time 0.018, + hardHighDist = Time 0.090, + softLowDist = Time 0.022, + softHighDist = Time 0.034, + minClickAttack = 0.2, + halfDiffDist = Time 0.0014, + minClickDur = Time 0.025, + volumeFrequency = Freq 10, + envelopeFrequency = Freq 70, + + emphasisExcess = 1.1, + raspingMinNumClicks = 3, + raspingMaxRelativeClickDistance = 1.5, + maxInterimRumblingDur = Time 0.1, + chirpingHackDur = Time 0.08, + chirpingMinDur = Time 0.15, + chirpingMaxDur = Time 0.8, + chirpingMainDurMaxDeviation = Time 0.01, + -- value 3 avoids zero-length r1 intervals in training1500.WAV + -- value 2 was better for counting clicks in some cases + -- weakCounterSlopeSizesBand20 = (3,3), + weakCounterSlopeSizes = (0.6,0.6), + sampleRate = Rate.Sample 11025, + featureSampleRate = Rate.Feature 200, + measureSampleRate = Rate.Measure 200, + -- Main.spectralParameters expects even block size + fourierBlockSize = 256, + fourierBlockStep = 128 + } diff --git a/src/Quantile.hs b/src/Quantile.hs new file mode 100644 --- /dev/null +++ b/src/Quantile.hs @@ -0,0 +1,43 @@ +{- +See also: statistics, order-statistics, interpolation +-} +module Quantile where + +import qualified Data.NonEmpty.Set as NESet +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty +import Data.NonEmpty ((!:)) + +import qualified Algebra.RealRing as Real +import qualified Algebra.Field as Field +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + +{- | +The function @discrete xs@ is the inverse cumulative distribution function +of the discrete distribution represented by @xs@. +It is a piecewise linear interpolation +between all numbers in @xs@ in ascending order. +In @discrete xs r@ the parameter @r@ must be between 0 and 1. +It is @discrete xs 0 == minimum xs@, +@discrete xs 1 == maximum xs@, +and @discrete xs 0 == median xs@. +-} +discrete :: (Field.C a, Real.C a) => NonEmpty.T [] a -> a -> a +discrete (NonEmpty.Cons x []) = const x +discrete xs = + case NESet.fromList $ NonEmptyC.zip xs $ (0::Int) !: [1 ..] of + set -> \r -> + if r==one + then fst $ NESet.findMax set + else + {- + 'Set.elemAt' would be faster than 'drop', + but is only available since GHC-7.8.4. + -} + let (k, frac) = splitFraction $ fromIntegral (NESet.size set - 1) * r + in case drop k $ NonEmpty.flatten $ NESet.toAscList set of + (x0,_):(x1,_):_ -> x0*(one-frac) + x1*frac + _ -> error "Quantile.discrete: unexpected empty list" diff --git a/src/Rate.hs b/src/Rate.hs new file mode 100644 --- /dev/null +++ b/src/Rate.hs @@ -0,0 +1,22 @@ +module Rate where + +import qualified Sound.SoxLib as SoxLib + + +class C rate where unpack :: rate -> SoxLib.Rate + +newtype Sample = Sample SoxLib.Rate deriving (Eq) +instance C Sample where unpack (Sample rate) = rate + +newtype Feature = Feature SoxLib.Rate deriving (Eq) +instance C Feature where unpack (Feature rate) = rate + +newtype Measure = Measure SoxLib.Rate deriving (Eq) +instance C Measure where unpack (Measure rate) = rate + + +ratio :: (C rate0, C rate1) => rate0 -> rate1 -> SoxLib.Rate +ratio r0 r1 = unpack r0 / unpack r1 + +featureFromSample :: Sample -> Feature +featureFromSample (Sample rate) = Feature rate diff --git a/src/Signal.hs b/src/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Signal.hs @@ -0,0 +1,73 @@ +module Signal where + +import qualified Rate + +import qualified LabelChain +import qualified Sound.Audacity.LabelTrack as LabelTrack + +import qualified Synthesizer.Generic.Cut as CutG +import qualified Data.StorableVector.Lazy as SVL + +import Control.DeepSeq (NFData, rnf, ) + +import Data.Traversable (Traversable, traverse) +import Data.Foldable (Foldable, foldMap) + +import Data.Int (Int32, ) + + +data T rate body = + Cons { + sampleRate :: rate, + body :: body + } + +type LabelTrack rate a = T rate (LabelTrack.T Int a) +type LabelChain rate a = T rate (LabelChain.T Int a) + +type Sampled a = T Rate.Sample (SVL.Vector a) +type Sox = Sampled Int32 +type SoxLabelled a = T Rate.Sample (SVL.Vector Int32, LabelChain.T Int a) + + +instance (Rate.C rate, NFData body) => NFData (T rate body) where + rnf (Cons rate xs) = rnf (Rate.unpack rate, xs) + +instance Functor (T rate) where + fmap f (Cons rate xs) = Cons rate $ f xs + +instance Foldable (T rate) where + foldMap f (Cons _rate xs) = f xs + +instance Traversable (T rate) where + traverse f (Cons rate xs) = fmap (Cons rate) $ f xs + + +-- | more descriptive than 'fmap' +map :: (a -> b) -> T rate a -> T rate b +map = fmap + +duration :: (Rate.C rate, CutG.Read signal) => T rate signal -> Double +duration (Cons rate xs) = + fromIntegral (CutG.length xs) / Rate.unpack rate + +labelRealTimes :: + (Rate.C rate) => LabelChain rate a -> LabelChain.T Double a +labelRealTimes (Cons rate xs) = LabelChain.realTimes rate xs + +labelDiscretizeTimes :: + (Rate.C rate) => + rate -> LabelChain.T Double a -> LabelChain rate a +labelDiscretizeTimes rate = + Cons rate . LabelChain.mapTime (round . (Rate.unpack rate *)) + +labelResample :: + (Rate.C rate0, Rate.C rate1) => + rate1 -> LabelChain rate0 a -> LabelChain rate1 a +labelResample rate = labelDiscretizeTimes rate . labelRealTimes + +addDiscretizedLabels :: + (Rate.C rate) => + T rate a -> LabelChain.T Double b -> T rate (a, LabelChain.T Int b) +addDiscretizedLabels (Cons rate as) bs = + Cons rate (as, body $ labelDiscretizeTimes rate bs) diff --git a/src/SignalProcessing.hs b/src/SignalProcessing.hs new file mode 100644 --- /dev/null +++ b/src/SignalProcessing.hs @@ -0,0 +1,303 @@ +module SignalProcessing where + +import qualified Rate +import Parameters (Freq, freq, ) + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilt +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Filter.Recursive as FiltRec +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Generic.Analysis as Ana +import qualified Synthesizer.Generic.Cut as Cut +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.State.Signal as SigS + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable, ) + +import qualified Control.Category as Cat +import Control.Arrow (Arrow, (^<<), (<<<), (&&&)) +import Control.DeepSeq (NFData, ($!!)) + +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Foldable as Fold +import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Traversable (Traversable, mapAccumL) +import Data.Foldable (Foldable, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Tuple.HT (swap, ) + +import qualified Algebra.RealRing as Real +import qualified Algebra.Field as Field +import qualified Algebra.Additive as Additive +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + + +{-# INLINE zerothMoment #-} +zerothMoment :: Causal.T Float Float +zerothMoment = + Causal.consInit 0 + +{-# INLINE firstMoment #-} +firstMoment :: Causal.T Float Float +firstMoment = + (\(x0,_x1,x2) -> (x2-x0)/2) ^<< lag2 + +{-# INLINE secondMoment #-} +secondMoment :: Causal.T Float Float +secondMoment = + (\(x0,x1,x2) -> x2-2*x1+x0) ^<< lag2 + +{-# INLINE lag2 #-} +lag2 :: (Additive.C a) => Causal.T a (a,a,a) +lag2 = lag2Init zero + +{-# INLINE lag2Init #-} +lag2Init :: a -> Causal.T a (a,a,a) +lag2Init x = + (\((x0,x1),x2) -> (x0,x1,x2)) + ^<< + (Causal.consInit x &&& Cat.id <<< Causal.consInit x) &&& Cat.id + + +{-# INLINE bandpass #-} +bandpass :: (Rate.C rate) => rate -> Float -> Freq -> Causal.T Float Float +bandpass rate q f = + UniFilt.bandpass + ^<< + UniFilt.causal + <<< + Causal.feedConstFst (UniFilt.parameter (FiltRec.Pole q (freq rate f))) + +{-# INLINE highpass #-} +highpass :: (Rate.C rate) => rate -> Float -> Freq -> Causal.T Float Float +highpass rate q f = + UniFilt.highpass + ^<< + UniFilt.causal + <<< + Causal.feedConstFst (UniFilt.parameter (FiltRec.Pole q (freq rate f))) + +{-# INLINE lowpass #-} +lowpass :: (Rate.C rate) => rate -> Float -> Freq -> Causal.T Float Float +lowpass rate q f = + UniFilt.lowpass + ^<< + UniFilt.causal + <<< + Causal.feedConstFst (UniFilt.parameter (FiltRec.Pole q (freq rate f))) + + +twoPasses :: + (Storable a) => + (SVL.Vector a -> SVL.Vector a) -> SVL.Vector a -> SVL.Vector a +twoPasses f = SVL.reverse . f . SVL.reverse . f + +lowpassOnePass :: + (Rate.C rate) => rate -> Freq -> SVL.Vector Float -> SVL.Vector Float +lowpassOnePass rate f sig = + let fr = freq rate f + in Causal.apply + (Filt1.lowpass_ + ^<< + Filt1.causalInit + (Ana.average $ Cut.take (ceiling (1/fr)) $ SigG.toState sig) + <<< + Causal.feedConstFst (Filt1.parameter fr)) + sig + +lowpassTwoPass :: + (Rate.C rate) => rate -> Freq -> SVL.Vector Float -> SVL.Vector Float +lowpassTwoPass rate f = twoPasses (lowpassOnePass rate f) + + + +-- ToDo: move to synthesizer-core:Causal.Filter +{-# INLINE differentiate #-} +differentiate :: Causal.T Float Float +differentiate = + Cat.id - Causal.consInit zero + +{-# INLINE differentiateMin3 #-} +differentiateMin3 :: Causal.T Float Float +differentiateMin3 = differentiateMin3Init zero + +{-# INLINE differentiateMin3Init #-} +differentiateMin3Init :: Float -> Causal.T Float Float +differentiateMin3Init x = + Cat.id + - + ((\(x0,x1,x2) -> x0 `min` x1 `min` x2) ^<< lag2Init x + <<< Causal.consInit x) + +{- | +This one produces narrow pikes for the click beginnings. +However this turns out to make the click recognition worse. +-} +differentiateMin3Narrow :: Causal.T Float Float +differentiateMin3Narrow = + (\(x, (x0,x1,x2)) -> + let xmin = x0 `min` x1 `min` x2 + xmax = x0 `max` x1 `max` x2 + in if x>xmax then x-xmin else x-x2) ^<< + Cat.id &&& (lag2 <<< Causal.consInit zero) + + +downSampleMax :: Int -> SVL.Vector Float -> SVL.Vector Float +downSampleMax k = + SigG.fromState SigG.defaultLazySize . + fmap SVL.maximum . Cut.sliceVertical k + + +downSampleChunkSizes :: + (Field.C t, Real.C t) => + t -> SigS.T Int +downSampleChunkSizes sizeFrac = + SigS.unfoldR + (\sizeRem -> Just $ splitFraction $ sizeRem + sizeFrac) + zero + + +{- +ToDo: move to synthesizer-core +could be generalized to Causal arrows +sometimes reversed parameter seems to be more appropriate +-} +chop :: (Traversable f, Cut.Transform sig) => sig -> f Int -> f sig +chop xs = snd . mapAccumL (\xsr d -> swap $ Cut.splitAt d xsr) xs + + +chopFrac :: Double -> SVL.Vector Float -> SigS.T (SVL.Vector Float) +chopFrac sizeFrac xs = + SigG.crochetL (\n xi -> toMaybe (not $ SVL.null xi) $ SVL.splitAt n xi) xs $ + downSampleChunkSizes sizeFrac + +{- | +It must be @sizeFrac >= 1@. +-} +downSampleMaxFrac :: Double -> SVL.Vector Float -> SVL.Vector Float +downSampleMaxFrac sizeFrac = + SigG.fromState SigG.defaultLazySize . fmap SVL.maximum . + chopFrac sizeFrac + +downSampleMaxAbsFrac :: Double -> SVL.Vector Float -> SVL.Vector Float +downSampleMaxAbsFrac sizeFrac = + SigG.fromState SigG.defaultLazySize . fmap Ana.volumeMaximum . + chopFrac sizeFrac + +downSampleAvgFrac :: Double -> SVL.Vector Float -> SVL.Vector Float +downSampleAvgFrac sizeFrac = + SigG.fromState SigG.defaultLazySize . fmap Ana.average . + chopFrac sizeFrac + + + +takeSlices :: (Cut.Transform sig) => Int -> sig -> [sig] -> [sig] +takeSlices blockSize xs = + Match.take (SigS.toList $ Cut.sliceVertical blockSize xs) + +-- ToDo: move to synthesizer-core +sliceOverlappingAbs, sliceOverlappingDiff, sliceOverlappingRel, + sliceOverlapping :: (Cut.Transform sig) => Int -> (Int,Int) -> sig -> [sig] + +sliceOverlappingAbs blockSize (pre,suf) xs = + takeSlices blockSize xs $ + map + (\t -> + let start = max 0 $ t-pre + stop = t+blockSize+suf + in Cut.take (stop-start) $ Cut.drop start xs) $ + iterate (blockSize+) 0 + +sliceOverlappingDiff blockSize (pre,suf) xs = + let offsets = iterate (blockSize+) (-pre) + in takeSlices blockSize xs $ + zipWith (\offset -> Cut.take (blockSize+pre+suf+min 0 offset)) offsets $ + snd $ List.mapAccumL (\xsi k -> (Cut.drop k xsi, xsi)) xs $ + ListHT.mapAdjacent subtract $ map (max 0) offsets + +sliceOverlappingRel blockSize (pre,suf) xs = + let offsets = iterate (min 0 . (blockSize+)) (-pre) + in takeSlices blockSize xs $ + zipWith (\offset -> Cut.take (blockSize+pre+suf+offset)) offsets $ snd $ + List.mapAccumL + (\xsi offset -> (Cut.drop (max 0 $ offset+blockSize) xsi, xsi)) + xs offsets + +sliceOverlapping = sliceOverlappingRel + +propSliceOverlapping :: NonEmpty.T [] Int -> ([Int], [Int]) -> String -> Bool +propSliceOverlapping blockSizeList (preList,sufList) xs = + let blockSize = length $ NonEmpty.flatten blockSizeList + pre = length preList + suf = length sufList + in ListHT.allEqual $ + sliceOverlappingAbs blockSize (pre,suf) xs : + sliceOverlappingDiff blockSize (pre,suf) xs : + sliceOverlappingRel blockSize (pre,suf) xs : + [] + + +centroidVariance3 :: + Field.C a => (a, a) -> (a, a) -> (a, a) -> (a, a) +centroidVariance3 (f0,x0) (f1,x1) (f2,x2) = + let s = x0+x1+x2 + mean y0 y1 y2 = (y0*x0 + y1*x1 + y2*x2) / s + center = mean f0 f1 f2 + in (center, mean ((f0-center)^2) ((f1-center)^2) ((f2-center)^2)) + + +svlConcat :: SVL.Vector Float -> SV.Vector Float +svlConcat = SV.concat . SVL.chunks + + +foldLength :: (Foldable f) => f a -> Int +foldLength = length . Fold.toList + + +{- +ToDo: move to utility-ht? +could be the basis of a Synthesizer.State.argmax function +it is now included in 'semigroups' but with swapped order +better maxKey :: (Ord b) => (a -> b) -> a -> a -> a ? +-} +argMax :: (Ord b) => (a,b) -> (a,b) -> (a,b) +argMax x0 x1 = + if snd x0 >= snd x1 then x0 else x1 + +argMin :: (Ord b) => (a,b) -> (a,b) -> (a,b) +argMin x0 x1 = + if snd x0 <= snd x1 then x0 else x1 + +-- ToDo: move to synthesizer-core +argMaximum :: + (NFData a, Ord a, Additive.C a, SigG.Read sig a) => sig a -> (Int, a) +argMaximum = + SigS.foldL (\x y -> (argMax $!! x) y) (0,zero) . + SigS.zip (SigS.iterate (1+) 0) . SigG.toState + + + +{-# INLINE fanout3 #-} +fanout3 :: + (Arrow arrow) => + arrow a b -> arrow a c -> arrow a d -> arrow a (b,c,d) +fanout3 arrb arrc arrd = + (\(b,(c,d)) -> (b,c,d)) ^<< arrb &&& arrc &&& arrd + + + +chirpingPauseDur :: SVL.Vector Float -> Int +chirpingPauseDur xs = + let x = Ana.average xs + in SVL.length $ SVL.takeWhile (<=x) $ SVL.reverse xs + +chirpingMainDur :: SVL.Vector Float -> Int +chirpingMainDur xs = + SVL.length xs - chirpingPauseDur xs diff --git a/src/SignalProcessingMethods.hs b/src/SignalProcessingMethods.hs new file mode 100644 --- /dev/null +++ b/src/SignalProcessingMethods.hs @@ -0,0 +1,43 @@ +module SignalProcessingMethods where + +import qualified SpectralDistribution as SD +import qualified Signal +import qualified Rate +import SignalProcessing (lowpassTwoPass, ) +import Parameters (Freq(Freq), ) + +import qualified Sound.SoxLib as SoxLib +import qualified Data.StorableVector.Lazy as SVL + + +type Triple a = (a,a,a) + +data T = + Cons { + dehum :: Signal.Sox -> Signal.Sampled Float, + rumble :: Signal.Sox -> Signal.Sampled Float, + downSampleAbs :: + SoxLib.Rate -> Signal.Sampled Float -> SVL.Vector Float, + bandpassDownSample :: + Rate.Feature -> Freq -> Signal.Sox -> SVL.Vector Float, + bandParameters :: + Triple Freq -> Signal.Sampled Float -> + [Int] -> [((Float, Float), SD.T Float)] + } + +envelopeLowRate :: + (Rate.C rate) => + T -> rate -> Signal.Sampled Float -> + (SVL.Vector Float, SVL.Vector Float) +envelopeLowRate methods featRate sig = + let env = downSampleAbs methods (Rate.unpack featRate) sig + volume = lowpassTwoPass featRate (Freq 20) env + in (volume, SVL.zipWith (/) env volume) + +dehummedEnvelopeLowRate :: + (Rate.C rate) => + T -> rate -> Signal.Sox -> (SVL.Vector Float, SVL.Vector Float) +dehummedEnvelopeLowRate methods featRate sig = + let env = downSampleAbs methods (Rate.unpack featRate) $ dehum methods sig + volume = lowpassTwoPass featRate (Freq 20) env + in (volume, SVL.zipWith (/) env volume) diff --git a/src/SignalProcessingSpecific.hs b/src/SignalProcessingSpecific.hs new file mode 100644 --- /dev/null +++ b/src/SignalProcessingSpecific.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE RebindableSyntax #-} +module SignalProcessingSpecific where + +import qualified Signal +import qualified Named +import qualified Rate +import Parameters (Freq(Freq), formatFreq, ) + +import qualified SpectralDistribution as SD +import qualified SignalProcessingMethods as Methods +import qualified SignalProcessing as SP +import SignalProcessingMethods (Triple, ) +import SignalProcessing + (bandpass, highpass, lowpassTwoPass, + downSampleMaxFrac, downSampleMaxAbsFrac, fanout3, ) + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Basic.Binary as Bin + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.List as List +import Control.Arrow ((&&&), (^<<), (<<^), ) +import Data.Tuple.HT (mapSnd, fst3, snd3, thd3, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{-# INLINE dehum #-} +dehum :: Rate.Sample -> Causal.T Float Float +dehum rate = highpass rate 1 (Freq 800) + + +filterBand :: Float -> Freq -> Signal.Sox -> Named.Signal +filterBand q f (Signal.Cons rate sig) = + Named.Cons ("band " ++ formatFreq f) $ + Causal.apply (abs ^<< bandpass rate q f <<^ Bin.toCanonical) sig + +{- +We have checked with a chirp that the bands slightly overlap. +-} +filterBands :: + Signal.Sox -> (Named.Signal, (Named.Signal, Named.Signal, Named.Signal)) +filterBands sig = + ((filterBand 2 (Freq 1600) sig) {Named.name = "dehummed"}, + (filterBand 10 (Freq 1200) sig, + filterBand 10 (Freq 2000) sig, + filterBand 10 (Freq 4000) sig)) + +bandEnvelopes :: + Signal.Sox -> (Named.Signal, (Named.Signal, Named.Signal, Named.Signal)) +bandEnvelopes sig@(Signal.Cons rate _) = + let (broadband, (band12, band20, band40)) = filterBands sig + volume = lowpassTwoPass rate (Freq 20) $ Named.body broadband + envelope xs = SVL.zipWith (/) (lowpassTwoPass rate (Freq 200) xs) volume + in (Named.Cons "volume" volume, + (fmap envelope band12, fmap envelope band20, fmap envelope band40)) + + +bandEnvelopesLowRate :: + Rate.Feature -> Signal.Sox -> + (Named.Signal, (Named.Signal, Named.Signal, Named.Signal)) +bandEnvelopesLowRate featRate sig = + let (broadband, (band12, band20, band40)) = filterBands sig + -- ToDo: would be simpler, if broadband contains the sample rate + k = Rate.ratio (Signal.sampleRate sig) featRate + volume = + lowpassTwoPass featRate (Freq 20) $ + downSampleMaxFrac k $ Named.body broadband + envelope xs = SVL.zipWith (/) (downSampleMaxFrac k xs) volume + in (Named.Cons "volume" volume, + (fmap envelope band12, fmap envelope band20, fmap envelope band40)) + + +{-# INLINE bandsDerivatives #-} +bandsDerivatives :: + Triple Freq -> Signal.Sampled Float -> + SVL.Vector (Triple Float, Triple Float) +bandsDerivatives bandFreqs (Signal.Cons rate sig) = + Causal.apply + (let band f = bandpass rate 10 (f bandFreqs) + in fanout3 (band fst3) (band snd3) (band thd3) + &&& + fanout3 SP.zerothMoment SP.firstMoment SP.secondMoment) + sig + + +spectralDistribution1Slow, spectralDistribution2Slow :: + SVL.Vector (Triple Float) -> SD.T Float +spectralDistribution1Slow chunk = + let partSum sel = SigG.sum $ SigG.map (abs.sel) $ SigG.toState chunk + in SD.spectralDistribution1 + (partSum fst3) (partSum snd3) (partSum thd3) + +spectralDistribution2Slow chunk = + let partSum sel = SigG.sum $ SigG.map ((^2).sel) $ SigG.toState chunk + in SD.spectralDistribution2 + (partSum fst3) (partSum snd3) (partSum thd3) + + +sumSV :: SV.Vector Float -> Float +sumSV = SV.foldl' (+) 0 + +_sumSVL :: SVL.Vector Float -> Float +_sumSVL = sum . map sumSV . SVL.chunks + + +addSumSV :: Float -> SV.Vector Float -> Float +addSumSV = SV.foldl' (+) + +{- | +Consistently sum with left associativity. +This is consistent with the LLVM implementation. +-} +sumSVL :: SVL.Vector Float -> Float +sumSVL = List.foldl' addSumSV 0 . SVL.chunks + + +spectralDistribution1, spectralDistribution2 :: + SVL.Vector (Triple Float) -> SD.T Float +spectralDistribution1 chunk = + SD.spectralDistribution1 + (sumSVL $ SVL.map (abs.fst3) chunk) + (sumSVL $ SVL.map (abs.snd3) chunk) + (sumSVL $ SVL.map (abs.thd3) chunk) + +spectralDistribution2 chunk = + SD.spectralDistribution2 + (sumSVL $ SVL.map ((^2).fst3) chunk) + (sumSVL $ SVL.map ((^2).snd3) chunk) + (sumSVL $ SVL.map ((^2).thd3) chunk) + + +spectralBandDistr :: Triple Freq -> SVL.Vector (Triple Float) -> (Float, Float) +spectralBandDistr (Freq bandFreq0, Freq bandFreq1, Freq bandFreq2) chunk = + mapSnd sqrt $ + SP.centroidVariance3 + (bandFreq0, sumSVL $ SVL.map (abs.fst3) chunk) + (bandFreq1, sumSVL $ SVL.map (abs.snd3) chunk) + (bandFreq2, sumSVL $ SVL.map (abs.thd3) chunk) + +bandParameters :: + Triple Freq -> SVL.Vector (Triple Float, Triple Float) -> + ((Float, Float), SD.T Float) +bandParameters bandFreqs chunk = + (spectralBandDistr bandFreqs (SVL.map fst chunk), + spectralDistribution1 (SVL.map snd chunk)) + + +methods :: Methods.T +methods = + Methods.Cons { + Methods.dehum = + \(Signal.Cons rate xs) -> + Signal.Cons rate $ Causal.apply (dehum rate <<^ Bin.toCanonical) xs, + + Methods.rumble = + \(Signal.Cons rate xs) -> + Signal.Cons rate $ + Causal.apply (SP.lowpass rate 5 (Freq 220) <<^ Bin.toCanonical) xs, + + Methods.downSampleAbs = + \featRate (Signal.Cons rate xs) -> + downSampleMaxAbsFrac (Rate.unpack rate / featRate) xs, + + Methods.bandpassDownSample = + \featRate f (Signal.Cons rate xs) -> + downSampleMaxAbsFrac (Rate.ratio rate featRate) $ + Causal.apply (bandpass rate 10 f <<^ Bin.toCanonical) xs, + + Methods.bandParameters = + \bandFreqs sig sizes -> + map (bandParameters bandFreqs) $ + SP.chop (bandsDerivatives bandFreqs sig) sizes + } diff --git a/src/Sox.hs b/src/Sox.hs new file mode 100644 --- /dev/null +++ b/src/Sox.hs @@ -0,0 +1,110 @@ +module Sox where + +import qualified Named +import qualified Parameters as Params +import qualified Signal +import qualified Rate + +import qualified Option + +import qualified Synthesizer.Basic.Binary as Bin +import qualified Sound.SoxLib as SoxLib + +import qualified Data.StorableVector.Lazy as SVL +import Foreign.Storable (peek) + +import Control.Monad (when) +import Control.Applicative ((<$>)) + +import qualified Data.List as List +import Data.Maybe (fromMaybe) + +import qualified System.Path.PartClass as PathClass +import qualified System.Path.IO as PathIO +import qualified System.Path as Path +import Text.Printf (printf) + +import qualified Algebra.RealRing as Real + +import Data.Int (Int32) + + +withSound :: + (PathClass.AbsRel ar) => + Option.Flags -> Path.FilePath ar -> + (SoxLib.Format SoxLib.ReadMode -> Signal.Sox -> IO b) -> + IO b +withSound flags path act = + SoxLib.withRead SoxLib.defaultReaderInfo (Path.toString path) $ \fmtPtr -> do + fmt <- peek fmtPtr + let numChan = fromMaybe 1 $ SoxLib.channels $ SoxLib.signalInfo fmt + rate = + case Option.sampleRate flags of + Just r -> Rate.Sample r + Nothing -> + case SoxLib.rate $ SoxLib.signalInfo fmt of + Just r -> Rate.Sample r + Nothing -> Params.sampleRate Params.deflt + when (numChan/=1) $ + ioError $ userError $ + printf "expected mono file but got %d channels" numChan + act fmt . Signal.Cons rate =<< + SoxLib.readStorableVectorLazy fmtPtr + (case Option.chunkSize flags of + SVL.ChunkSize size -> SVL.ChunkSize $ numChan * size) + + +multiInfoFromFormat :: + (Rate.C rate) => Int -> SoxLib.Format mode -> rate -> SoxLib.WriterInfo +multiInfoFromFormat numChannels fmtIn rate = + SoxLib.defaultWriterInfo { + SoxLib.writerSignalInfo = Just $ + (SoxLib.signalInfo fmtIn) { + SoxLib.channels = Just numChannels, + SoxLib.length = + (numChannels *) <$> SoxLib.length (SoxLib.signalInfo fmtIn), + SoxLib.rate = Just $ Rate.unpack rate + } + } + +writerInfoFromFormat :: + (Rate.C rate) => SoxLib.Format mode -> rate -> SoxLib.WriterInfo +writerInfoFromFormat fmtIn rate = + SoxLib.defaultWriterInfo { + SoxLib.writerSignalInfo = Just $ + (SoxLib.signalInfo fmtIn) { + SoxLib.rate = Just $ Rate.unpack rate + } + } + + +writeChannels :: + (Rate.C rate, PathClass.AbsRel ar) => + SoxLib.Format mode -> rate -> Path.FilePath ar -> + [SVL.Vector Int32] -> IO () +writeChannels fmtIn rate output sigs = + SoxLib.withWrite (multiInfoFromFormat (length sigs) fmtIn rate) + (Path.toString output) $ \fmtOut -> + SoxLib.writeStorableVectorLazy fmtOut $ + SVL.interleaveFirstPattern sigs + +writeFeatures :: + (Rate.C rate, PathClass.AbsRel ar) => + SoxLib.Format mode -> Path.FilePath ar -> + [Float] -> Signal.T rate [Named.Signal] -> IO () +writeFeatures fmtIn output scales (Signal.Cons rate featSigs) = + writeChannels fmtIn rate output $ + zipWith + (\c -> + SVL.map (Bin.fromCanonicalWith Real.roundSimple . (c*)) . Named.body) + scales featSigs + +_writeFeatures :: + (Rate.C rate, PathClass.AbsRel ar) => + SoxLib.Format mode -> Path.FilePath ar -> + [Float] -> Signal.T rate [Named.Signal] -> IO () +_writeFeatures _fmtIn output _scales (Signal.Cons rate featSigs) = + PathIO.writeFile (Path.replaceExtension output "dat") $ unlines $ + show (Rate.unpack rate) : + (map (unwords . map show) $ List.transpose $ + map (SVL.unpack . Named.body) featSigs) diff --git a/src/SpectralDistribution.hs b/src/SpectralDistribution.hs new file mode 100644 --- /dev/null +++ b/src/SpectralDistribution.hs @@ -0,0 +1,68 @@ +module SpectralDistribution where + +import Control.Applicative (Applicative, liftA2, pure, (<*>), ) +import Control.DeepSeq (NFData, rnf, ) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold + +import Foreign.Storable.Record as Store +import Foreign.Storable (Storable (..), ) + +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + +data T a = Cons {centroid, spread :: a} + deriving (Eq, Show) + +instance (NFData a) => NFData (T a) where + rnf (Cons c s) = rnf (c,s) + +instance Functor T where + fmap = Trav.fmapDefault + +instance Applicative T where + pure x = Cons x x + Cons fc fs <*> Cons c s = Cons (fc c) (fs s) + +instance Fold.Foldable T where + foldMap = Trav.foldMapDefault + +instance Trav.Traversable T where + traverse f (Cons c s) = liftA2 Cons (f c) (f s) + + +store :: Storable a => Store.Dictionary (T a) +store = + Store.run $ + liftA2 Cons + (Store.element centroid) + (Store.element spread) + +instance Storable a => Storable (T a) where + sizeOf = Store.sizeOf store + alignment = Store.alignment store + peek = Store.peek store + poke = Store.poke store + + +mapSpread :: (a -> a) -> T a -> T a +mapSpread f (Cons c s) = Cons c (f s) + + +{-# INLINE spectralDistribution1 #-} +spectralDistribution1 :: Float -> Float -> Float -> T Float +spectralDistribution1 d0 d1 d2 = + let r1 = d1/d0 in Cons r1 (d2/d0 - r1^2) + + +{-# INLINE signedSqrt #-} +signedSqrt :: Float -> Float +signedSqrt x = signum x * sqrt (abs x) + +{-# INLINE spectralDistribution2 #-} +spectralDistribution2 :: Float -> Float -> Float -> T Float +spectralDistribution2 d0 d1 d2 = + let r1 = d1/d0 in Cons (sqrt r1) (signedSqrt (d2/d0 - r1^2)) diff --git a/src/SpectralDistributionTest.hs b/src/SpectralDistributionTest.hs new file mode 100644 --- /dev/null +++ b/src/SpectralDistributionTest.hs @@ -0,0 +1,179 @@ +module Main where + +import qualified SpectralDistribution as SD +import qualified SignalProcessing as SP + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilt +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Filter.Recursive as FiltRec +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.State.Filter.NonRecursive as FiltNR +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.State.Oscillator as Osci +import qualified Synthesizer.State.Displacement as Disp +import qualified Synthesizer.State.Control as Ctrl +import qualified Synthesizer.State.Noise as Noise +import qualified Synthesizer.Causal.Process as Causal + +import Synthesizer.Causal.Class (($<), ($*), ) + +import qualified Data.StorableVector.Lazy as SVL + +import Control.Arrow ((&&&), (<<<), (^<<), (<<^), ) +import Control.Monad (liftM2, ) + +import Data.Foldable (forM_, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + +frequency :: Float +frequency = 0.01 + +duration :: Int +duration = 50000 + +toneEnvelope :: SigS.T Float +toneEnvelope = + FiltNR.envelope (Ctrl.exponential 20000 1) $ + Osci.staticSine zero frequency + +toneChirp :: SigS.T Float +toneChirp = + Osci.freqModSine zero $ + Ctrl.exponential 10000 (0.1::Float) + +{- | +@sqrt@ asserts that the spectral centroid stays constant. +This works, because our time-domain definition of spectral centroid +computes the quadratic mean of frequencies. +-} +toneBroaden :: SigS.T Float +toneBroaden = + FiltNR.amplify 0.5 $ + Disp.mix + (Osci.freqModSine zero $ fmap sqrt $ + Ctrl.line duration (0.01, 0.02::Float)) + (Osci.freqModSine zero $ fmap sqrt $ + Ctrl.line duration (0.01, 0::Float)) + + +toneMix :: Float -> Float -> SigS.T Float +toneMix freq0 freq1 = + FiltNR.amplify 0.5 $ + Disp.mix + (Osci.staticSine zero freq0) + (Osci.staticSine zero freq1) + + + +noiseEnvelope :: SigS.T Float +noiseEnvelope = + FiltNR.envelope (Ctrl.exponential 20000 1) Noise.white + +noiseChirp :: SigS.T Float +noiseChirp = + (UniFilt.bandpass ^<< UniFilt.causal) + $< SigS.map + (UniFilt.parameter . FiltRec.Pole 10) + (Ctrl.exponential 10000 (0.1::Float)) + $* Noise.white + +noiseBroaden :: SigS.T Float +noiseBroaden = + (UniFilt.bandpass ^<< UniFilt.causal) + $< SigS.map + (UniFilt.parameter . flip FiltRec.Pole frequency) + (Ctrl.exponential 10000 (100::Float)) + $* FiltNR.amplify 0.5 Noise.white + + + +smooth :: Causal.T Float Float +smooth = + Filt1.lowpass_ + ^<< + Filt1.causal + <<< + Causal.feedConstFst (Filt1.parameter (0.0002::Float)) + + +volume :: SigS.T Float -> Float +volume = SigS.sum . SigS.map abs + +followEnvelope :: Causal.T Float Float +followEnvelope = smooth <<^ abs + +spectralDistribution1 :: Causal.T Float (SD.T Float) +spectralDistribution1 = + (\(d0,(d1,d2)) -> + SD.mapSpread SD.signedSqrt $ SD.spectralDistribution1 d0 d1 d2) + ^<< + (followEnvelope <<< SP.zerothMoment) &&& + (followEnvelope <<< SP.firstMoment) &&& + (followEnvelope <<< SP.secondMoment) + + +volumeSquare :: SigS.T Float -> Float +volumeSquare = SigS.sum . SigS.map (^2) + +meanSquare :: Causal.T Float Float +meanSquare = smooth <<^ (^2) + +spectralDistribution2 :: Causal.T Float (SD.T Float) +spectralDistribution2 = + (\(d0,(d1,d2)) -> + SD.mapSpread SD.signedSqrt $ SD.spectralDistribution2 d0 d1 d2) + ^<< + (meanSquare <<< SP.zerothMoment) &&& + (meanSquare <<< SP.firstMoment) &&& + (meanSquare <<< SP.secondMoment) + + +main :: IO () +main = do + forM_ [(0.01, 0.01), (0.01, 0.01*sqrt 2), (0.01, 0.02), (0.01, 0.04)] $ + \(freq0,freq1) -> + let sig = SigS.take 100000 $ toneMix freq0 freq1 + d0 = volume $ Causal.apply SP.zerothMoment sig + d1 = volume $ Causal.apply SP.firstMoment sig + d2 = volume $ Causal.apply SP.secondMoment sig + (SD.Cons centroid1 spread1) = SD.spectralDistribution1 d0 d1 d2 + s0 = volumeSquare $ Causal.apply SP.zerothMoment sig + s1 = volumeSquare $ Causal.apply SP.firstMoment sig + s2 = volumeSquare $ Causal.apply SP.secondMoment sig + (SD.Cons centroid2 spread2) = SD.spectralDistribution2 s0 s1 s2 + r1 = s1/s0 + in do + putStrLn $ "\nfreqs: " ++ show (freq0,freq1) + print (s0, s1, s2, s1/s0, s2/s1) + print (s2/s0, r1^2, s2/s0-r1^2) + print + (sqrt ((freq0^2+freq1^2)/2), + (centroid1 / (2*pi), sqrt spread1 / (2*pi)), + (centroid2 / (2*pi), sqrt spread2 / (2*pi))) + + let signals = + ("tone-env", toneEnvelope) : + ("tone-chirp", toneChirp) : + ("tone-broaden", toneBroaden) : + ("noise-env", noiseEnvelope) : + ("noise-chirp", noiseChirp) : + ("noise-broaden", noiseBroaden) : + [] + write process filename = + SVL.writeFile filename . + SigG.fromState SigG.defaultLazySize . SigS.take duration . process + renderers = + ("", write id) : + ("-distribution1", write $ Causal.apply spectralDistribution1) : + ("-distribution2", write $ Causal.apply spectralDistribution2) : + [] + + sequence_ $ + liftM2 + (\(featureName,render) (signalName,signal) -> + render ("/tmp/" ++ signalName ++ featureName ++ ".f32") signal) + renderers signals diff --git a/src/Spreadsheet/Format.hs b/src/Spreadsheet/Format.hs new file mode 100644 --- /dev/null +++ b/src/Spreadsheet/Format.hs @@ -0,0 +1,1153 @@ +{-# LANGUAGE RebindableSyntax #-} +module Spreadsheet.Format ( + Results, + Measurements, + AllPaths, + TableFormats(..), + + Flags(..), defaultFlags, + RecordingFlags(..), + + writeOverviewHead, + writeOverviewFoot, + appendOverview, + appendTreatmentOverview, + formatTables, + + -- * utility + (<->), + ) where + +import qualified LabelTrack +import qualified LabelChain +import qualified Durations as Durs +import qualified ClassRecord +import qualified Class +import qualified Time +import qualified SpectralDistribution as SD +import qualified Signal +import qualified Rate +import Measurement + (SpectralParameters(SpectralParameters, spectralFlatness), + ClassFeatures, ) + +import qualified Spreadsheet.Formula as CalcForm +import qualified Spreadsheet.Palisade as Palisade +import qualified Spreadsheet.Row as CalcRow +import qualified Text.CSV.Lazy.String as CSV +import Spreadsheet.Row (FieldTracked, Precision(Prec0, Prec3, Prec6)) + +import qualified Data.Text as Text +import Data.Text (Text, ) + +import qualified Control.Monad.Trans.Writer as MW +import Control.DeepSeq (NFData, rnf, force, ) +import Control.Monad (void, liftM2, liftM3, when, ) +import Control.Applicative (Applicative, liftA2, liftA3, pure, (<*>), ) +import Data.Biapplicative (bipure, (<<*>>), ) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Monoid.HT as Mn +import qualified Data.Semigroup as Sg +import qualified Data.Char as Char +import Data.IORef (IORef, newIORef, readIORef, modifyIORef, ) +import Data.Foldable (foldMap, fold, ) +import Data.Monoid (Monoid, mempty, mappend, (<>), ) +import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (mapMaybe, ) +import Data.Map (Map, ) + +import qualified System.FilePath.Find as Find +import qualified System.Path.PartClass as PathClass +import qualified System.Path.Directory as Dir +import qualified System.Path.IO as PathIO +import qualified System.Path as Path +import System.FilePath.Find ((~~?), (==?), (&&?), (||?), ) +import System.Path ((), (<.>), ) +import Text.Printf (printf, ) + +import qualified Algebra.RealRing as Real +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import Algebra.ToRational (realToField) +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude (Num) + + +spectralParametersReal :: + (Trans.C a) => + Formula a -> SpectralParameters Float -> + SpectralParameters (Formula a) +spectralParametersReal + rate (SpectralParameters flatness maxFreq (centroid,deviation) distr) = + SpectralParameters + (realToField flatness) (rate * realToField maxFreq) + (realToField centroid, realToField deviation) + (spectralDistributionReal rate distr) + +spectralDistributionReal :: + (Trans.C a) => + Formula a -> SD.T Float -> SD.T (Formula a) +spectralDistributionReal rate (SD.Cons centroid spread) = + let angularRate = rate / (Ring.fromInteger 2 * CalcForm.pi) + in SD.Cons + (realToField centroid * angularRate) + (realToField (SD.signedSqrt spread) * angularRate) + + +type Cell = CalcForm.CellTracked +type Formula = CalcForm.FormulaTracked + + +palBounds :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (Cell a) a +palBounds = + Palisade.colNoSum "Start/s" + `Palisade.right` + Palisade.colNoSum "Stop/s" + `Palisade.right` + Palisade.colSum Prec6 "Duration/s" + +rowBounds :: + (CalcRow.Fraction a) => + Formula a -> (Int,Int) -> CalcRow.M (Cell a) +rowBounds rate bounds = do + start <- CalcRow.putFractionFormula Prec6 $ fromIntegral (fst bounds) / rate + stop <- CalcRow.putFractionFormula Prec6 $ fromIntegral (snd bounds) / rate + CalcRow.putFraction Prec6 $ stop - start + + +precSpectral :: SpectralParameters Precision +precSpectral = (pure Prec0) {spectralFlatness = Prec3} + +palSpectral :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (SpectralParameters (Cell a)) (SpectralParameters a) +palSpectral = + Palisade.Cons + (map (flip (,) True) $ Fold.toList $ + SpectralParameters + "WienerEntropy" "MaxFreq/Hz" + ("BandCentroid/Hz", "BandDeviation/Hz") + (SD.Cons "SpecCentroid/Hz" "SpecSpread/Hz")) + (fold . liftA2 Palisade.summarySum5 precSpectral . Trav.sequenceA) + (fmap CalcForm.trackedNumber) + (fold . liftA2 Palisade.summary5String precSpectral . Trav.sequenceA) + +rowSpectral :: + (CalcRow.Fraction a) => + SpectralParameters (Formula a) -> + CalcRow.M (SpectralParameters (Cell a)) +rowSpectral = + Trav.sequence . liftA2 CalcRow.putFraction precSpectral + + +_palClickDur :: (CalcRow.Fraction a, Real.C a) => Palisade.T (Cell a) a +_palClickDur = Palisade.colSum5 Prec6 "ClickDur/s" + +_rowClickDur :: + (CalcRow.Fraction a) => + Formula a -> [LabelChain.ClickAbs Int] -> CalcRow.M (Cell a) +_rowClickDur rate clicks = + CalcRow.putFraction Prec6 $ + fromIntegral (sum (map (\(LabelChain.ClickAbs t0 t1 _) -> t1-t0) clicks)) + / + (rate * fromIntegral (length clicks)) + + +type Advertisement a = (BoundRasping a, Maybe (BoundChirping a)) + +type BoundAdvertisement a = (a, Advertisement a) + +palBoundAdvertisement :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (BoundAdvertisement (Cell a)) (BoundAdvertisement a) +palBoundAdvertisement = + Palisade.pair palBounds $ + Palisade.pair + (Palisade.mapHeaders ("Slow " ++) $ + Palisade.pair (Palisade.colSum5 Prec6 "Dur/s") palRasping) + (Palisade.maybe $ + Palisade.mapHeaders ("Fast " ++) $ + Palisade.pair (Palisade.colSum5 Prec6 "Dur/s") palChirping) + +type Rasping a = ((a, a), (a, a, a), SpectralParameters a) + +palRasping :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (Rasping (Cell a)) (Rasping a) +palRasping = + Palisade.triple + (Palisade.pair + (Palisade.colSum Prec3 "NumClicks") + (Palisade.colSum Prec3 "NumEmphasized")) + (Palisade.triple + (Palisade.colSum5 Prec3 "ClickRate/Hz") + (Palisade.colSum5 Prec6 "ClickHalfLife/s") + (Palisade.colSum5 Prec6 "ClickPause/s")) + palSpectral + +rowRasping :: + (CalcRow.Fraction a) => + Formula a -> Formula a -> + ((Int, Int, Int), SpectralParameters (Formula a)) -> + CalcRow.M (Rasping (Cell a)) +rowRasping rate dur + ((numClicksInt, sumHalfLifes, numEmphasizedInt), spectralDistr) = do + numClicksCell <- CalcRow.putInt numClicksInt + let numClicks = CalcForm.trackedVar numClicksCell + numEmphasized <- CalcRow.putInt numEmphasizedInt + clickRate <- CalcRow.putFraction Prec3 $ numClicks / dur + hlife <- + CalcRow.putFraction Prec6 $ + fromIntegral sumHalfLifes / (numClicks * rate) + clickPause <- + CalcRow.putFraction Prec6 $ dur / numClicks - CalcForm.trackedVar hlife + spectral <- rowSpectral spectralDistr + return + ((numClicksCell, numEmphasized), + (clickRate, hlife, clickPause), + spectral) + +type BoundRasping a = (a, Rasping a) + +palBoundRasping :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (BoundRasping (Cell a)) (BoundRasping a) +palBoundRasping = Palisade.pair palBounds palRasping + + +type Chirping a = (a, SpectralParameters a) + +palChirping :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (Chirping (Cell a)) (Chirping a) +palChirping = + Palisade.pair (Palisade.colSum5 Prec6 "MainDur/s") palSpectral + +rowChirping :: + (CalcRow.Fraction a) => + Formula a -> + (Int, SpectralParameters (Formula a)) -> + CalcRow.M (Chirping (Cell a)) +rowChirping rate (brk, spectralDistr) = do + mainDur <- CalcRow.putFraction Prec6 $ fromIntegral brk / rate + spectral <- rowSpectral spectralDistr + return (mainDur, spectral) + +rowNoChirping :: CalcRow.M () +rowNoChirping = + case palChirping :: + Palisade.T (Chirping (Cell Double)) (Chirping Double) of + Palisade.Cons tabHeadChirping _ _ _ -> + sequence_ $ Match.replicate tabHeadChirping CalcRow.putEmpty + +type BoundChirping a = (a, Chirping a) + +palBoundChirping :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (BoundChirping (Cell a)) (BoundChirping a) +palBoundChirping = Palisade.pair palBounds palChirping + + +type Ticking a = (a, a, SpectralParameters a) + +palTicking :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (Ticking (Cell a)) (Ticking a) +palTicking = + Palisade.triple + (Palisade.colSum5 Prec3 "NumClicks") + (Palisade.colSum Prec3 "ClickRate/Hz") + palSpectral + +rowTicking :: + (CalcRow.Fraction a) => + Formula a -> + (Int, SpectralParameters (Formula a)) -> + CalcRow.M (Ticking (Cell a)) +rowTicking dur (numClicksInt, spectralDistr) = do + numClicks <- CalcRow.putInt numClicksInt + clickRate <- CalcRow.putFraction Prec3 $ CalcForm.trackedVar numClicks / dur + spectral <- rowSpectral spectralDistr + return (numClicks, clickRate, spectral) + +type BoundTicking a = (a, Ticking a) + +palBoundTicking :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (BoundTicking (Cell a)) (BoundTicking a) +palBoundTicking = Palisade.pair palBounds palTicking + + +type Growling a = Rasping a + +palGrowling :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (Growling (Cell a)) (Growling a) +palGrowling = palRasping + +rowGrowling :: + (CalcRow.Fraction a) => + Formula a -> Formula a -> + ((Int, Int, Int), SpectralParameters (Formula a)) -> + CalcRow.M (Growling (Cell a)) +rowGrowling = rowRasping + +type BoundGrowling a = (a, Growling a) + +palBoundGrowling :: + (CalcRow.Fraction a, Real.C a) => + Palisade.T (BoundGrowling (Cell a)) (BoundGrowling a) +palBoundGrowling = Palisade.pair palBounds palGrowling + + +data EvalType = Number | Formula + deriving (Eq, Ord, Show, Enum) + +typeName :: EvalType -> String +typeName typ = + case typ of + Formula -> "formula" + Number -> "number" + +typeSelect :: EvalType -> CalcForm.Tracked a a -> a +typeSelect typ = + case typ of + Formula -> CalcForm.trackedFormula + Number -> CalcForm.trackedNumber + + +infixl 7 <-> + +(<->) :: Path.File ar -> String -> Path.File ar +path <-> var = Path.mapFileName (++ "-" ++ var) path + +formatTable :: + (PathClass.AbsRel ar) => + Path.File ar -> EvalType -> String -> [[FieldTracked]] -> + TableFormats (Path.File ar, Text) +formatTable outputStem typ cls content = + liftA2 (,) + (fmap + (\ext -> outputStem <-> map Char.toLower cls <-> typeName typ <.> ext) + formatExtensions) + (fmap + (\fmt -> + Text.pack $ + formatOpen fmt cls ++ formatRows fmt typ content ++ formatClose fmt) $ + formats) + + +formatMultiTable :: + (PathClass.AbsRel ar) => + Path.File ar -> EvalType -> + ClassRecord.T (String, [[FieldTracked]]) -> + TableFormats (Path.File ar, Text) +formatMultiTable outputStem typ tables = + liftA2 (,) + (fmap (\ext -> outputStem <-> typeName typ <.> ext) formatExtensions) + (fmap + (\fmt -> + Text.pack $ + formatFileOpen fmt ++ + foldMap (uncurry (formatSheet fmt typ)) tables ++ + formatFileClose fmt) + formats) + +renderTable2 :: + Palisade.T a b -> [CalcRow.M a] -> ([[FieldTracked]], [b]) +renderTable2 (Palisade.Cons tabHead aggregate select _) table = + let (meass, content) = unzip $ zipWith CalcRow.run [1..] table + in ((map tableHead $ "Source" : map fst tabHead) : + content ++ + [] : + List.transpose + (map tableHead (Fold.toList Palisade.summary5Names ++ ["Sum"]) : + flip map (aggregate meass) + (\(sum5, sumRes) -> Fold.toList sum5 ++ [sumRes])) + , + map select meass) + + +data TableFormats a = TableFormats {tableCSV, tableHTML, tableXML2003 :: a} +type TablePaths ar = TableFormats (Maybe (Path.File ar)) +data Resolutions a = Resolutions {resTreatment, resAnimal, resRecording :: a} +type ResPaths ar = Resolutions (TablePaths ar) +type ClassPaths ar = ClassRecord.T (ResPaths ar) +type DurPaths ar = ((TablePaths ar, TablePaths ar), IORef Int) +type AllPaths ar = (DurPaths ar, ClassPaths ar, (Path.Dir ar, String, String)) + + +instance Functor TableFormats where + fmap = Trav.fmapDefault + +instance Fold.Foldable TableFormats where + foldMap = Trav.foldMapDefault + +instance Trav.Traversable TableFormats where + traverse f (TableFormats csv html xml2003) = + liftA3 TableFormats (f csv) (f html) (f xml2003) + +instance Applicative TableFormats where + pure a = TableFormats a a a + TableFormats fCSV fHTML fXML2003 <*> TableFormats xCSV xHTML xXML2003 = + TableFormats (fCSV xCSV) (fHTML xHTML) (fXML2003 xXML2003) + +formatExtensions :: TableFormats String +formatExtensions = TableFormats "csv" "html" "xml" + + +instance Fold.Foldable Resolutions where + foldMap f (Resolutions treatment animal recording) = + f treatment <> f animal <> f recording + + +tableHead :: String -> FieldTracked +tableHead content = + (tableField content) { + CalcRow.fieldHead = True + } + +tableSpanHead :: Int -> String -> FieldTracked +tableSpanHead colSpan content = + (tableHead content) { + CalcRow.fieldSpan = colSpan + } + +tableField :: String -> FieldTracked +tableField content = + CalcRow.TableField { + CalcRow.fieldType = CalcRow.TypeString, + CalcRow.fieldQuoted = False, + CalcRow.fieldAnchor = "", + CalcRow.fieldHead = False, + CalcRow.fieldSpan = 1, + CalcRow.fieldPrecision = Nothing, + CalcRow.fieldContent = CalcForm.untracked content + } + +tableFieldInt :: Int -> FieldTracked +tableFieldInt number = + (tableField $ show number) { + CalcRow.fieldType = CalcRow.TypeNumber + } + +tableFieldAnchor :: + (PathClass.FileDir fd) => + Path.AbsDir -> Path.Rel fd -> FieldTracked +tableFieldAnchor path file = + (tableField $ Path.toString file) { + CalcRow.fieldAnchor = Path.toString $ path file + } + + +initFile :: + (PathClass.AbsRel ar) => + Path.File ar -> String -> IO (Path.File ar) +initFile path str = do + PathIO.writeFile path str + return path + + + +data + Format = + Format { + formatOpen :: String -> String, + formatClose :: String, + formatRows :: EvalType -> [[FieldTracked]] -> String, + formatFileOpen :: String, + formatFileClose :: String, + formatSheet :: EvalType -> String -> [[FieldTracked]] -> String + } + +formats :: TableFormats Format +formats = + TableFormats { + tableCSV = formatCSV, + tableHTML = formatHTML, + tableXML2003 = formatXML2003 + } + +formatCSV, formatHTML, formatXML2003 :: Format +formatCSV = + Format { + formatOpen = const "", + formatClose = "", + formatRows = formatCSVRows, + formatFileOpen = "", + formatFileClose = "", + formatSheet = \typ name content -> + (prettyCSVTable [[name]]) + ++ + formatCSVRows typ content + ++ + (prettyCSVTable [[]]) + } + +formatHTML = + let fileOpenNamed name = + "" : + printf "%s" name : + "" : + [] + + fileOpen = + "" : + "" : + [] + + tableOpen = + "" : + [] + + tableClose = + "
" : + [] + + fileClose = + "" : + "" : + [] + + in Format { + formatOpen = \name -> unlines $ fileOpenNamed name ++ tableOpen, + formatClose = unlines $ tableClose ++ fileClose, + formatRows = (unlines .) . formatHTMLRows, + formatFileOpen = unlines fileOpen, + formatFileClose = unlines fileClose, + formatSheet = \typ name content -> unlines $ + printf "

%s

" name + : + tableOpen + ++ + formatHTMLRows typ content + ++ + tableClose + } + +formatXML2003 = + let fileOpen = + "" : + "" : + "" : + "" : + "" : + "" : + "" : + "" : + "" : + [] + + tableOpen name = + printf "" name : + "" : + [] + + tableClose = + "
" : + "" : + [] + + fileClose = + "" : + [] + + in Format { + formatOpen = \name -> unlines $ fileOpen ++ tableOpen name, + formatClose = unlines $ tableClose ++ fileClose, + formatRows = (unlines .) . formatXML2003Rows, + formatFileOpen = unlines fileOpen, + formatFileClose = unlines fileClose, + formatSheet = \typ name content -> unlines $ + tableOpen name + ++ + formatXML2003Rows typ content + ++ + tableClose + } + + + +writeTableInit :: + (PathClass.AbsRel ar) => + TableFormats Bool -> Path.File ar -> + [[FieldTracked]] -> IO (TablePaths ar) +writeTableInit mask path content = do + let name = Path.toString $ Path.takeFileName path + Trav.sequence $ + liftA3 + (\enable ext fmt -> + Trav.sequence $ toMaybe enable $ + initFile (path <.> ext) + (formatOpen fmt name ++ formatRows fmt Number content)) + mask formatExtensions formats + + +expandTableHead1 :: [(String, [String])] -> [[FieldTracked]] +expandTableHead1 = + (:[]) . + concatMap (\(top,below) -> map (tableHead . ((top++"\n") ++)) below) + +expandTableHead2 :: [(String, [String])] -> [[FieldTracked]] +expandTableHead2 = + (\(top,below) -> [top, concat below]) . unzip . + map (\(top,below) -> (tableSpanHead (length below) top, map tableHead below)) + +{- +ToDo: +We could try to write the median for every recording +immediately after the processing of the recording is finished. +However this would require more effort to bring the rows in order, +since the recordings are processed in parallel. +-} +writeMedianHead :: + (PathClass.AbsRel ar) => + TableFormats Bool -> Bool -> Path.Dir ar -> + Palisade.T (Cell Double, a) (Double, b) -> + String -> IO (ResPaths ar) +writeMedianHead mask divTH output pal cls = do + let headers = map fst $ filter snd $ Palisade.header pal + let summ5Names = Fold.toList Palisade.summary5Names + let writeHead resolution leading = do + writeTableInit mask + (output Path.path (map Char.toLower cls) <-> resolution) $ + (if divTH then expandTableHead2 else expandTableHead1) $ + map (flip (,) [""]) leading ++ map (flip (,) summ5Names) headers + liftM3 Resolutions + (writeHead "treatment" $ "Night" : "Treatment" : "Number" : []) + (writeHead "animal" $ "Night" : "Animal" : "Trial" : "Number" : []) + (writeHead "recording" $ + "Night" : "Animal" : "Trial" : "Recording" : "Number" : []) + +findAdvertisementData :: + (PathClass.AbsRel ar) => String -> Path.Dir ar -> IO [Path.File ar] +findAdvertisementData fmt = + let isAdv = + Find.fileName ~~? printf fmt "*" &&? + (Find.fileType ==? Find.RegularFile ||? + Find.fileType ==? Find.SymbolicLink) + in fmap (map Path.path) . Find.find (Find.depth ==? 0) isAdv . Path.toString + +writeOverviewHead :: + (PathClass.AbsRel ar) => Flags -> Path.Dir ar -> IO (AllPaths ar) +writeOverviewHead flags output = do + let backup pathFmt = + findAdvertisementData pathFmt output >>= + mapM_ (\path -> Dir.renameFile path (path <.> "bak")) + let advertisementHourlyFmt = "advertisement-hourly-%s.ssv" + let advertisementFmt = "advertisement-%s.ssv" + backup advertisementHourlyFmt + backup advertisementFmt + let durHead = + map tableHead $ + ["Night", "Animal", "Trial"] ++ + Fold.toList (fmap (++"/s") Durs.names) ++ + "Sum/s" : Fold.toList (fmap (++" rel") ClassRecord.names) + let (CalcForm.Tracked emitForm emitNumber) = emitFormula flags + let writeDurationHead enable typ = + writeTableInit (fmap (enable&&) $ emitFormats flags) + (output Path.path "duration" <-> typeName typ) [durHead] + durationTable <- + liftM2 (,) + (writeDurationHead emitForm Formula) + (writeDurationHead emitNumber Number) + rowRef <- newIORef 0 + let writeMedHead = + writeMedianHead (emitFormats flags) (dividedTableHead flags) output + medianTables <- + Trav.sequence $ + ClassRecord.Cons + (writeMedHead palBoundAdvertisement) + (writeMedHead palBoundRasping) + (writeMedHead palBoundChirping) + (writeMedHead palBoundTicking) + (writeMedHead palBoundGrowling) + <*> + ClassRecord.names + return ((durationTable, rowRef), medianTables, + (output, advertisementFmt, advertisementHourlyFmt)) + +for2_ :: + (Applicative t, Applicative f, Fold.Foldable t) => + t a -> t b -> (a -> b -> f ()) -> f () +for2_ xs ys act = + Fold.sequenceA_ $ liftA2 act xs ys + +writeOverviewFoot :: + (PathClass.AbsRel ar) => AllPaths ar -> IO () +writeOverviewFoot + (((durationFormulaTable, durationNumberTable), _rowRef), + classTables, _advertisementPath) = do + let closeTable paths = + for2_ paths formats $ \mpath format -> + Fold.for_ mpath $ \path -> + PathIO.appendFile path $ formatClose format + closeTable durationFormulaTable + closeTable durationNumberTable + Fold.mapM_ (Fold.mapM_ closeTable) classTables + + +formatField :: EvalType -> FieldTracked -> String +formatField typ x = + case CalcRow.fieldContent x of + CalcForm.Tracked formula str -> + case typ of + Number -> str + Formula -> maybe str (('=':) . CalcForm.formatCSV) formula + +prettyCSVTable :: [[String]] -> String +prettyCSVTable = CSV.ppCSVTable . snd . CSV.toCSVTable + +formatCSVRows :: EvalType -> [[FieldTracked]] -> String +formatCSVRows typ = + prettyCSVTable . + map + (concatMap + (\x -> take (CalcRow.fieldSpan x) $ formatField typ x : repeat "")) + +formatHTMLRows :: EvalType -> [[FieldTracked]] -> [String] +formatHTMLRows typ = + map (\row -> ""++row++"") . + map (concatMap + (\x -> + let tag = if CalcRow.fieldHead x then "th" else "td" + colSpan, anchorOpen, anchorClose :: String + colSpan = + Mn.when (CalcRow.fieldSpan x > 1) $ + printf " colspan=%d" (CalcRow.fieldSpan x) + (anchorOpen, anchorClose) = + Mn.when (not $ null $ CalcRow.fieldAnchor x) + (printf "" $ CalcRow.fieldAnchor x, "") + escape = concatMap (\c -> if c=='\n' then "
" else [c]) + in printf "<%s%s>%s%s%s" + tag colSpan anchorOpen + (escape $ formatField typ x) anchorClose tag)) + +formatXML2003Rows :: EvalType -> [[FieldTracked]] -> [String] +formatXML2003Rows ftyp = + concatMap (\row -> "" : row ++ "" : []) . + map (map + (\x -> + let style, colSpan, anchor :: String + style = + if CalcRow.fieldHead x + then " ss:StyleID='head'" + else foldMap + (printf " ss:StyleID='%s'" . precision) + (CalcRow.fieldPrecision x) + precision prec = + case prec of + Prec0 -> "frac0" + Prec3 -> "frac3" + Prec6 -> "frac6" + colSpan = + Mn.when (CalcRow.fieldSpan x > 1) $ + printf " ss:MergeAcross='%d'" $ CalcRow.fieldSpan x - 1 + anchor = + Mn.when (not $ null $ CalcRow.fieldAnchor x) $ + printf " ss:HRef='%s'" $ CalcRow.fieldAnchor x + CalcForm.Tracked mformula display = CalcRow.fieldContent x + escape = concatMap (\c -> if c=='\n' then " " else [c]) + formula = + case ftyp of + Number -> "" + Formula -> + foldMap + (printf " ss:Formula='=%s'" . CalcForm.formatXML2003) + mformula + typ = + case CalcRow.fieldType x of + CalcRow.TypeString -> "String" + CalcRow.TypeNumber -> "Number" + in printf "%s" + style colSpan anchor formula typ (escape display))) + +appendTable :: + (PathClass.AbsRel ar) => + EvalType -> TablePaths ar -> [[FieldTracked]] -> IO () +appendTable typ paths content = + for2_ paths formats $ \mpath format -> + Fold.for_ mpath $ \path -> + PathIO.appendFile path $ formatRows format typ content + +appendMedian :: + (PathClass.AbsRel ar) => + [FieldTracked] -> [meas] -> + Palisade.T a b -> (meas -> [b]) -> TablePaths ar -> + IO () +appendMedian source totalDursMeass pal selectMeas tablePath = + appendTable Number tablePath $ + let meass = concatMap selectMeas totalDursMeass + in [source ++ + tableFieldInt (length meass) : + concatMap Fold.toList (Palisade.selectedSummary5 pal meass)] + +appendMedian2 :: + (PathClass.AbsRel ar) => + [FieldTracked] -> Path.AbsDir -> [(Path.RelFile, meas)] -> + Palisade.T a b -> (meas -> [b]) -> ResPaths ar -> + IO () +appendMedian2 source fullDir1 totalDursMeass pal selectMeas + (Resolutions {resAnimal = animalPath, resRecording = recordingPath}) = do + appendMedian source (map snd totalDursMeass) pal selectMeas animalPath + appendTable Number recordingPath $ + flip map (map (mapSnd selectMeas) totalDursMeass) $ + \(name,meass) -> + source ++ tableFieldAnchor fullDir1 name : + tableFieldInt (length meass) : + concatMap Fold.toList (Palisade.selectedSummary5 pal meass) + + +calcFormPutAnchor :: + (PathClass.FileDir fd, PathClass.AbsRel ar) => + Path.Path ar fd -> Path.Rel fd -> CalcRow.M () +calcFormPutAnchor url disp = + CalcRow.putAnchor (Path.toString url) (Path.toString disp) + + +type + Results = + (Durs.T Double, Map Time.Hour (Durs.T Double), Measurements Double) + +appendOverview :: + (PathClass.AbsRel ar) => + AllPaths ar -> + Path.AbsDir -> Path.RelDir -> Path.RelDir -> Int -> + [(Path.RelFile, Results)] -> IO () +appendOverview + (((durationFormulaTable, durationNumberTable), rowRef), + classTables, _advertisementPath) + input dir0 dir1 animal totalDursMeass = do + + modifyIORef rowRef succ + rowPos <- readIORef rowRef + let fullDir0 = input dir0 + let fullDir1 = fullDir0 dir1 + let row = + CalcRow.exec rowPos $ do + calcFormPutAnchor fullDir0 dir0 + void $ CalcRow.putNumber animal + calcFormPutAnchor fullDir1 dir1 + durClasses <- + fmap (fmap CalcForm.trackedVar . Durs.classes) $ + Trav.traverse (CalcRow.putPlainFraction Prec3) $ + List.foldl' (\x y -> force $ liftA2 (+) x y) (pure 0) $ + map (fst3 . snd) totalDursMeass + durSum <- + CalcRow.putFractionFormula Prec3 $ Fold.foldl1 (+) durClasses + Fold.mapM_ (CalcRow.putFraction Prec3 . (/durSum)) durClasses + appendTable Formula durationFormulaTable [row] + appendTable Number durationNumberTable [row] + + let source = + tableFieldAnchor input dir0 : + tableFieldInt animal : + tableFieldAnchor fullDir0 dir1 : + [] + let appendMed = + appendMedian2 source fullDir1 $ map (mapSnd thd3) totalDursMeass + + Fold.sequence_ $ + ClassRecord.Cons + (appendMed palBoundAdvertisement measAdvertisement) + (appendMed palBoundRasping measRasping) + (appendMed palBoundChirping measChirping) + (appendMed palBoundTicking measTicking) + (appendMed palBoundGrowling measGrowling) + <*> + classTables + + +summary5 :: + (Field.C a, Real.C a, Num a) => + [[ClassRecord.T a]] -> Maybe (Palisade.FiveNumberSummary a) +summary5 = + fmap Palisade.summary5Number . + NonEmpty.fetch . map (uncurry (/)) . filter ((/=0) . snd) . + map + (\durs -> + (sum (map ClassRecord.advertisement durs), + sum (map Fold.sum durs))) + +transposeMapList :: (Ord k) => [Map k a] -> Map k [a] +transposeMapList = Map.unionsWith (++) . map (fmap (:[])) + +appendTreatmentOverview :: + (PathClass.AbsRel ar) => + AllPaths ar -> Path.AbsDir -> Path.RelDir -> String -> + [[(Path.RelFile, Results)]] -> IO () +appendTreatmentOverview + (_durationTable, classTables, + (output, advertisementFmt, advertisementHourlyFmt)) + input dir0 treatment fileTotalDursMeass = do + + let totalDursMeass = map (map snd) fileTotalDursMeass + let appendMed = + appendMedian + [tableFieldAnchor input dir0, tableField treatment] + (map thd3 $ concat totalDursMeass) + + Fold.sequence_ $ + ClassRecord.Cons + (appendMed palBoundAdvertisement measAdvertisement) + (appendMed palBoundRasping measRasping) + (appendMed palBoundChirping measChirping) + (appendMed palBoundTicking measTicking) + (appendMed palBoundGrowling measGrowling) + <*> + fmap resTreatment classTables + + let hourSumms = + map (mapPair + (Time.formatHour "%Y-%m-%d %H", + Fold.toList . fmap (printf "%.3f"))) $ + Map.toAscList $ + Map.mapMaybe summary5 $ + transposeMapList $ + map + (transposeMapList . map (fmap Durs.classes . snd3)) + totalDursMeass + + PathIO.writeFile + (output dir0 + Path.relFile (printf advertisementHourlyFmt treatment)) $ + unlines $ + map (\(hour,summ) -> unwords $ hour : summ) $ + hourSumms + + PathIO.appendFile + (output + Path.relFile (printf advertisementHourlyFmt treatment)) $ + unlines $ + map (\(hour,summ) -> unwords $ hour : summ) $ + ListHT.switchR [] + (\_xs (hour,summ) -> + hourSumms ++ [(hour, Match.replicate summ "NaN")]) $ + hourSumms + + PathIO.appendFile + (output Path.path (printf advertisementFmt treatment)) $ + printf "\"%s\" %s\n" (Path.toString dir0) $ + List.intercalate " " $ Fold.toList $ + maybe (pure "NaN") (fmap (printf "%.3f")) $ summary5 $ + map (map (Durs.classes . fst3)) + totalDursMeass + + +data + Measurements a = + Measurements { + measAdvertisement :: [BoundAdvertisement a], + measRasping :: [BoundRasping a], + measChirping :: [BoundChirping a], + measTicking :: [BoundTicking a], + measGrowling :: [BoundGrowling a] + } + +instance Sg.Semigroup (Measurements a) where + Measurements a0 r0 c0 t0 g0 <> Measurements a1 r1 c1 t1 g1 = + Measurements (a0++a1) (r0++r1) (c0++c1) (t0++t1) (g0++g1) + +instance Monoid (Measurements a) where + mempty = Measurements [] [] [] [] [] + mappend = (<>) + +instance (NFData a) => NFData (Measurements a) where + rnf (Measurements a r c t g) = rnf (a,r,c,t,g) + + +data + Flags = + Flags { + emitFormula :: CalcForm.Tracked Bool Bool, + emitFormats :: TableFormats Bool, + emitRecording :: RecordingFlags Bool, + dividedTableHead :: Bool + } + +data RecordingFlags a = RecordingFlags {emitSingle, emitMulti :: a} + +instance Functor RecordingFlags where + fmap = Trav.fmapDefault + +instance Fold.Foldable RecordingFlags where + foldMap = Trav.foldMapDefault + +instance Trav.Traversable RecordingFlags where + traverse f (RecordingFlags single multi) = + liftA2 RecordingFlags (f single) (f multi) + +instance Applicative RecordingFlags where + pure a = RecordingFlags a a + RecordingFlags fSingle fMulti <*> RecordingFlags single multi = + RecordingFlags (fSingle single) (fMulti multi) + +defaultFlags :: Flags +defaultFlags = + Flags { + emitFormula = CalcForm.Tracked True True, + emitFormats = + TableFormats {tableCSV = False, tableHTML = True, tableXML2003 = True}, + emitRecording = RecordingFlags {emitSingle = False, emitMulti = True}, + dividedTableHead = False + } + + +formatTables :: + (PathClass.AbsRel ar0, PathClass.AbsRel ar1) => + Flags -> + Rate.Sample -> Path.File ar0 -> Path.File ar1 -> + Signal.LabelChain Rate.Measure (SpectralParameters Float, ClassFeatures) -> + MW.Writer [(Path.File ar1, Text)] (Measurements Double) +formatTables + (Flags formFlags fmtFlags recFlags _divTH) + highRateReal input outputStem + (Signal.Cons lowRateReal measures) = do + let putInput = calcFormPutAnchor input $ Path.takeBaseName input + lowRate = CalcForm.trackFraction $ Rate.unpack lowRateReal + highRate = CalcForm.trackFraction $ Rate.unpack highRateReal + classMeasures = + LabelTrack.decons $ LabelTrack.fromLabelChain $ + LabelChain.abstractFromSoundClassIntervals $ + fmap + (\(spec, cls) -> + let spectralDistr = spectralParametersReal highRate spec + in case cls of + Class.Rasping clickMeasure -> + Class.Rasping (clickMeasure, spectralDistr) + Class.Chirping chirpMain -> + Class.Chirping (chirpMain, spectralDistr) + Class.Ticking numClicks -> + Class.Ticking (numClicks, spectralDistr) + Class.Growling clickMeasure -> + Class.Growling (clickMeasure, spectralDistr) + Class.Other str -> Class.Other str) $ + measures + + renderTable pal renderRow = + renderTable2 pal $ mapMaybe renderRow classMeasures + + (tables, meass) = + bipure ClassRecord.Cons Measurements + <<*>> + (renderTable palBoundAdvertisement $ \(bnd,cls) -> + case cls of + Class.Advertisement brk raspingMeas mchirpingMeas -> + Just $ do + putInput + durCell <- rowBounds lowRate bnd + durRaspingCell <- + CalcRow.putFraction Prec6 $ + (fromIntegral brk - fromIntegral (fst bnd)) / lowRate + let dur = CalcForm.trackedVar durCell + let durRasping = CalcForm.trackedVar durRaspingCell + rasping <- rowRasping lowRate durRasping raspingMeas + chirping <- + case mchirpingMeas of + Nothing -> do + CalcRow.putEmpty + rowNoChirping + return Nothing + Just chirping -> + fmap Just $ + liftM2 (,) + (CalcRow.putFraction Prec6 $ dur - durRasping) + (rowChirping lowRate chirping) + return (durCell, ((durRaspingCell, rasping), chirping)) + _ -> Nothing) + <<*>> + (renderTable palBoundRasping $ \(bnd,cls) -> + case cls of + Class.NoAdvertisement (Class.Rasping measured) -> + Just $ do + putInput + dur <- rowBounds lowRate bnd + rasping <- + rowRasping lowRate (CalcForm.trackedVar dur) measured + return (dur, rasping) + _ -> Nothing) + <<*>> + (renderTable palBoundChirping $ \(bnd,cls) -> + case cls of + Class.NoAdvertisement (Class.Chirping measured) -> + Just $ do + putInput + dur <- rowBounds lowRate bnd + chirping <- rowChirping lowRate measured + return (dur, chirping) + _ -> Nothing) + <<*>> + (renderTable palBoundTicking $ \(bnd,cls) -> + case cls of + Class.NoAdvertisement (Class.Ticking measured) -> + Just $ do + putInput + dur <- rowBounds lowRate bnd + ticking <- rowTicking (CalcForm.trackedVar dur) measured + return (dur, ticking) + _ -> Nothing) + <<*>> + (renderTable palBoundGrowling $ \(bnd,cls) -> + case cls of + Class.NoAdvertisement (Class.Growling measured) -> + Just $ do + putInput + dur <- rowBounds lowRate bnd + rasping <- + rowGrowling lowRate (CalcForm.trackedVar dur) measured + return (dur, rasping) + _ -> Nothing) + + let tellSelected mask tbls = + for2_ mask tbls $ \enable table -> when enable $ MW.tell [table] + let formatSelected typ mask makeTables = + when (typeSelect typ formFlags) $ + tellSelected mask $ makeTables typ + let whenFormula formulaFormats numberFormats makeTables = do + formatSelected Formula formulaFormats makeTables + formatSelected Number numberFormats makeTables + + when (emitSingle recFlags) $ + for2_ ClassRecord.names tables $ \cls table -> + whenFormula fmtFlags fmtFlags $ \typ -> + formatTable outputStem typ cls table + + {- + In CSV and HTML files the cell references in formulas + become invalid by concatenating tables. + Thus we allow to skip CSV and HTML creation for formula tables. + -} + let fmtFormFlags = fmtFlags {tableCSV = False, tableHTML = False} + when (emitMulti recFlags) $ + whenFormula fmtFormFlags fmtFlags $ \typ -> + formatMultiTable outputStem typ $ + liftA2 (,) ClassRecord.names tables + + return meass diff --git a/src/Spreadsheet/Formula.hs b/src/Spreadsheet/Formula.hs new file mode 100644 --- /dev/null +++ b/src/Spreadsheet/Formula.hs @@ -0,0 +1,240 @@ +module Spreadsheet.Formula ( + Formula, + CellId(CellId), + Agg(..), + constant, + pi, + fromInt, + formatCSV, + formatXML2003, + aggregate, + sum, + + Tracked(..), + untracked, + CellTracked, + FormulaTracked, + trackFraction, + trackedVar, + ) where + +import qualified Data.Bifunctor as Bifunc +import Control.Applicative (liftA2) +import Data.Bitraversable (Bitraversable, bitraverse, bifoldMapDefault, ) +import Data.Bifoldable (Bifoldable, bifoldMap, ) +import Data.Biapplicative (Biapplicative, bipure, biliftA2, (<<*>>), ) +import Data.Bifunctor (Bifunctor, bimap, ) + +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List as List +import Data.Tuple.HT (swap) +import Data.Maybe.HT (toMaybe) +import Text.Printf (printf) +import Data.Char (ord, chr) +import Data.Ord.HT (comparing) +import Data.Eq.HT (equating) + +import qualified Algebra.ToRational as ToRational +import qualified Algebra.RealRing as Real +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import Algebra.ToRational (realToField) +import NumericPrelude.Numeric hiding (sum, pi) +import NumericPrelude.Base +import Prelude () + + +data Formula = + Const Integer + | Any String + | Var CellId + | Infix Infix Formula Formula + | Agg Agg [Either Formula (CellId, CellId)] + + +data CellId = CellId Int Int + deriving (Eq, Ord, Show) + +data Infix = Times | Divide | Plus | Minus + deriving (Show) + +data Precedence = PrecSum | PrecProduct | PrecLiteral + deriving (Eq, Ord, Enum) + +data Agg = Sum | Minimum | Maximum | Median | Quartile Int + deriving (Show) + +format :: (CellId -> String) -> Formula -> String +format fmtCellId = + let go paren form = + case form of + Const a -> show a + Any str -> str + Var cell -> fmtCellId cell + Agg agg cells -> + printf (formatAgg agg) $ List.intercalate ";" $ + map (either (go (PrecSum>)) (cellRange fmtCellId)) cells + Infix Times x y -> + parentheses (paren PrecProduct) $ + go (PrecProduct>) x ++ "*" ++ go (PrecProduct>) y + Infix Divide x y -> + parentheses (paren PrecProduct) $ + go (PrecProduct>) x ++ "/" ++ go (PrecProduct>=) y + Infix Plus x y -> + parentheses (paren PrecSum) $ + go (PrecSum>) x ++ "+" ++ go (PrecSum>) y + Infix Minus x y -> + parentheses (paren PrecSum) $ + go (PrecSum>) x ++ "-" ++ go (PrecSum>=) y + in go (const False) + +formatCSV :: Formula -> String +formatCSV = format formatCellId + +formatCellId :: CellId -> String +formatCellId (CellId row column) = formatColumnId column ++ show (row+1) + +formatColumnId :: Int -> String +formatColumnId = + let range = ord 'Z' - ord 'A' + 1 + in map chr . map (ord 'A' +) . reverse . + List.unfoldr (\k -> toMaybe (k>0) $ swap $ divMod (k-1) range) . (1+) + +formatXML2003 :: Formula -> String +formatXML2003 = format formatCellIdXML2003 + +formatCellIdXML2003 :: CellId -> String +formatCellIdXML2003 (CellId row column) = + printf "R%dC%d" (row+1) (column+1) + +formatAgg :: Agg -> String +formatAgg agg = + case agg of + -- ToDo: SUMME in German locale + Sum -> "SUM(%s)" + Minimum -> "MIN(%s)" + Maximum -> "MAX(%s)" + Median -> "MEDIAN(%s)" + Quartile n -> "QUARTILE(%s;" ++ show n ++ ")" + +parentheses :: Bool -> String -> String +parentheses b xs = + if b + then '(' : xs ++ ")" + else xs + + +constant :: Integer -> Formula +constant = Const + + +instance Additive.C Formula where + zero = Const zero + x + y = Infix Plus x y + x - y = Infix Minus x y + +instance Ring.C Formula where + fromInteger = Const . Ring.fromInteger + one = Const one + x * y = Infix Times x y + +instance Field.C Formula where + x / y = Infix Divide x y + + +{- | +This type tracks the operations applied to the @a@-typed value. +Cf. EFA.Equation.Pair +-} +data Tracked formula a = Tracked {trackedFormula :: formula, trackedNumber :: a} + deriving (Show) + +instance Bifunctor Tracked where + bimap f g (Tracked formula number) = Tracked (f formula) (g number) + +instance Biapplicative Tracked where + bipure = Tracked + Tracked ff f <<*>> Tracked fx x = Tracked (ff fx) (f x) + +instance Bifoldable Tracked where + bifoldMap = bifoldMapDefault + +instance Bitraversable Tracked where + bitraverse f g (Tracked formula number) = + liftA2 Tracked (f formula) (g number) + +type FormulaTracked = Tracked Formula +type CellTracked = Tracked CellId + +untracked :: String -> Tracked (Maybe Formula) String +untracked = Tracked Nothing + + +instance (Eq a) => Eq (Tracked formula a) where + (==) = equating trackedNumber + +instance (Ord a) => Ord (Tracked formula a) where + compare = comparing trackedNumber + + +instance + (Additive.C formula, Additive.C a) => + Additive.C (Tracked formula a) where + zero = bipure zero zero + (+) = biliftA2 (+) (+) + (-) = biliftA2 (-) (-) + +instance (Ring.C formula, Ring.C a) => Ring.C (Tracked formula a) where + fromInteger n = bipure (Ring.fromInteger n) (Ring.fromInteger n) + one = bipure one one + (*) = biliftA2 (*) (*) + +instance (Field.C formula, Field.C a) => Field.C (Tracked formula a) where + (/) = biliftA2 (/) (/) + + +trackFraction :: (Real.C a, ToRational.C a) => a -> FormulaTracked a +trackFraction x = + case splitFraction x of + (i, frac) -> + Tracked (if isZero frac then constant i else realToField x) x + +trackedVar :: CellTracked a -> FormulaTracked a +trackedVar = Bifunc.first Var + +fromInt :: (Ring.C a) => Tracked formula Int -> Tracked formula a +fromInt = Bifunc.second fromIntegral + + +pi :: (Trans.C a) => FormulaTracked a +pi = Tracked (Any "PI()") Trans.pi + + + +{- | +Simplified implementation that works only for a rectangle of cells. +-} +cellRange :: (CellId -> String) -> (CellId, CellId) -> String +cellRange fmtCellId (from, to) = + printf "%s:%s" (fmtCellId from) (fmtCellId to) + +{- | +The set of cells must form a rectangle. +It is an unchecked error if that does not apply. +-} +aggregate :: + Agg -> (NonEmpty.T [] a -> a) -> + NonEmpty.T [] (CellTracked a) -> FormulaTracked a +aggregate op agg xs = + Tracked + (Agg op + (let cells = fmap trackedFormula xs + in [Right (NonEmpty.minimum cells, NonEmpty.maximum cells)])) + (agg $ fmap trackedNumber xs) + +sum :: (Additive.C a) => [CellTracked a] -> FormulaTracked a +sum = + maybe zero (aggregate Sum (Additive.sum . NonEmpty.flatten)) . + NonEmpty.fetch diff --git a/src/Spreadsheet/Palisade.hs b/src/Spreadsheet/Palisade.hs new file mode 100644 --- /dev/null +++ b/src/Spreadsheet/Palisade.hs @@ -0,0 +1,217 @@ +module Spreadsheet.Palisade ( + FiveNumberSummary(..), + summary5Names, + summary5Number, + + T(..), + summarySum5, + summary5String, + colNoSum, + colSum5, + colSum, + right, + pair, + triple, + maybe, + mapHeaders, + ) where + +import qualified Spreadsheet.Formula as CalcForm +import Spreadsheet.Formula (CellTracked, trackedNumber) +import Spreadsheet.Row + (Fraction, Precision, FieldTracked, + emptyField, fractionField, fracFieldFromTracked) + +import qualified Quantile + +import Control.Applicative (Applicative, pure, liftA2, (<*>)) + +import qualified Data.Foldable as Fold +import qualified Data.NonEmpty as NonEmpty +import Data.Tuple.HT (mapPair, mapTriple, mapFst) +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) + +import qualified Algebra.RealRing as Real +import qualified Algebra.Field as Field +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (maybe) + +import qualified Prelude as P + + + +data FiveNumberSummary a = + FiveNumberSummary { + summaryMinimum, summaryQuartile1, summaryMedian, + summaryQuartile3, summaryMaximum :: a + } + +percentages :: (Field.C a) => FiveNumberSummary a +percentages = + fmap (\k -> fromInteger k / fromInteger 4) $ + FiveNumberSummary { + summaryMinimum = 0, + summaryQuartile1 = 1, + summaryMedian = 2, + summaryQuartile3 = 3, + summaryMaximum = 4 + } + +quartileAggs :: FiveNumberSummary CalcForm.Agg +quartileAggs = + FiveNumberSummary { + summaryMinimum = CalcForm.Minimum, + summaryQuartile1 = CalcForm.Quartile 1, + summaryMedian = CalcForm.Median, + summaryQuartile3 = CalcForm.Quartile 3, + summaryMaximum = CalcForm.Maximum + } + +summary5 :: + (Field.C a, Real.C a) => + NonEmpty.T [] (CellTracked a) -> + FiveNumberSummary (CalcForm.FormulaTracked a) +summary5 xs = + liftA2 + (\op k -> CalcForm.aggregate op (flip Quantile.discrete k) xs) + quartileAggs percentages + +summary5Number :: + (Field.C a, Real.C a) => NonEmpty.T [] a -> FiveNumberSummary a +summary5Number xs = + fmap (Quantile.discrete xs) percentages + +summary5Names :: FiveNumberSummary String +summary5Names = + FiveNumberSummary { + summaryMinimum = "Minimum", + summaryQuartile1 = "Quartile 1", + summaryMedian = "Median", + summaryQuartile3 = "Quartile 3", + summaryMaximum = "Maximum" + } + + +instance Functor FiveNumberSummary where + fmap f (FiveNumberSummary q0 q1 q2 q3 q4) = + FiveNumberSummary (f q0) (f q1) (f q2) (f q3) (f q4) + +instance Applicative FiveNumberSummary where + pure q = FiveNumberSummary q q q q q + FiveNumberSummary p0 p1 p2 p3 p4 <*> FiveNumberSummary q0 q1 q2 q3 q4 = + FiveNumberSummary (p0 q0) (p1 q1) (p2 q2) (p3 q3) (p4 q4) + +instance Fold.Foldable FiveNumberSummary where + foldMap f (FiveNumberSummary q0 q1 q2 q3 q4) = + f q0 <> f q1 <> f q2 <> f q3 <> f q4 + + + +{- | +The 'T' type ensures that aggregations match the column headers. +Unfortunately, they do not assert that the aggregation values +are positioned below the aggregated data. +So far I have not found a way to achieve that. +It would certainly mean to give up the M monad. + +For more clarity we could replace +the list types by two type constructor variables, +one for vertical and one for horizontal lists. +-} +data T a b = + Cons { + header :: [(String,Bool)], + aggregator :: Aggregator a, + selector :: a -> b, + selectedSummary5 :: [b] -> [FiveNumberSummary FieldTracked] + } + +mapHeaders :: (String -> String) -> T a b -> T a b +mapHeaders f pal = + pal{header = map (mapFst f) $ header pal} + +type Aggregator a = [a] -> [(FiveNumberSummary FieldTracked, FieldTracked)] + +aggSummary5 :: + (Fraction a, Real.C a) => + Precision -> [CellTracked a] -> FiveNumberSummary FieldTracked +aggSummary5 prec = + P.maybe (pure emptyField) (fmap (fracFieldFromTracked prec) . summary5) . + NonEmpty.fetch + +summarySum :: (Fraction a, Real.C a) => Precision -> Aggregator (CellTracked a) +summarySum prec cells = + [(aggSummary5 prec cells, fracFieldFromTracked prec $ CalcForm.sum cells)] + +summarySum5 :: (Fraction a, Real.C a) => Precision -> Aggregator (CellTracked a) +summarySum5 prec cells = [(aggSummary5 prec cells, emptyField)] + + +colNoSum :: String -> T () () +colNoSum name = + Cons [(name,False)] (const [(pure emptyField, emptyField)]) id (const []) + + +summary5String :: + (Fraction a, Real.C a) => + Precision -> [a] -> [FiveNumberSummary FieldTracked] +summary5String prec = + (:[]) . + P.maybe (pure emptyField) (fmap (fractionField prec) . summary5Number) . + NonEmpty.fetch + +{- +The Precision given here should be the same as the one +given to the corresponding Row.putFraction, +but currently we cannot check that statically. +-} +colSum :: (Fraction a, Real.C a) => Precision -> String -> T (CellTracked a) a +colSum prec name = + Cons [(name,True)] (summarySum prec) trackedNumber (summary5String prec) + +colSum5 :: (Fraction a, Real.C a) => Precision -> String -> T (CellTracked a) a +colSum5 prec name = + Cons [(name,True)] (summarySum5 prec) trackedNumber (summary5String prec) + + +summRight :: ([r0] -> [a]) -> ([r1] -> [a]) -> [r1] -> [a] +summRight f0 f1 cells = f0 [] ++ f1 cells + +infixr 5 `right` + +right :: T () () -> T a b -> T a b +right (Cons name0 agg0 _sel0 med0) (Cons name1 agg1 sel1 med1) = + Cons (name0++name1) (summRight agg0 agg1) sel1 (summRight med0 med1) + +summPair :: ([r0] -> [a]) -> ([r1] -> [a]) -> [(r0,r1)] -> [a] +summPair f0 f1 cells = + let (cells0,cells1) = unzip cells + in f0 cells0 ++ f1 cells1 + +pair :: T a0 b0 -> T a1 b1 -> T (a0,a1) (b0,b1) +pair (Cons name0 agg0 sel0 med0) (Cons name1 agg1 sel1 med1) = + Cons (name0++name1) + (summPair agg0 agg1) + (mapPair (sel0, sel1)) + (summPair med0 med1) + +summTriple :: + ([r0] -> [a]) -> ([r1] -> [a]) -> ([r2] -> [a]) -> [(r0,r1,r2)] -> [a] +summTriple f0 f1 f2 cells = + let (cells0,cells1,cells2) = unzip3 cells + in f0 cells0 ++ f1 cells1 ++ f2 cells2 + +triple :: T a0 b0 -> T a1 b1 -> T a2 b2 -> T (a0,a1,a2) (b0,b1,b2) +triple + (Cons name0 agg0 sel0 med0) + (Cons name1 agg1 sel1 med1) + (Cons name2 agg2 sel2 med2) = + Cons (name0++name1++name2) + (summTriple agg0 agg1 agg2) + (mapTriple (sel0, sel1, sel2)) + (summTriple med0 med1 med2) + +maybe :: T a b -> T (Maybe a) (Maybe b) +maybe (Cons name agg sel med) = + Cons name (agg . catMaybes) (fmap sel) (med . catMaybes) diff --git a/src/Spreadsheet/Row.hs b/src/Spreadsheet/Row.hs new file mode 100644 --- /dev/null +++ b/src/Spreadsheet/Row.hs @@ -0,0 +1,203 @@ +module Spreadsheet.Row ( + M, + exec, + run, + + Value, + Fraction, + Precision(..), + + putEmpty, + putValueFormula, + putValue, + putFractionFormula, + putFraction, + putPlainFraction, + putString, + putAnchor, + putInt, + putNumber, + + FieldTracked, + FieldType(..), + TableField(..), + emptyField, + fractionField, + fracFieldFromTracked, + ) where + +import qualified Spreadsheet.Formula as CalcForm +import Spreadsheet.Formula + (FormulaTracked, CellTracked, Tracked(Tracked), untracked) + +import qualified Control.Monad.Trans.RWS as MRWS +import Control.Monad (liftM2) +import Data.Bifunctor (bimap, ) + +import Text.Printf (PrintfArg, printf) + +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + +data FieldType = TypeString | TypeNumber + deriving (Eq, Ord, Enum, Show) + +type FieldTracked = TableField (Tracked (Maybe CalcForm.Formula) String) +data TableField a = + TableField { + fieldType :: FieldType, + fieldQuoted :: Bool, + fieldAnchor :: String, + fieldHead :: Bool, + fieldSpan :: Int, + fieldPrecision :: Maybe Precision, + fieldContent :: a + } + +instance Functor TableField where + fmap f x = x{fieldContent = f $ fieldContent x} + + +type M = MRWS.RWS Int [FieldTracked] Int + +exec :: Int -> M () -> [FieldTracked] +exec row act = snd $ run row act + +run :: Int -> M row -> (row, [FieldTracked]) +run row act = MRWS.evalRWS act row 0 + + +makeField :: Bool -> a -> TableField a +makeField quote content = + TableField { + fieldType = TypeString, + fieldQuoted = quote, + fieldAnchor = "", + fieldHead = False, + fieldSpan = 1, + fieldPrecision = Nothing, + fieldContent = content + } + +putString :: String -> M () +putString str = + put $ makeField True $ untracked str + +putAnchor :: String -> String -> M () +putAnchor ref str = + put $ (makeField True $ untracked str) {fieldAnchor = ref} + + +put :: FieldTracked -> M () +put x = do + column <- MRWS.get + MRWS.tell [x] + MRWS.put $! column + fieldSpan x + + +putEmpty :: M () +putEmpty = put emptyField + +putInt :: (Ring.C a) => Int -> M (CellTracked a) +putInt = fmap CalcForm.fromInt . putNumber + +getCellName :: M CalcForm.CellId +getCellName = liftM2 CalcForm.CellId MRWS.ask MRWS.get + +putNumber :: (Value a) => a -> M (CellTracked a) +putNumber x = do + cell <- getCellName + put $ (makeField False $ untracked $ formatValue x) {fieldType = TypeNumber} + return $ Tracked cell x + +putValue :: (Value a) => FormulaTracked a -> M (CellTracked a) +putValue x = do + cell <- getCellName + put $ fieldFromTracked x + return $ x{CalcForm.trackedFormula = cell} + +putValueFormula :: (Value a) => FormulaTracked a -> M (FormulaTracked a) +putValueFormula = fmap CalcForm.trackedVar . putValue + +putFraction :: + (Fraction a) => Precision -> FormulaTracked a -> M (CellTracked a) +putFraction prec x = do + cell <- getCellName + put $ fracFieldFromTracked prec x + return $ x{CalcForm.trackedFormula = cell} + +putPlainFraction :: (Fraction a) => Precision -> a -> M (CellTracked a) +putPlainFraction prec x = do + cell <- getCellName + put $ fractionField prec x + return $ Tracked cell x + +putFractionFormula :: + (Fraction a) => Precision -> FormulaTracked a -> M (FormulaTracked a) +putFractionFormula prec = fmap CalcForm.trackedVar . putFraction prec + + +class Value a where + {- | + Convert a value to a text representation + that is compatible to spreadsheet processors. + -} + formatValue :: a -> String + +instance Value Int where + formatValue = show + +instance Value Integer where + formatValue = show + +instance Value Float where + formatValue = show + +instance Value Double where + formatValue = show + + +data Precision = Prec0 | Prec3 | Prec6 + deriving (Eq, Ord, Enum) + +class (Value a, Field.C a) => Fraction a where + formatFraction :: Precision -> a -> String + +instance Fraction Float where + formatFraction = formatFractionDefault + +instance Fraction Double where + formatFraction = formatFractionDefault + +formatFractionDefault :: (PrintfArg a) => Precision -> a -> String +formatFractionDefault prec = printf (precisionFormat prec) + +precisionFormat :: Precision -> String +precisionFormat prec = + case prec of + Prec0 -> "%.0f" + Prec3 -> "%.3f" + Prec6 -> "%.6f" + + +fieldFromTracked :: Value a => Tracked CalcForm.Formula a -> FieldTracked +fieldFromTracked x = + (makeField False $ bimap Just formatValue x) {fieldType = TypeNumber} + +fracFieldFromTracked :: + Fraction a => Precision -> Tracked CalcForm.Formula a -> FieldTracked +fracFieldFromTracked prec x = + (makeField False $ bimap Just (formatFraction prec) x) + {fieldType = TypeNumber, fieldPrecision = Just prec} + +emptyField :: FieldTracked +emptyField = makeField False $ untracked "" + +fractionField :: (Fraction a) => Precision -> a -> FieldTracked +fractionField prec a = + (makeField False $ untracked $ formatFraction prec a) + {fieldType = TypeNumber, fieldPrecision = Just prec} diff --git a/src/Time.hs b/src/Time.hs new file mode 100644 --- /dev/null +++ b/src/Time.hs @@ -0,0 +1,150 @@ +module Time ( + parseRecordingName, timeLabels, + parseLog, LogEntry(..), + Hour(..), hours, formatHour, parseHour, splitHour, nextHour, + ) where + +import qualified Data.Time.Format as TimeFormat +import qualified Data.Time.LocalTime as LocalTime +import qualified Data.Time.Clock as Clock +import Data.Time.LocalTime (LocalTime, TimeOfDay) +import Data.Time.Calendar (Day, addDays) + +import qualified LabelChain + +import qualified System.Path as Path + +import Control.DeepSeq (NFData, rnf) +import Control.Monad (guard) + +import qualified Data.List.Reverse.StrictElement as Rev +import qualified Data.List.HT as ListHT +import Data.Maybe (listToMaybe) +import Data.Char (isSpace) + + +{- | +Parse time from file names like @T2014-03-11_18-01-27_0000111.WAV@. +-} +parseRecordingName :: Path.RelFile -> Maybe LocalTime +parseRecordingName = + TimeFormat.parseTimeM True + TimeFormat.defaultTimeLocale "T%Y-%m-%d_%H-%M-%S_" . + take (length "T2014-03-11_18-01-27_") . + Path.toString + +timeLabels :: Double -> TimeOfDay -> LabelChain.T Double String +timeLabels duration = + fmap (TimeFormat.formatTime TimeFormat.defaultTimeLocale "%H:%M:%S") . + LabelChain.fromAdjacentChunks . + zip (chopDuration duration) . iterate nextSecond + +chopDuration :: Double -> [Double] +chopDuration = + let go dur = if dur>1 then 1 : go (dur-1) else [dur] + in go + +nextSecond :: TimeOfDay -> TimeOfDay +nextSecond = + LocalTime.timeToTimeOfDay . + (Clock.secondsToDiffTime 1 +) . + LocalTime.timeOfDayToTime + + +parseLogTime :: (String,String) -> Maybe LocalTime +parseLogTime (date,time) = + TimeFormat.parseTimeM True TimeFormat.defaultTimeLocale "%m/%d/%y %H:%M:%S" $ + date ++ " " ++ time + + +data LogEntry = Start FilePath | Stop | Recording Path.RelFile Double + deriving Show + +parseLog :: String -> [Either String (LocalTime, LogEntry)] +parseLog = + filter (either (not . null) (const True)) . + mergeAdjacent + (\row0 row1 -> + case (row0,row1) of + ((fileName, Nothing), (_, Just (time, ["Monitoring_started"]))) -> + Just $ Right (time, Start fileName) + _ -> Nothing) + (\(row,remd) -> maybe (Left row) Right $ do + (time, ss) <- remd + fmap ((,) time) $ + case ss of + ["Monitoring_stopped"] -> Just Stop + [fileName, durStr] -> do + path <- Path.maybe fileName + listToMaybe $ do + (dur, seconds) <- reads durStr + guard (dropWhile isSpace seconds == "s") + return $ Recording path dur + _ -> Nothing) . + map + (\row -> (,) row $ do + s0:s1:ss <- Just $ ListHT.chop ('\t'==) row + dateTime <- parseLogTime (s0,s1) + return (dateTime, ss)) . + map (Rev.dropWhile ('\r'==)) . + lines + +mergeAdjacent :: (a -> a -> Maybe b) -> (a -> b) -> [a] -> [b] +mergeAdjacent g f = + let go [] = [] + go [x] = [f x] + go (x0:x0s@(x1:x1s)) = + case g x0 x1 of + Nothing -> f x0 : go x0s + Just y -> y : go x1s + in go + + +data Hour = Hour {hourDay :: Day, hourOfDay :: Int} + deriving (Eq, Ord, Show) + +instance NFData Hour where + rnf (Hour day hour) = rnf (day, hour) + +hours :: LocalTime -> LabelChain.T Double Hour +hours start = + let (h,s) = splitHour start + in LabelChain.fromAdjacentChunks . + zip (max 0 (3600 - s) : repeat 3600) . iterate nextHour $ h + +formatHour :: String -> Hour -> String +formatHour fmt = + TimeFormat.formatTime TimeFormat.defaultTimeLocale fmt . localTimeFromHour + +localTimeFromHour :: Hour -> LocalTime +localTimeFromHour (Hour day hour) = + LocalTime.LocalTime { + LocalTime.localDay = day, + LocalTime.localTimeOfDay = LocalTime.midnight{LocalTime.todHour = hour} + } + +parseHour :: String -> String -> Maybe Hour +parseHour fmt = + fmap hourFromLocalTime . + TimeFormat.parseTimeM True TimeFormat.defaultTimeLocale fmt + +hourFromLocalTime :: LocalTime -> Hour +hourFromLocalTime time = + Hour + (LocalTime.localDay time) + (LocalTime.todHour $ LocalTime.localTimeOfDay time) + +splitHour :: LocalTime -> (Hour, Double) +splitHour + (LocalTime.LocalTime { + LocalTime.localDay = day, + LocalTime.localTimeOfDay = tod + }) = + (Hour day (LocalTime.todHour tod), + fromIntegral (LocalTime.todMin tod) * 60 + + realToFrac (LocalTime.todSec tod)) + +nextHour :: Hour -> Hour +nextHour (Hour day hour0) = + let (dayInc, hour1) = divMod (hour0+1) 24 + in Hour (addDays (fromIntegral dayInc) day) hour1