Let --exclude and --include take category parameters as well.
[darcs-mirror-arbtt.git] / src / Stats.hs
1 {-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
2 module Stats where
3
4 import Data.Time
5 import Data.Maybe
6 import Data.List
7 import Data.Ord
8 import Text.Printf
9 import qualified Data.Map as M
10 import qualified Data.Set as S
11 import Data.MyText (Text,pack,unpack)
12 import Data.Function (on)
13 import System.Locale (defaultTimeLocale)
14
15
16 import Data
17 import Categorize
18
19
20 data Report = GeneralInfos
21     | TotalTime
22     | Category Category
23     | EachCategory
24     | IntervalCategory Category
25     | IntervalTag Activity
26         deriving (Show, Eq)
27
28 data Filter = Exclude ActivityMatcher | Only ActivityMatcher | GeneralCond String
29         deriving (Show, Eq)
30
31 data ActivityMatcher = MatchActivity Activity | MatchCategory Category
32         deriving (Show, Eq)
33
34 -- Supported report output formats: text, comma-separated values and
35 -- tab-separated values
36 data ReportFormat = RFText | RFCSV | RFTSV
37         deriving (Show, Eq)
38
39 data ReportOptions = ReportOptions
40     { roMinPercentage :: Double
41     , roReportFormat :: ReportFormat
42     }
43         deriving (Show, Eq)
44
45 defaultReportOptions = ReportOptions
46     { roMinPercentage = 1
47     , roReportFormat = RFText
48     }
49
50 -- Data format semantically representing the result of a report, including the
51 -- title
52 data ReportResults =
53         ListOfFields String [(String, String)]
54         | ListOfTimePercValues String [(String, String, Double)]
55         | PieChartOfTimePercValues  String [(String, String, Double)]
56         | ListOfIntervals String [(String,String,String,String)]
57
58
59 -- We apply the filters in a way such that consecutive runs of selected samples
60 -- are in the same sublist, and sublists are separated by non-selected samples
61 applyFilters :: [Filter] -> TimeLog (Ctx, ActivityData) -> [TimeLog (Ctx, ActivityData)]
62 applyFilters filters = filterAndSeparate $ \tl ->
63        all (\flag -> case flag of 
64                 Exclude act  -> excludeTag act tl
65                 Only act     -> onlyTag act tl
66                 GeneralCond s-> applyCond s tl) filters
67
68 filterAndSeparate :: (a -> Bool) -> [a] -> [[a]]
69 filterAndSeparate pred = fst . go
70   where go [] = ([],True)
71         go (x:xs) = case (go xs,pred x) of
72                     ((rs,     True) , True)  -> ([x]:rs,   False)
73                     (((r:rs), False), True)  -> ((x:r):rs, False)
74                     ((rs,     _)    , False) -> (rs,       True)
75                                 
76 excludeTag matcher = not . any (matchActivityMatcher matcher) . snd . tlData
77 onlyTag matcher = any (matchActivityMatcher matcher) . snd . tlData
78 defaultFilter = Exclude (MatchActivity inactiveActivity)
79
80 matchActivityMatcher :: ActivityMatcher -> Activity -> Bool
81 matchActivityMatcher (MatchActivity act1) act2 = act1 == act2
82 matchActivityMatcher (MatchCategory cat) act2 = Just cat == activityCategory act2
83
84 parseActivityMatcher :: String -> ActivityMatcher 
85 parseActivityMatcher str | last str == ':' = MatchCategory (pack (init str))
86                          | otherwise       = MatchActivity (read str)
87
88 -- | to be used lazily, to re-use computation when generating more than one
89 -- report at a time
90 data Calculations = Calculations
91         { firstDate :: UTCTime
92         , lastDate  :: UTCTime
93         , timeDiff :: NominalDiffTime
94         , totalTimeRec :: NominalDiffTime
95         , totalTimeSel :: NominalDiffTime
96         , fractionRec :: Double
97         , fractionSel :: Double
98         , fractionSelRec :: Double
99         , sums :: M.Map Activity NominalDiffTime
100         , allTags :: TimeLog (Ctx, ActivityData)
101         -- tags is a list of uninterrupted entries
102         , tags :: [TimeLog (Ctx, ActivityData)]
103         }
104
105 prepareCalculations :: TimeLog (Ctx, ActivityData) -> [TimeLog (Ctx, ActivityData)] -> Calculations
106 prepareCalculations allTags tags =
107   let c = Calculations
108           { firstDate = tlTime (head allTags)
109           , lastDate = tlTime (last allTags)
110           , timeDiff = diffUTCTime (lastDate c) (firstDate c)
111           , totalTimeRec = fromInteger (sum (map tlRate allTags))/1000
112           , totalTimeSel = fromInteger (sum (map tlRate (concat tags)))/1000
113           , fractionRec = realToFrac (totalTimeRec c) / (realToFrac (timeDiff c))
114           , fractionSel = realToFrac (totalTimeSel c) / (realToFrac (timeDiff c))
115           , fractionSelRec = realToFrac (totalTimeSel c) / realToFrac (totalTimeRec c)
116           , sums = sumUp (concat tags)
117           , allTags
118           , tags
119           } in c
120
121 -- | Sums up each occurence of an 'Activity', weighted by the sampling rate
122 sumUp :: TimeLog (Ctx, ActivityData) -> M.Map Activity NominalDiffTime
123 sumUp = foldr go M.empty
124   where go tl m = foldr go' m (snd (tlData tl))
125           where go' act = M.insertWith (+) act (fromInteger (tlRate tl)/1000)
126
127
128 listCategories :: TimeLog (Ctx, ActivityData) -> [Category]
129 listCategories = S.toList . foldr go S.empty
130   where go tl m = foldr go' m (snd (tlData tl))
131           where go' (Activity (Just cat) _) = S.insert cat
132                 go' _                       = id
133
134 putReports :: ReportOptions -> Calculations -> [Report] -> IO ()
135 putReports opts c = sequence_ . intersperse (putStrLn "") . map (putReport opts c) 
136
137 putReport :: ReportOptions -> Calculations -> Report -> IO ()
138 putReport opts c EachCategory = putReports opts c (map Category (listCategories (concat (tags c))))
139 putReport opts c r = renderReport opts $ reportToTable opts c r
140
141 reportToTable :: ReportOptions -> Calculations -> Report -> ReportResults
142 reportToTable opts (Calculations {..}) r = case r of
143         GeneralInfos -> ListOfFields "General Information" $
144                 [ ("FirstRecord", show firstDate)
145                 , ("LastRecord",  show lastDate)
146                 , ("Number of records", show (length allTags))
147                 , ("Total time recorded",  showTimeDiff totalTimeRec)
148                 , ("Total time selected",  showTimeDiff totalTimeSel)
149                 , ("Fraction of total time recorded", printf "%3.0f%%" (fractionRec * 100))
150                 , ("Fraction of total time selected", printf "%3.0f%%" (fractionSel * 100))
151                 , ("Fraction of recorded time selected", printf "%3.0f%%" (fractionSelRec * 100))
152                 ]
153
154         TotalTime -> ListOfTimePercValues "Total time per tag" $
155                 mapMaybe (\(tag,time) ->
156                       let perc = realToFrac time/realToFrac totalTimeSel in
157                       if perc*100 >= roMinPercentage opts
158                       then Just $ ( show tag
159                                   , showTimeDiff time
160                                   , perc)
161                       else Nothing
162                       ) $
163                 reverse $
164                 sortBy (comparing snd) $
165                 M.toList sums
166         
167         Category cat -> PieChartOfTimePercValues ("Statistics for category " ++ show cat) $
168                 let filteredSums = M.filterWithKey (\a _ -> isCategory cat a) sums
169                     uncategorizedTime = totalTimeSel - M.fold (+) 0 filteredSums
170                     tooSmallSums = M.filter (\t -> realToFrac t / realToFrac totalTimeSel * 100 < roMinPercentage opts) filteredSums
171                     tooSmallTimes = M.fold (+) 0 tooSmallSums
172                 in
173
174                 mapMaybe (\(tag,time) ->
175                       let perc = realToFrac time/realToFrac totalTimeSel in
176                       if perc*100 >= roMinPercentage opts
177                       then Just ( show tag
178                                 , showTimeDiff time
179                                 , perc)
180                       else Nothing
181                       )
182                       (reverse $ sortBy (comparing snd) $ M.toList filteredSums)
183                 ++
184                 (
185                 if tooSmallTimes > 0
186                 then [( printf "(%d entries omitted)" (M.size tooSmallSums)
187                       , showTimeDiff tooSmallTimes
188                       , realToFrac tooSmallTimes/realToFrac totalTimeSel
189                       )]
190                 else []
191                 )
192                 ++      
193                 (if uncategorizedTime > 0
194                 then [( "(unmatched time)"
195                       , showTimeDiff uncategorizedTime
196                       , realToFrac uncategorizedTime/realToFrac totalTimeSel
197                       )]
198                 else []
199                 )
200         
201         IntervalCategory cat -> intervalReportToTable ("Intervals for category " ++ show cat)
202                                                       (extractCat cat) 
203         IntervalTag tag -> intervalReportToTable ("Intervals for category " ++ show tag)
204                                                  (extractTag tag) 
205
206     where
207         extractCat :: Category -> ActivityData -> Maybe String
208         extractCat cat = fmap (unpack . activityName) . listToMaybe . filter ( (==Just cat) . activityCategory )
209
210         extractTag :: Activity -> ActivityData -> Maybe String
211         extractTag tag = fmap show . listToMaybe . filter ( (==tag) )
212
213         intervalReportToTable :: String -> (ActivityData -> Maybe String) -> ReportResults
214         intervalReportToTable title extr = ListOfIntervals title $
215             map (\tles ->
216                 let str = fromJust (tlData (head tles))
217                     firstE = showUtcTime (tlTime (head tles))
218                     lastE = showUtcTime (tlTime (last tles))
219                     timeLength = showTimeDiff $
220                         tlTime (last tles) `diffUTCTime` tlTime (head tles) +
221                         fromIntegral (tlRate (last tles))/1000
222                 in (str, firstE, lastE, timeLength)) $
223             filter (isJust . tlData . head ) $
224             concat $
225             fmap (groupBy ((==) `on` tlData) .
226                  (fmap.fmap) (extr . snd)) $
227             tags
228             
229             
230
231 renderReport opts reportdata = do
232     let results = doRender opts reportdata
233     putStr results
234
235 doRender opts reportdata = case roReportFormat opts of
236                 RFText -> renderReportText reportdata
237                 RFCSV -> renderReportCSV reportdata
238                 RFTSV -> renderReportTSV reportdata
239
240 renderReportText (ListOfFields title dats) = 
241     underline title ++
242     (tabulate False $ map (\(f,v) -> [f,v]) dats)
243
244 renderReportText (ListOfTimePercValues title dats) = 
245     underline title ++ (tabulate True $ listOfValues dats)
246
247 renderReportText (PieChartOfTimePercValues title dats) = 
248     underline title ++ (tabulate True $ piechartOfValues dats)
249
250 renderReportText (ListOfIntervals title dats) = 
251     underline title ++ (tabulate True $ listOfIntervals dats)
252
253 listOfValues dats =
254     ["Tag","Time","Percentage"] :
255     map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats
256
257 piechartOfValues dats =
258     ["Tag","Time","Percentage"] :
259     map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats
260
261 listOfIntervals dats =
262     ["Tag","From","Until","Duration"] :
263     map (\(t,f,u,d) -> [t,f,u,d]) dats
264
265 -- The reporting of "General Information" is not supported for the
266 -- comma-separated output format.
267 renderReportCSV (ListOfFields title dats) = 
268     error ("\"" ++ title ++ "\"" ++ " not supported for comma-separated output format")
269
270 renderReportCSV (ListOfTimePercValues _ dats) = 
271     renderWithDelimiter "," (listOfValues dats)
272
273 renderReportCSV (PieChartOfTimePercValues _ dats) = 
274     renderWithDelimiter "," (piechartOfValues dats)
275
276 renderReportCSV (ListOfIntervals title dats) = 
277     renderWithDelimiter "," (listOfIntervals dats)
278
279 -- The reporting of "General Information" is not supported for the
280 -- TAB-separated output format.
281 renderReportTSV (ListOfFields title dats) = 
282     error ("\"" ++ title ++ "\"" ++ " not supported for TAB-separated output format")
283
284 renderReportTSV (ListOfTimePercValues _ dats) = 
285     renderWithDelimiter "\t" (listOfValues dats)
286
287 renderReportTSV (PieChartOfTimePercValues _ dats) = 
288     renderWithDelimiter "\t" (piechartOfValues dats)
289
290 renderReportTSV (ListOfIntervals title dats) = 
291     renderWithDelimiter "\t" (listOfIntervals dats)
292
293 renderWithDelimiter delim datasource =
294     unlines $ map (injectDelimiter delim) datasource
295
296 injectDelimiter d = concat . intersperse d
297
298 tabulate :: Bool -> [[String]] -> String
299 tabulate titlerow rows = unlines $ addTitleRow $ map (intercalate " | " . zipWith (\l s -> take (l - length s) (repeat ' ') ++ s) colwidths) rows
300   where cols = transpose rows
301         colwidths = map (maximum . map length) cols
302         addTitleRow | titlerow  = \(l:ls) -> (map (\c -> if c == ' ' then '_' else c) l ++ "_")
303                                              : ls
304                  -- | titlerow  = \(l:ls) -> l : (take (length l) (repeat '-')) : ls
305                     | otherwise = id
306
307 showTimeDiff :: NominalDiffTime -> String
308 showTimeDiff t = go False $ zip [days,hours,mins,secs] ["d","h","m","s"]
309   where s = round t :: Integer
310         days  =  s `div` (24*60*60)
311         hours = (s `div` (60*60)) `mod` 24
312         mins  = (s `div` 60) `mod` 60
313         secs  =  s `mod` 60 
314         go False []         = "0s"
315         go True  []         = ""
316 --      go True  vs         | all (==0) (map fst vs) = concat (replicate (length vs) "   ")
317         go True  ((a,u):vs)             = printf "%02d%s" a u ++ go True vs
318         go False ((a,u):vs) | a > 0     = printf "%2d%s" a u ++ go True vs
319                             | otherwise =                       go False vs
320
321 showUtcTime :: UTCTime -> String
322 showUtcTime = formatTime defaultTimeLocale "%x %X"
323
324 underline str = unlines 
325     [ str
326     , map (const '=') str
327     ]