f7f76a5879d9b334945910350e86512ff9fb701b
[darcs-mirror-arbtt.git] / src / Stats.hs
1 {-# LANGUAGE RecordWildCards, NamedFieldPuns, TypeOperators, TupleSections #-}
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 = 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 :: Repeater -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
178 processRepeater ByDay rep =
179     filterElems (\(b :!: _) -> b) $
180     pure (RepeatedReportResults "Day" . map (\(d,rr) -> (showGregorian d, rr)) . M.toList) <*>
181     multiplex (utctDay . tlTime . Strict.snd) rep
182 processRepeater ByMonth rep =
183     filterElems (\(b :!: _) -> b) $
184     pure (RepeatedReportResults "Month" . map (\((y,m),rr) -> (show y ++ "-" ++ show m, rr)) . M.toList) <*>
185     multiplex ((\(y,m,_) -> (y, m)). toGregorian . utctDay . tlTime . Strict.snd) rep
186 processRepeater ByYear rep =
187     filterElems (\(b :!: _) -> b) $
188     pure (RepeatedReportResults "Year" . map (\(y,rr) -> (show y, rr)) . M.toList) <*>
189     multiplex ((\(y,_,_) -> y). toGregorian . utctDay . tlTime . Strict.snd) rep
190
191 processReport :: ReportOptions -> Report -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
192 processReport opts GeneralInfos =
193    pure (\n firstDate lastDate ttr tts ->
194     let timeDiff = diffUTCTime lastDate firstDate
195         fractionRec = realToFrac ttr / (realToFrac timeDiff) :: Double
196         fractionSel = realToFrac tts / (realToFrac timeDiff) :: Double
197         fractionSelRec = realToFrac tts / realToFrac ttr :: Double
198     in ListOfFields "General Information"
199         [ ("FirstRecord", show firstDate)
200         , ("LastRecord",  show lastDate)
201         , ("Number of records", show n)
202         , ("Total time recorded",  showTimeDiff opts ttr)
203         , ("Total time selected",  showTimeDiff opts tts)
204         , ("Fraction of total time recorded", printf "%3.0f%%" (fractionRec * 100))
205         , ("Fraction of total time selected", printf "%3.0f%%" (fractionSel * 100))
206         , ("Fraction of recorded time selected", printf "%3.0f%%" (fractionSelRec * 100))
207         ]) <*>
208     onAll lfLength <*>
209     onAll calcFirstDate <*>
210     onAll calcLastDate <*>
211     onAll calcTotalTime <*>
212     onSelected calcTotalTime
213
214 processReport opts  TotalTime =
215     onSelected $
216         pure (\totalTimeSel sums -> 
217             ListOfTimePercValues "Total time per tag" .
218             mapMaybe (\(tag,time) ->
219                   let perc = realToFrac time/realToFrac totalTimeSel
220                       pick = applyActivityFilter (roActivityFilter opts) tag
221                   in if pick && perc*100 >= roMinPercentage opts
222                   then Just $ ( show tag
223                               , showTimeDiff opts time
224                               , perc)
225                   else Nothing
226                   ) .
227             reverse .
228             sortBy (comparing snd) $
229             M.toList $
230             sums) <*>
231     calcTotalTime <*>
232     calcSums 
233
234 processReport opts (Category cat) = pure (\c -> processCategoryReport opts c cat) <*>
235     prepareCalculations
236
237 processReport opts EachCategory = 
238     pure (\c cats -> MultipleReportResults $ map (processCategoryReport opts c) cats) <*>
239     prepareCalculations <*>
240     onSelected calcCategories
241
242 processReport opts (IntervalCategory cat) =
243     processIntervalReport opts ("Intervals for category " ++ show cat) (extractCat cat) 
244     where
245         extractCat :: Category -> ActivityData -> Maybe String
246         extractCat cat = fmap (unpack . activityName) . listToMaybe . filter ( (==Just cat) . activityCategory )
247
248 processReport opts (IntervalTag tag) =
249     processIntervalReport opts ("Intervals for category " ++ show tag) (extractTag tag) 
250     where
251         extractTag :: Activity -> ActivityData -> Maybe String
252         extractTag tag = fmap show . listToMaybe . filter ( (==tag) )
253
254 processReport opts DumpSamples =
255     DumpResult <$> onSelected (mapElems toList $ fmap $
256         \(cd,ad) -> (tlData (cNow cd), cTimeZone cd, filterActivity (roActivityFilter opts) ad)
257         )
258
259 calcCategories :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Category]
260 calcCategories = fmap S.toList $ leftFold S.empty $ \s tl ->
261     foldl' go' s (snd (tlData tl))
262           where go' s (Activity (Just cat) _) = S.insert cat s
263                 go' s _                       = s
264
265 processCategoryReport opts ~(Calculations {..}) cat =
266         PieChartOfTimePercValues ("Statistics for category " ++ show cat) $
267                 let filteredSums = M.filterWithKey (\a _ -> isCategory cat a) sums
268                     uncategorizedTime = totalTimeSel - M.fold (+) 0 filteredSums
269                     tooSmallSums = M.filter (\t -> realToFrac t / realToFrac totalTimeSel * 100 < roMinPercentage opts) filteredSums
270                     tooSmallTimes = M.fold (+) 0 tooSmallSums
271                 in
272
273                 mapMaybe (\(tag,time) ->
274                       let perc = realToFrac time/realToFrac totalTimeSel
275                           pick = applyActivityFilter (roActivityFilter opts) tag
276                       in if pick && perc*100 >= roMinPercentage opts
277                       then Just ( show tag
278                                 , showTimeDiff opts time
279                                 , perc)
280                       else Nothing
281                       )
282                       (reverse $ sortBy (comparing snd) $ M.toList filteredSums)
283                 ++
284                 (
285                 if tooSmallTimes > 0
286                 then [( printf "(%d entries omitted)" (M.size tooSmallSums)
287                       , showTimeDiff opts tooSmallTimes
288                       , realToFrac tooSmallTimes/realToFrac totalTimeSel
289                       )]
290                 else []
291                 )
292                 ++      
293                 (if uncategorizedTime > 0
294                 then [( "(unmatched time)"
295                       , showTimeDiff opts uncategorizedTime
296                       , realToFrac uncategorizedTime/realToFrac totalTimeSel
297                       )]
298                 else []
299                 )
300
301 processIntervalReport :: ReportOptions -> String -> (ActivityData -> Maybe String) -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
302 processIntervalReport opts title extr = runOnIntervals  go1 go2
303   where
304     go1 :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Interval]
305     go1 = go3 `mapElems` fmap (extr . snd) 
306     go3 :: LeftFold (TimeLogEntry (Maybe String)) [Interval]
307     go3 = runOnGroups ((==) `on` tlData) go4 (onJusts toList)
308     go4 :: LeftFold (TimeLogEntry (Maybe String)) (Maybe Interval)
309     go4 = pure (\fe le ->
310         case tlData fe of
311             Just str -> Just
312                 ( str
313                 , showUtcTime (tlTime fe)
314                 , showUtcTime (tlTime le)
315                 , showTimeDiff opts $
316                     tlTime le `diffUTCTime` tlTime fe + fromIntegral (tlRate fe)/1000
317                 )
318             Nothing -> Nothing) <*>
319         (fromJust <$> lfFirst) <*>
320         (fromJust <$> lfLast)
321     go2 :: LeftFold [Interval] ReportResults
322     go2 = ListOfIntervals title <$> concatFold
323         
324
325 {-
326         ((extr. snd) `filterWith` 
327             runOnIntervals
328                 (runOnGroups ((==) `on` tlData)
329 -}
330
331
332 {-
333 intervalReportToTable :: String -> (ActivityData -> Maybe String) -> ReportResults
334 intervalReportToTable title extr = ListOfIntervals title $
335     map (\tles ->
336         let str = fromJust (tlData (head tles))
337             firstE = showUtcTime (tlTime (head tles))
338             lastE = showUtcTime (tlTime (last tles))
339             timeLength = showTimeDiff $
340                 tlTime (last tles) `diffUTCTime` tlTime (head tles) +
341                 fromIntegral (tlRate (last tles))/1000
342         in (str, firstE, lastE, timeLength)) $
343     filter (isJust . tlData . head ) $
344     concat $
345     fmap (groupBy ((==) `on` tlData) .
346          (fmap.fmap) (extr . snd)) $
347     tags
348 -}           
349             
350 renderReport :: ReportOptions -> ReportResults -> IO ()
351 renderReport opts (DumpResult samples) =
352     dumpActivity samples
353 renderReport opts (MultipleReportResults reports) =
354     sequence_ . intersperse (putStrLn "") . map (renderReport opts) $ reports
355 renderReport opts reportdata =
356     putStr $ doRender opts reportdata
357
358 doRender :: ReportOptions -> ReportResults -> String
359 doRender opts reportdata = case roReportFormat opts of
360                 RFText -> renderReportText id reportdata
361                 RFCSV -> renderWithDelimiter "," $ renderXSV reportdata
362                 RFTSV -> renderWithDelimiter "\t" $ renderXSV reportdata
363
364 renderReportText titleMod (ListOfFields title dats) = 
365     underline (titleMod title) ++
366     (tabulate False $ map (\(f,v) -> [f,v]) dats)
367
368 renderReportText titleMod (ListOfTimePercValues title dats) = 
369     underline (titleMod title) ++ (tabulate True $ listOfValues dats)
370
371 renderReportText titleMod (PieChartOfTimePercValues title dats) = 
372     underline (titleMod title) ++ (tabulate True $ piechartOfValues dats)
373
374 renderReportText titleMod (ListOfIntervals title dats) = 
375     underline (titleMod title) ++ (tabulate True $ listOfIntervals dats)
376
377 renderReportText titleMod (RepeatedReportResults cat reps) = 
378     intercalate "\n" $ map (\(v,rr) -> renderReportText (titleMod . mod v) rr) reps
379   where mod v s = s ++ " (" ++ cat ++ " " ++ v ++ ")"
380
381 listOfValues dats =
382     ["Tag","Time","Percentage"] :
383     map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats
384
385 piechartOfValues dats =
386     ["Tag","Time","Percentage"] :
387     map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats
388
389 listOfIntervals dats =
390     ["Tag","From","Until","Duration"] :
391     map (\(t,f,u,d) -> [t,f,u,d]) dats
392
393 -- The reporting of "General Information" is not supported for the
394 -- comma-separated output format.
395 renderXSV (ListOfFields title dats) = 
396     error ("\"" ++ title ++ "\"" ++ " not supported for this output format")
397
398 renderXSV (ListOfTimePercValues _ dats) = listOfValues dats
399
400 renderXSV (PieChartOfTimePercValues _ dats) = piechartOfValues dats
401
402 renderXSV (ListOfIntervals title dats) = listOfIntervals dats
403
404 -- A bit code-smelly here.
405 renderXSV (RepeatedReportResults cat reps) = title : fields
406   where
407     title = cat : head (renderXSV (snd (head reps)))
408     fields = concatMap (\(v,rr) -> map (v:) (tail (renderXSV rr))) reps
409
410 renderWithDelimiter :: String -> [[String]] -> String
411 renderWithDelimiter delim datasource =
412     unlines $ map (intercalate delim) datasource
413
414 tabulate :: Bool -> [[String]] -> String
415 tabulate titlerow rows = unlines $ addTitleRow $ map (intercalate " | " . zipWith (\l s -> take (l - length s) (repeat ' ') ++ s) colwidths) rows
416   where cols = transpose rows
417         colwidths = map (maximum . map length) cols
418         addTitleRow | titlerow  = \(l:ls) -> (map (\c -> if c == ' ' then '_' else c) l ++ "_")
419                                              : ls
420                  -- | titlerow  = \(l:ls) -> l : (take (length l) (repeat '-')) : ls
421                     | otherwise = id
422
423 showTimeDiff :: ReportOptions -> NominalDiffTime -> String
424 showTimeDiff (ReportOptions { roReportFormat = RFText }) = showTimeDiffHuman
425 showTimeDiff _                                           = showTimeDiffMachine
426
427 showTimeDiffHuman :: NominalDiffTime -> String
428 showTimeDiffHuman t = go False $ zip [days,hours,mins,secs] ["d","h","m","s"]
429   where s = round t :: Integer
430         days  =  s `div` (24*60*60)
431         hours = (s `div` (60*60)) `mod` 24
432         mins  = (s `div` 60) `mod` 60
433         secs  =  s `mod` 60 
434         go False []         = "0s"
435         go True  []         = ""
436 --      go True  vs         | all (==0) (map fst vs) = concat (replicate (length vs) "   ")
437         go True  ((a,u):vs)             = printf "%02d%s" a u ++ go True vs
438         go False ((a,u):vs) | a > 0     = printf "%2d%s" a u ++ go True vs
439                             | otherwise =                       go False vs
440
441 showTimeDiffMachine :: NominalDiffTime -> String
442 showTimeDiffMachine t = printf "%d:%02d:%02d" hours mins secs
443   where s = round t :: Integer
444         hours = s `div` (60*60)
445         mins  = (s `div` 60) `mod` 60
446         secs  =  s `mod` 60 
447
448 showUtcTime :: UTCTime -> String
449 showUtcTime = formatTime defaultTimeLocale "%x %X"
450
451 underline :: String -> String
452 underline str = unlines 
453     [ str
454     , map (const '=') str
455     ]