arbtt-0.6: src/Stats.hs
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
module Stats where
import Data.Time
import Data.Maybe
import Data.List
import Data.Ord
import Text.Printf
import qualified Data.Map as M
import qualified Data.Set as S
import Data.MyText (Text,pack,unpack)
import Data.Function (on)
import System.Locale (defaultTimeLocale)
import Data
import Categorize
data Report = GeneralInfos
| TotalTime
| Category Category
| EachCategory
| IntervalCategory Category
| IntervalTag Activity
deriving (Show, Eq)
data Filter = Exclude ActivityMatcher | Only ActivityMatcher | GeneralCond String
deriving (Show, Eq)
data ActivityMatcher = MatchActivity Activity | MatchCategory Category
deriving (Show, Eq)
data ActivityFilter = ExcludeActivity ActivityMatcher | OnlyActivity ActivityMatcher
deriving (Show, Eq)
-- Supported report output formats: text, comma-separated values and
-- tab-separated values
data ReportFormat = RFText | RFCSV | RFTSV
deriving (Show, Eq)
data ReportOptions = ReportOptions
{ roMinPercentage :: Double
, roReportFormat :: ReportFormat
, roActivityFilter :: [ActivityFilter]
}
deriving (Show, Eq)
defaultReportOptions = ReportOptions
{ roMinPercentage = 1
, roReportFormat = RFText
, roActivityFilter = []
}
-- Data format semantically representing the result of a report, including the
-- title
data ReportResults =
ListOfFields String [(String, String)]
| ListOfTimePercValues String [(String, String, Double)]
| PieChartOfTimePercValues String [(String, String, Double)]
| ListOfIntervals String [(String,String,String,String)]
-- We apply the filters in a way such that consecutive runs of selected samples
-- are in the same sublist, and sublists are separated by non-selected samples
applyFilters :: [Filter] -> TimeLog (Ctx, ActivityData) -> [TimeLog (Ctx, ActivityData)]
applyFilters filters = filterAndSeparate $ \tl ->
all (\flag -> case flag of
Exclude act -> excludeTag act tl
Only act -> onlyTag act tl
GeneralCond s-> applyCond s tl) filters
applyActivityFilter :: [ActivityFilter] -> Activity -> Bool
applyActivityFilter fs act = all go fs
where go (ExcludeActivity matcher) = not (matchActivityMatcher matcher act)
go (OnlyActivity matcher) = matchActivityMatcher matcher act
filterAndSeparate :: (a -> Bool) -> [a] -> [[a]]
filterAndSeparate pred = fst . go
where go [] = ([],True)
go (x:xs) = case (go xs,pred x) of
((rs, True) , True) -> ([x]:rs, False)
(((r:rs), False), True) -> ((x:r):rs, False)
((rs, _) , False) -> (rs, True)
excludeTag matcher = not . any (matchActivityMatcher matcher) . snd . tlData
onlyTag matcher = any (matchActivityMatcher matcher) . snd . tlData
defaultFilter = Exclude (MatchActivity inactiveActivity)
matchActivityMatcher :: ActivityMatcher -> Activity -> Bool
matchActivityMatcher (MatchActivity act1) act2 = act1 == act2
matchActivityMatcher (MatchCategory cat) act2 = Just cat == activityCategory act2
parseActivityMatcher :: String -> ActivityMatcher
parseActivityMatcher str | last str == ':' = MatchCategory (pack (init str))
| otherwise = MatchActivity (read str)
-- | to be used lazily, to re-use computation when generating more than one
-- report at a time
data Calculations = Calculations
{ firstDate :: UTCTime
, lastDate :: UTCTime
, timeDiff :: NominalDiffTime
, totalTimeRec :: NominalDiffTime
, totalTimeSel :: NominalDiffTime
, fractionRec :: Double
, fractionSel :: Double
, fractionSelRec :: Double
, sums :: M.Map Activity NominalDiffTime
, allTags :: TimeLog (Ctx, ActivityData)
-- tags is a list of uninterrupted entries
, tags :: [TimeLog (Ctx, ActivityData)]
}
prepareCalculations :: TimeLog (Ctx, ActivityData) -> [TimeLog (Ctx, ActivityData)] -> Calculations
prepareCalculations allTags tags =
let c = Calculations
{ firstDate = tlTime (head allTags)
, lastDate = tlTime (last allTags)
, timeDiff = diffUTCTime (lastDate c) (firstDate c)
, totalTimeRec = fromInteger (sum (map tlRate allTags))/1000
, totalTimeSel = fromInteger (sum (map tlRate (concat tags)))/1000
, fractionRec = realToFrac (totalTimeRec c) / (realToFrac (timeDiff c))
, fractionSel = realToFrac (totalTimeSel c) / (realToFrac (timeDiff c))
, fractionSelRec = realToFrac (totalTimeSel c) / realToFrac (totalTimeRec c)
, sums = sumUp (concat tags)
, allTags
, tags
} in c
-- | Sums up each occurence of an 'Activity', weighted by the sampling rate
sumUp :: TimeLog (Ctx, ActivityData) -> M.Map Activity NominalDiffTime
sumUp = foldr go M.empty
where go tl m = foldr go' m (snd (tlData tl))
where go' act = M.insertWith (+) act (fromInteger (tlRate tl)/1000)
listCategories :: TimeLog (Ctx, ActivityData) -> [Category]
listCategories = S.toList . foldr go S.empty
where go tl m = foldr go' m (snd (tlData tl))
where go' (Activity (Just cat) _) = S.insert cat
go' _ = id
putReports :: ReportOptions -> Calculations -> [Report] -> IO ()
putReports opts c = sequence_ . intersperse (putStrLn "") . map (putReport opts c)
putReport :: ReportOptions -> Calculations -> Report -> IO ()
putReport opts c EachCategory = putReports opts c (map Category (listCategories (concat (tags c))))
putReport opts c r = renderReport opts $ reportToTable opts c r
reportToTable :: ReportOptions -> Calculations -> Report -> ReportResults
reportToTable opts (Calculations {..}) r = case r of
GeneralInfos -> ListOfFields "General Information" $
[ ("FirstRecord", show firstDate)
, ("LastRecord", show lastDate)
, ("Number of records", show (length allTags))
, ("Total time recorded", showTimeDiff totalTimeRec)
, ("Total time selected", showTimeDiff totalTimeSel)
, ("Fraction of total time recorded", printf "%3.0f%%" (fractionRec * 100))
, ("Fraction of total time selected", printf "%3.0f%%" (fractionSel * 100))
, ("Fraction of recorded time selected", printf "%3.0f%%" (fractionSelRec * 100))
]
TotalTime -> ListOfTimePercValues "Total time per tag" $
mapMaybe (\(tag,time) ->
let perc = realToFrac time/realToFrac totalTimeSel
pick = applyActivityFilter (roActivityFilter opts) tag
in if pick && perc*100 >= roMinPercentage opts
then Just $ ( show tag
, showTimeDiff time
, perc)
else Nothing
) $
reverse $
sortBy (comparing snd) $
M.toList sums
Category cat -> PieChartOfTimePercValues ("Statistics for category " ++ show cat) $
let filteredSums = M.filterWithKey (\a _ -> isCategory cat a) sums
uncategorizedTime = totalTimeSel - M.fold (+) 0 filteredSums
tooSmallSums = M.filter (\t -> realToFrac t / realToFrac totalTimeSel * 100 < roMinPercentage opts) filteredSums
tooSmallTimes = M.fold (+) 0 tooSmallSums
in
mapMaybe (\(tag,time) ->
let perc = realToFrac time/realToFrac totalTimeSel
pick = applyActivityFilter (roActivityFilter opts) tag
in if pick && perc*100 >= roMinPercentage opts
then Just ( show tag
, showTimeDiff time
, perc)
else Nothing
)
(reverse $ sortBy (comparing snd) $ M.toList filteredSums)
++
(
if tooSmallTimes > 0
then [( printf "(%d entries omitted)" (M.size tooSmallSums)
, showTimeDiff tooSmallTimes
, realToFrac tooSmallTimes/realToFrac totalTimeSel
)]
else []
)
++
(if uncategorizedTime > 0
then [( "(unmatched time)"
, showTimeDiff uncategorizedTime
, realToFrac uncategorizedTime/realToFrac totalTimeSel
)]
else []
)
IntervalCategory cat -> intervalReportToTable ("Intervals for category " ++ show cat)
(extractCat cat)
IntervalTag tag -> intervalReportToTable ("Intervals for category " ++ show tag)
(extractTag tag)
where
extractCat :: Category -> ActivityData -> Maybe String
extractCat cat = fmap (unpack . activityName) . listToMaybe . filter ( (==Just cat) . activityCategory )
extractTag :: Activity -> ActivityData -> Maybe String
extractTag tag = fmap show . listToMaybe . filter ( (==tag) )
intervalReportToTable :: String -> (ActivityData -> Maybe String) -> ReportResults
intervalReportToTable title extr = ListOfIntervals title $
map (\tles ->
let str = fromJust (tlData (head tles))
firstE = showUtcTime (tlTime (head tles))
lastE = showUtcTime (tlTime (last tles))
timeLength = showTimeDiff $
tlTime (last tles) `diffUTCTime` tlTime (head tles) +
fromIntegral (tlRate (last tles))/1000
in (str, firstE, lastE, timeLength)) $
filter (isJust . tlData . head ) $
concat $
fmap (groupBy ((==) `on` tlData) .
(fmap.fmap) (extr . snd)) $
tags
renderReport opts reportdata = do
let results = doRender opts reportdata
putStr results
doRender opts reportdata = case roReportFormat opts of
RFText -> renderReportText reportdata
RFCSV -> renderReportCSV reportdata
RFTSV -> renderReportTSV reportdata
renderReportText (ListOfFields title dats) =
underline title ++
(tabulate False $ map (\(f,v) -> [f,v]) dats)
renderReportText (ListOfTimePercValues title dats) =
underline title ++ (tabulate True $ listOfValues dats)
renderReportText (PieChartOfTimePercValues title dats) =
underline title ++ (tabulate True $ piechartOfValues dats)
renderReportText (ListOfIntervals title dats) =
underline title ++ (tabulate True $ listOfIntervals dats)
listOfValues dats =
["Tag","Time","Percentage"] :
map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats
piechartOfValues dats =
["Tag","Time","Percentage"] :
map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats
listOfIntervals dats =
["Tag","From","Until","Duration"] :
map (\(t,f,u,d) -> [t,f,u,d]) dats
-- The reporting of "General Information" is not supported for the
-- comma-separated output format.
renderReportCSV (ListOfFields title dats) =
error ("\"" ++ title ++ "\"" ++ " not supported for comma-separated output format")
renderReportCSV (ListOfTimePercValues _ dats) =
renderWithDelimiter "," (listOfValues dats)
renderReportCSV (PieChartOfTimePercValues _ dats) =
renderWithDelimiter "," (piechartOfValues dats)
renderReportCSV (ListOfIntervals title dats) =
renderWithDelimiter "," (listOfIntervals dats)
-- The reporting of "General Information" is not supported for the
-- TAB-separated output format.
renderReportTSV (ListOfFields title dats) =
error ("\"" ++ title ++ "\"" ++ " not supported for TAB-separated output format")
renderReportTSV (ListOfTimePercValues _ dats) =
renderWithDelimiter "\t" (listOfValues dats)
renderReportTSV (PieChartOfTimePercValues _ dats) =
renderWithDelimiter "\t" (piechartOfValues dats)
renderReportTSV (ListOfIntervals title dats) =
renderWithDelimiter "\t" (listOfIntervals dats)
renderWithDelimiter delim datasource =
unlines $ map (injectDelimiter delim) datasource
injectDelimiter d = concat . intersperse d
tabulate :: Bool -> [[String]] -> String
tabulate titlerow rows = unlines $ addTitleRow $ map (intercalate " | " . zipWith (\l s -> take (l - length s) (repeat ' ') ++ s) colwidths) rows
where cols = transpose rows
colwidths = map (maximum . map length) cols
addTitleRow | titlerow = \(l:ls) -> (map (\c -> if c == ' ' then '_' else c) l ++ "_")
: ls
-- | titlerow = \(l:ls) -> l : (take (length l) (repeat '-')) : ls
| otherwise = id
showTimeDiff :: NominalDiffTime -> String
showTimeDiff t = go False $ zip [days,hours,mins,secs] ["d","h","m","s"]
where s = round t :: Integer
days = s `div` (24*60*60)
hours = (s `div` (60*60)) `mod` 24
mins = (s `div` 60) `mod` 60
secs = s `mod` 60
go False [] = "0s"
go True [] = ""
-- go True vs | all (==0) (map fst vs) = concat (replicate (length vs) " ")
go True ((a,u):vs) = printf "%02d%s" a u ++ go True vs
go False ((a,u):vs) | a > 0 = printf "%2d%s" a u ++ go True vs
| otherwise = go False vs
showUtcTime :: UTCTime -> String
showUtcTime = formatTime defaultTimeLocale "%x %X"
underline str = unlines
[ str
, map (const '=') str
]