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