classify-frog-0.2.3: src/Spreadsheet/Format.hs
{-# 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 =
"<html lang=en>" :
printf "<head><title>%s</title></head>" name :
"<body>" :
[]
fileOpen =
"<html lang=en>" :
"<body>" :
[]
tableOpen =
"<table>" :
[]
tableClose =
"</table>" :
[]
fileClose =
"</body>" :
"</html>" :
[]
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 "<h1>%s</h1>" name
:
tableOpen
++
formatHTMLRows typ content
++
tableClose
}
formatXML2003 =
let fileOpen =
"<?xml version='1.0' encoding='UTF-8'?>" :
"<?mso-application progid='Excel.Sheet'?>" :
"<Workbook" :
" xmlns='urn:schemas-microsoft-com:office:spreadsheet'" :
" xmlns:c='urn:schemas-microsoft-com:office:component:spreadsheet'" :
" xmlns:o='urn:schemas-microsoft-com:office:office'" :
" xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet'" :
" xmlns:x2='http://schemas.microsoft.com/office/excel/2003/xml'" :
" xmlns:x='urn:schemas-microsoft-com:office:excel'>" :
"<Styles>" :
"<Style ss:ID='head'>" :
" <Alignment ss:Horizontal='Center'/>" :
" <Font ss:Bold='1'/>" :
"</Style>" :
"<Style ss:ID='frac0'>" :
" <NumberFormat ss:Format='0'/>" :
"</Style>" :
"<Style ss:ID='frac3'>" :
" <NumberFormat ss:Format='0.000'/>" :
"</Style>" :
"<Style ss:ID='frac6'>" :
" <NumberFormat ss:Format='0.000000'/>" :
"</Style>" :
"</Styles>" :
[]
tableOpen name =
printf "<ss:Worksheet ss:Name='%s'>" name :
"<Table>" :
[]
tableClose =
"</Table>" :
"</ss:Worksheet>" :
[]
fileClose =
"</Workbook>" :
[]
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 -> "<tr>"++row++"</tr>") .
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 "<a href='%s'>" $ CalcRow.fieldAnchor x, "</a>")
escape = concatMap (\c -> if c=='\n' then "<br>" else [c])
in printf "<%s%s>%s%s%s</%s>"
tag colSpan anchorOpen
(escape $ formatField typ x) anchorClose tag))
formatXML2003Rows :: EvalType -> [[FieldTracked]] -> [String]
formatXML2003Rows ftyp =
concatMap (\row -> "<Row>" : 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 "<Cell%s%s%s%s><Data ss:Type='%s'>%s</Data></Cell>"
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