b2bce3704b75ac732d92ae2f7c75ba395dfa2dde
[darcs-mirror-arbtt.git] / src / Stats.hs
1 {-# LANGUAGE RecordWildCards, NamedFieldPuns, TypeOperators, TupleSections, GADTSyntax, ExistentialQuantification #-}
2 module Stats (
3     Report(..),
4     ReportOptions(..),
5     ReportFormat(..),
6     ReportResults(..),
7     ActivityFilter(..),
8     Filter(..),
9     Repeater(..),
10     defaultFilter,
11     defaultReportOptions,
12     parseActivityMatcher,
13     filterPredicate,
14     prepareCalculations,
15     processReport,
16     processRepeater,
17     renderReport
18     ) where
19
20 import Data.Time
21 import Data.Maybe
22 import Data.List
23 import Data.Ord
24 import Text.Printf
25 import qualified Data.Map as M
26 import qualified Data.Set as S
27 import Data.MyText (Text,pack,unpack)
28 import Data.Function (on)
29 import System.Locale (defaultTimeLocale)
30 import Control.Applicative
31 import Data.Strict ((:!:), Pair(..))
32 import qualified Data.Strict as Strict
33 import Data.Traversable (sequenceA)
34 import Control.Arrow
35
36 import Data
37 import Categorize
38 import LeftFold
39 import DumpFormat
40
41
42 data Report = GeneralInfos
43     | TotalTime
44     | Category Category
45     | EachCategory
46     | IntervalCategory Category
47     | IntervalTag Activity
48     | DumpSamples
49         deriving (Show, Eq)
50
51 data Filter = Exclude ActivityMatcher | Only ActivityMatcher | GeneralCond String
52         deriving (Show, Eq)
53
54 data ActivityMatcher = MatchActivity Activity | MatchCategory Category
55         deriving (Show, Eq)
56
57 data ActivityFilter = ExcludeActivity ActivityMatcher | OnlyActivity ActivityMatcher
58         deriving (Show, Eq)
59
60 data Repeater = ByMinute | ByHour | ByDay | ByMonth | ByYear
61         deriving (Show, Eq)
62
63 -- Supported report output formats: text, comma-separated values and
64 -- tab-separated values
65 data ReportFormat = RFText | RFCSV | RFTSV
66         deriving (Show, Eq)
67
68 data ReportOptions = ReportOptions
69     { roMinPercentage :: Double
70     , roReportFormat :: ReportFormat
71     , roActivityFilter :: [ActivityFilter]
72     }
73         deriving (Show, Eq)
74
75 defaultReportOptions :: ReportOptions
76 defaultReportOptions = ReportOptions
77     { roMinPercentage = 1
78     , roReportFormat = RFText
79     , roActivityFilter = []
80     }
81
82 -- Data format semantically representing the result of a report, including the
83 -- title
84 type Interval = (String,String,String,String) 
85 data ReportResults =
86         ListOfFields String [(String, String)]
87         | ListOfTimePercValues String [(String, String, Double)]
88         | PieChartOfTimePercValues  String [(String, String, Double)]
89         | ListOfIntervals String [Interval]
90         | MultipleReportResults [ReportResults]
91         | RepeatedReportResults String [(String, ReportResults)]
92         | DumpResult (TimeLog (CaptureData, TimeZone, ActivityData))
93
94
95 filterPredicate :: [Filter] -> TimeLogEntry (Ctx, ActivityData) -> Bool
96 filterPredicate filters tl = 
97        all (\flag -> case flag of 
98                 Exclude act  -> excludeTag act tl
99                 Only act     -> onlyTag act tl
100                 GeneralCond s-> applyCond s (cTimeZone (fst (tlData tl))) tl) filters
101
102 filterActivity :: [ActivityFilter] -> ActivityData -> ActivityData
103 filterActivity fs = filter (applyActivityFilter fs)
104
105 applyActivityFilter :: [ActivityFilter] -> Activity -> Bool
106 applyActivityFilter fs act = all go fs
107     where go (ExcludeActivity matcher) = not (matchActivityMatcher matcher act)
108           go (OnlyActivity matcher)    =      matchActivityMatcher matcher act 
109                                 
110 excludeTag matcher = not . any (matchActivityMatcher matcher) . snd . tlData
111 onlyTag matcher = any (matchActivityMatcher matcher) . snd . tlData
112
113 defaultFilter :: Filter
114 defaultFilter = Exclude (MatchActivity inactiveActivity)
115
116 matchActivityMatcher :: ActivityMatcher -> Activity -> Bool
117 matchActivityMatcher (MatchActivity act1) act2 = act1 == act2
118 matchActivityMatcher (MatchCategory cat) act2 = Just cat == activityCategory act2
119
120 parseActivityMatcher :: String -> ActivityMatcher 
121 parseActivityMatcher str | last str == ':' = MatchCategory (pack (init str))
122                          | otherwise       = MatchActivity (read str)
123
124 -- | to be used lazily, to re-use computation when generating more than one
125 -- report at a time
126 data Calculations = Calculations
127         { firstDate :: UTCTime
128         , lastDate  :: UTCTime
129         , timeDiff :: NominalDiffTime
130         , totalTimeRec :: NominalDiffTime
131         , totalTimeSel :: NominalDiffTime
132         , fractionRec :: Double
133         , fractionSel :: Double
134         , fractionSelRec :: Double
135         , sums :: M.Map Activity NominalDiffTime
136         -- , allTags :: TimeLog (Ctx, ActivityData)
137         -- tags is a list of uninterrupted entries
138         -- , tags :: [TimeLog (Ctx, ActivityData)]
139         }
140
141 prepareCalculations :: LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) Calculations
142 prepareCalculations =
143     pure (\fd ld ttr tts s -> 
144         let c = Calculations
145                   { firstDate = fd
146                   , lastDate = ld
147                   , timeDiff = diffUTCTime (lastDate c) (firstDate c)
148                   , totalTimeRec = ttr
149                   , totalTimeSel = tts
150                   , fractionRec = realToFrac (totalTimeRec c) / (realToFrac (timeDiff c))
151                   , fractionSel = realToFrac (totalTimeSel c) / (realToFrac (timeDiff c))
152                   , fractionSelRec = realToFrac (totalTimeSel c) / realToFrac (totalTimeRec c)
153                   , sums = s
154                   } in c) <*>
155     onAll calcFirstDate <*>
156     onAll calcLastDate <*>
157     onAll calcTotalTime <*>
158     onSelected calcTotalTime <*>
159     onSelected calcSums 
160   where
161
162 calcFirstDate :: LeftFold (TimeLogEntry a) UTCTime
163 calcFirstDate = fromJust <$> lfFirst `mapElems` tlTime
164
165 calcLastDate :: LeftFold (TimeLogEntry a) UTCTime
166 calcLastDate = fromJust <$> lfLast `mapElems` tlTime
167
168 calcTotalTime :: LeftFold (TimeLogEntry a) NominalDiffTime
169 calcTotalTime = (/1000) <$> LeftFold 0 (+) fromInteger `mapElems` tlRate
170
171 calcSums :: LeftFold (TimeLogEntry (a, [Activity])) (M.Map Activity NominalDiffTime)
172 calcSums = LeftFold M.empty
173             (\m tl ->
174                 let go' m act = M.insertWith' (+) act (fromInteger (tlRate tl)/1000) m
175                 in foldl' go' m (snd (tlData tl))) id
176
177 processRepeater :: TimeZone -> Repeater -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
178 processRepeater tz r rep = case repeaterImpl r of
179     RepeaterImpl catR showR ->
180         filterElems (\(b :!: _) -> b) $
181         pure (RepeatedReportResults (repeaterTitle r) . map (first showR) . M.toList) <*>
182         multiplex (catR . utcToLocalTime tz . tlTime . Strict.snd) rep
183
184 data RepeaterImpl where
185   RepeaterImpl :: Ord r => (LocalTime -> r) -> (r -> String) -> RepeaterImpl
186
187 repeaterTitle :: Repeater -> String
188 repeaterTitle ByMinute = "Minute"
189 repeaterTitle ByHour   = "Hour"
190 repeaterTitle ByDay    = "Day"
191 repeaterTitle ByMonth  = "Month"
192 repeaterTitle ByYear   = "Year"
193
194 repeaterImpl :: Repeater -> RepeaterImpl
195 repeaterImpl ByMinute = RepeaterImpl
196     -- a somewhat lazy implementations, using strings...
197     (formatTime defaultTimeLocale "%F %H:%M")
198     id
199 repeaterImpl ByHour = RepeaterImpl
200     (formatTime defaultTimeLocale "%F %H:00")
201     id
202 repeaterImpl ByDay = RepeaterImpl
203     localDay
204     showGregorian
205 repeaterImpl ByMonth = RepeaterImpl
206     ((\(y,m,_) -> (y, m)) . toGregorian . localDay)
207     (\(y,m) -> show y ++ "-" ++ show m)
208 repeaterImpl ByYear = RepeaterImpl
209     ((\(y,_,_) -> y) . toGregorian . localDay)
210     show
211
212 processReport :: ReportOptions -> Report -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
213 processReport opts GeneralInfos =
214    pure (\n firstDate lastDate ttr tts ->
215     let timeDiff = diffUTCTime lastDate firstDate
216         fractionRec = realToFrac ttr / (realToFrac timeDiff) :: Double
217         fractionSel = realToFrac tts / (realToFrac timeDiff) :: Double
218         fractionSelRec = realToFrac tts / realToFrac ttr :: Double
219     in ListOfFields "General Information"
220         [ ("FirstRecord", show firstDate)
221         , ("LastRecord",  show lastDate)
222         , ("Number of records", show n)
223         , ("Total time recorded",  showTimeDiff opts ttr)
224         , ("Total time selected",  showTimeDiff opts tts)
225         , ("Fraction of total time recorded", printf "%3.0f%%" (fractionRec * 100))
226         , ("Fraction of total time selected", printf "%3.0f%%" (fractionSel * 100))
227         , ("Fraction of recorded time selected", printf "%3.0f%%" (fractionSelRec * 100))
228         ]) <*>
229     onAll lfLength <*>
230     onAll calcFirstDate <*>
231     onAll calcLastDate <*>
232     onAll calcTotalTime <*>
233     onSelected calcTotalTime
234
235 processReport opts  TotalTime =
236     onSelected $
237         pure (\totalTimeSel sums -> 
238             ListOfTimePercValues "Total time per tag" .
239             mapMaybe (\(tag,time) ->
240                   let perc = realToFrac time/realToFrac totalTimeSel
241                       pick = applyActivityFilter (roActivityFilter opts) tag
242                   in if pick && perc*100 >= roMinPercentage opts
243                   then Just $ ( show tag
244                               , showTimeDiff opts time
245                               , perc)
246                   else Nothing
247                   ) .
248             reverse .
249             sortBy (comparing snd) $
250             M.toList $
251             sums) <*>
252     calcTotalTime <*>
253     calcSums 
254
255 processReport opts (Category cat) = pure (\c -> processCategoryReport opts c cat) <*>
256     prepareCalculations
257
258 processReport opts EachCategory = 
259     pure (\c cats -> MultipleReportResults $ map (processCategoryReport opts c) cats) <*>
260     prepareCalculations <*>
261     onSelected calcCategories
262
263 processReport opts (IntervalCategory cat) =
264     processIntervalReport opts ("Intervals for category " ++ show cat) (extractCat cat) 
265     where
266         extractCat :: Category -> ActivityData -> Maybe String
267         extractCat cat = fmap (unpack . activityName) . listToMaybe . filter ( (==Just cat) . activityCategory )
268
269 processReport opts (IntervalTag tag) =
270     processIntervalReport opts ("Intervals for category " ++ show tag) (extractTag tag) 
271     where
272         extractTag :: Activity -> ActivityData -> Maybe String
273         extractTag tag = fmap show . listToMaybe . filter ( (==tag) )
274
275 processReport opts DumpSamples =
276     DumpResult <$> onSelected (mapElems toList $ fmap $
277         \(cd,ad) -> (tlData (cNow cd), cTimeZone cd, filterActivity (roActivityFilter opts) ad)
278         )
279
280 calcCategories :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Category]
281 calcCategories = fmap S.toList $ leftFold S.empty $ \s tl ->
282     foldl' go' s (snd (tlData tl))
283           where go' s (Activity (Just cat) _) = S.insert cat s
284                 go' s _                       = s
285
286 processCategoryReport opts ~(Calculations {..}) cat =
287         PieChartOfTimePercValues ("Statistics for category " ++ show cat) $
288                 let filteredSums = M.filterWithKey (\a _ -> isCategory cat a) sums
289                     uncategorizedTime = totalTimeSel - M.fold (+) 0 filteredSums
290                     tooSmallSums = M.filter (\t -> realToFrac t / realToFrac totalTimeSel * 100 < roMinPercentage opts) filteredSums
291                     tooSmallTimes = M.fold (+) 0 tooSmallSums
292                 in
293
294                 mapMaybe (\(tag,time) ->
295                       let perc = realToFrac time/realToFrac totalTimeSel
296                           pick = applyActivityFilter (roActivityFilter opts) tag
297                       in if pick && perc*100 >= roMinPercentage opts
298                       then Just ( show tag
299                                 , showTimeDiff opts time
300                                 , perc)
301                       else Nothing
302                       )
303                       (reverse $ sortBy (comparing snd) $ M.toList filteredSums)
304                 ++
305                 (
306                 if tooSmallTimes > 0
307                 then [( printf "(%d entries omitted)" (M.size tooSmallSums)
308                       , showTimeDiff opts tooSmallTimes
309                       , realToFrac tooSmallTimes/realToFrac totalTimeSel
310                       )]
311                 else []
312                 )
313                 ++      
314                 (if uncategorizedTime > 0
315                 then [( "(unmatched time)"
316                       , showTimeDiff opts uncategorizedTime
317                       , realToFrac uncategorizedTime/realToFrac totalTimeSel
318                       )]
319                 else []
320                 )
321
322 processIntervalReport :: ReportOptions -> String -> (ActivityData -> Maybe String) -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
323 processIntervalReport opts title extr = runOnIntervals  go1 go2
324   where
325     go1 :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Interval]
326     go1 = go3 `mapElems` fmap (extr . snd) 
327     go3 :: LeftFold (TimeLogEntry (Maybe String)) [Interval]
328     go3 = runOnGroups ((==) `on` tlData) go4 (onJusts toList)
329     go4 :: LeftFold (TimeLogEntry (Maybe String)) (Maybe Interval)
330     go4 = pure (\fe le ->
331         case tlData fe of
332             Just str -> Just
333                 ( str
334                 , showUtcTime (tlTime fe)
335                 , showUtcTime (tlTime le)
336                 , showTimeDiff opts $
337                     tlTime le `diffUTCTime` tlTime fe + fromIntegral (tlRate fe)/1000
338                 )
339             Nothing -> Nothing) <*>
340         (fromJust <$> lfFirst) <*>
341         (fromJust <$> lfLast)
342     go2 :: LeftFold [Interval] ReportResults
343     go2 = ListOfIntervals title <$> concatFold
344         
345
346 {-
347         ((extr. snd) `filterWith` 
348             runOnIntervals
349                 (runOnGroups ((==) `on` tlData)
350 -}
351
352
353 {-
354 intervalReportToTable :: String -> (ActivityData -> Maybe String) -> ReportResults
355 intervalReportToTable title extr = ListOfIntervals title $
356     map (\tles ->
357         let str = fromJust (tlData (head tles))
358             firstE = showUtcTime (tlTime (head tles))
359             lastE = showUtcTime (tlTime (last tles))
360             timeLength = showTimeDiff $
361                 tlTime (last tles) `diffUTCTime` tlTime (head tles) +
362                 fromIntegral (tlRate (last tles))/1000
363         in (str, firstE, lastE, timeLength)) $
364     filter (isJust . tlData . head ) $
365     concat $
366     fmap (groupBy ((==) `on` tlData) .
367          (fmap.fmap) (extr . snd)) $
368     tags
369 -}           
370             
371 renderReport :: ReportOptions -> ReportResults -> IO ()
372 renderReport opts (DumpResult samples) =
373     dumpActivity samples
374 renderReport opts (MultipleReportResults reports) =
375     sequence_ . intersperse (putStrLn "") . map (renderReport opts) $ reports
376 renderReport opts reportdata =
377     putStr $ doRender opts reportdata
378
379 doRender :: ReportOptions -> ReportResults -> String
380 doRender opts reportdata = case roReportFormat opts of
381                 RFText -> renderReportText id reportdata
382                 RFCSV -> renderWithDelimiter "," $ renderXSV reportdata
383                 RFTSV -> renderWithDelimiter "\t" $ renderXSV reportdata
384
385 renderReportText titleMod (ListOfFields title dats) = 
386     underline (titleMod title) ++
387     (tabulate False $ map (\(f,v) -> [f,v]) dats)
388
389 renderReportText titleMod (ListOfTimePercValues title dats) = 
390     underline (titleMod title) ++ (tabulate True $ listOfValues dats)
391
392 renderReportText titleMod (PieChartOfTimePercValues title dats) = 
393     underline (titleMod title) ++ (tabulate True $ piechartOfValues dats)
394
395 renderReportText titleMod (ListOfIntervals title dats) = 
396     underline (titleMod title) ++ (tabulate True $ listOfIntervals dats)
397
398 renderReportText titleMod (RepeatedReportResults cat reps) = 
399     intercalate "\n" $ map (\(v,rr) -> renderReportText (titleMod . mod v) rr) reps
400   where mod v s = s ++ " (" ++ cat ++ " " ++ v ++ ")"
401
402 listOfValues dats =
403     ["Tag","Time","Percentage"] :
404     map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats
405
406 piechartOfValues dats =
407     ["Tag","Time","Percentage"] :
408     map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats
409
410 listOfIntervals dats =
411     ["Tag","From","Until","Duration"] :
412     map (\(t,f,u,d) -> [t,f,u,d]) dats
413
414 -- The reporting of "General Information" is not supported for the
415 -- comma-separated output format.
416 renderXSV (ListOfFields title dats) = 
417     error ("\"" ++ title ++ "\"" ++ " not supported for this output format")
418
419 renderXSV (ListOfTimePercValues _ dats) = listOfValues dats
420
421 renderXSV (PieChartOfTimePercValues _ dats) = piechartOfValues dats
422
423 renderXSV (ListOfIntervals title dats) = listOfIntervals dats
424
425 -- A bit code-smelly here.
426 renderXSV (RepeatedReportResults cat reps) = title : fields
427   where
428     title = cat : head (renderXSV (snd (head reps)))
429     fields = concatMap (\(v,rr) -> map (v:) (tail (renderXSV rr))) reps
430
431 renderWithDelimiter :: String -> [[String]] -> String
432 renderWithDelimiter delim datasource =
433     unlines $ map (intercalate delim) datasource
434
435 tabulate :: Bool -> [[String]] -> String
436 tabulate titlerow rows = unlines $ addTitleRow $ map (intercalate " | " . zipWith (\l s -> take (l - length s) (repeat ' ') ++ s) colwidths) rows
437   where cols = transpose rows
438         colwidths = map (maximum . map length) cols
439         addTitleRow | titlerow  = \(l:ls) -> (map (\c -> if c == ' ' then '_' else c) l ++ "_")
440                                              : ls
441                  -- | titlerow  = \(l:ls) -> l : (take (length l) (repeat '-')) : ls
442                     | otherwise = id
443
444 showTimeDiff :: ReportOptions -> NominalDiffTime -> String
445 showTimeDiff (ReportOptions { roReportFormat = RFText }) = showTimeDiffHuman
446 showTimeDiff _                                           = showTimeDiffMachine
447
448 showTimeDiffHuman :: NominalDiffTime -> String
449 showTimeDiffHuman t = go False $ zip [days,hours,mins,secs] ["d","h","m","s"]
450   where s = round t :: Integer
451         days  =  s `div` (24*60*60)
452         hours = (s `div` (60*60)) `mod` 24
453         mins  = (s `div` 60) `mod` 60
454         secs  =  s `mod` 60 
455         go False []         = "0s"
456         go True  []         = ""
457 --      go True  vs         | all (==0) (map fst vs) = concat (replicate (length vs) "   ")
458         go True  ((a,u):vs)             = printf "%02d%s" a u ++ go True vs
459         go False ((a,u):vs) | a > 0     = printf "%2d%s" a u ++ go True vs
460                             | otherwise =                       go False vs
461
462 showTimeDiffMachine :: NominalDiffTime -> String
463 showTimeDiffMachine t = printf "%d:%02d:%02d" hours mins secs
464   where s = round t :: Integer
465         hours = s `div` (60*60)
466         mins  = (s `div` 60) `mod` 60
467         secs  =  s `mod` 60 
468
469 showUtcTime :: UTCTime -> String
470 showUtcTime = formatTime defaultTimeLocale "%x %X"
471
472 underline :: String -> String
473 underline str = unlines 
474     [ str
475     , map (const '=') str
476     ]