#!/usr/bin/env runhaskell {-| hledger-range-voting [-f JOURNALFILE] Perform range voting calculus on the default or specified journal. |-} import Data.List --import Data.List (mapAccumL) import Data.Maybe import Data.Ord import Data.Time.Calendar import System.Console.CmdArgs.Explicit import Text.Printf import qualified Data.Map as Map import Hledger import Hledger.Cli import Hledger.Cli.Options -- import Prelude hiding (putStr) import Hledger.Utils.UTF8IOCompat (putStr) argsmode :: Mode RawOpts argsmode = (defCommandMode ["range-voting"]) { modeHelp = "perform range voting" , modeGroupFlags = Group { groupNamed = [ ("Input",inputflags) , ("Reporting",reportflags) , ("Misc",helpflags) ] , groupUnnamed = [] , groupHidden = [] } } -- like Register.summarisePostings -- | Print various statistics for the journal. main :: IO () main = do opts <- getCliOpts argsmode withJournalDo opts $ \CliOpts{reportopts_=reportopts_} j -> do d <- getCurrentDay let q = queryFromOpts d reportopts_ let l = ledgerFromJournal q j let reportspan = (ledgerDateSpan l) `spanDefaultsFrom` (queryDateSpan False q) let intervalspans = splitSpan (intervalFromOpts reportopts_) reportspan let s = intercalate "\n" $ map (showRangeVoting reportopts_{empty_=True} l d) intervalspans putStr s data Stats = Stats { stats_choice :: String , stats_sum :: Double , stats_blank_count :: Int , stats_null_count :: Int , stats_null_value :: Double , stats_values :: [(Int,Int)] } stats :: Stats stats = Stats { stats_choice = "" , stats_sum = 0.0 , stats_blank_count = 0 , stats_null_count = 0 , stats_null_value = 0.0 , stats_values = [] } showRangeVoting :: ReportOpts -> Ledger -> Day -> DateSpan -> String showRangeVoting ropts l today span = unlines $ map (\(label,value) -> concatBottomPadded [printf fmt1 label, value]) main where fmt1 = "%-" ++ show w1 ++ "s: " -- fmt2 = "%-" ++ show w2 ++ "s" w1 = maximum $ map (length . fst) main -- w2 = maximum $ map (length . show . snd) main main = concat $ [ [("Span vote (official)", printf "%s to %s (%d days)" (show $ (tdate opening)) (show $ (tdate2 opening)) votedays) ,("Span vote (actual)", printf "%s to %s (%d days)" (start span) (end span) days) ,("Cardinal", printf "%d" cardinal) ,("Values", "{"++(intercalate "," $ map (printf "%d") values)++"}") ,("Quorum", printf "%d/%d (%f%%)" votesnum votersnum (fromIntegral votesnum*100.0/fromIntegral votersnum::Double)) ,("Blanks", printf "%d" $ foldl (\acc t -> acc + stats_blank_count t) 0 stats) ,("Nulls", printf "%d" $ foldl (\acc t -> acc + stats_null_count t) 0 stats) ,("Medians", "") ] , map (\t -> ( printf " - %s" (stats_choice t) , printf "sum: %+.f" (stats_sum t) ) ) medians , [("Choices", printf "%d" nchoices) ] , map (\t -> ( printf " - %s" (stats_choice t) , printf "sum: %+f = %d*(0:blank) + %d*(%+.2f:null) + %s" (stats_sum t) (stats_blank_count t) (stats_null_count t) (stats_null_value t) (intercalate " + " $ map (\(value,sum) -> printf "%d*(%+d)" sum value) (stats_values t)) ) ) stats --,("Commodities", printf "%s (%s)" (show $ length cs) (intercalate ", " cs)) ] where j = ljournal l ts = sortBy (comparing tdate) $ filter (spanContainsDate span . tdate) $ jtxns j as = nub $ map paccount $ concatMap tpostings ts cs = Map.keys $ canonicalStyles $ concatMap amounts $ map pamount $ concatMap tpostings ts showelapsed Nothing = "" showelapsed (Just days) = printf " (%d %s)" days' direction where days' = abs days direction | days >= 0 = "days ago" :: String | otherwise = "days from now" start (DateSpan (Just d) _) = show d start _ = "" end (DateSpan _ (Just d)) = show d end _ = "" days = fromMaybe 0 $ daysInSpan span votedays = fromMaybe 0 $ daysInSpan (DateSpan (Just (tdate opening)) (maybe Nothing Just (tdate2 opening))) acctnum = length as openings = filter ((== "Opening") . tdescription) $ ts opening | null openings = error' "\"Opening\" transaction is missing" | otherwise = head $ openings cardinals = filter ((== "Cardinal") . fst) $ ttags opening cardinal | null cardinals = error' "\"Cardinal\" tag is missing on \"Opening\" transaction" | otherwise = read $ snd $ head $ cardinals :: Int values | (cardinal `mod` 2 == 0) = delete 0 [-cardinal`div`2..cardinal`div`2] | otherwise = [-(cardinal-1)`div`2..(cardinal-1)`div`2] choices = map paccount $ filter (isPrefixOf "Choice:" . paccount) $ tpostings opening votes = filter ((== "Vote") . tdescription) $ ts stats = sortBy (\a b -> (stats_sum b) `compare` (stats_sum a)) $ map (\s -> let mean = fromIntegral (foldl (\acc (v,c) -> acc + (v * c)) 0 (stats_values s)) / fromIntegral (length (stats_values s)) in s { stats_null_value = mean , stats_sum = (stats_sum s) + (mean * fromIntegral (stats_null_count s)) }) $ foldl (\s vote -> map (\s -> case filter ((== stats_choice s) . paccount) (tpostings vote) of [] -> s { stats_blank_count = stats_blank_count s + 1 } [choice_posting] -> case pamount choice_posting of Mixed [Amount{acommodity="", aquantity=q, aprice=NoPrice}] -> let i = floor q in if snd (properFraction q) == 0.0 && i `elem` values then s { stats_sum = stats_sum s + fromIntegral i , stats_values = map (\(v,c) -> if v == i then (v,c+1) else (v,c)) (stats_values s) } else s { stats_null_count = stats_null_count s + 1 } -- error' $ printf "TODO: null vote: invalid value: %f" q _ -> s { stats_null_count = stats_null_count s + 1 } -- error' "TODO: null vote: too much informations" _ -> s { stats_null_count = stats_null_count s + 1 } ) s ) [ Stats { stats_choice = choice , stats_sum = 0.0 , stats_blank_count = 0 , stats_null_count = 0 , stats_null_value = 0.0 , stats_values = [(value,0) | value<-values] } | choice<-choices ] votes medians = filter (\c -> stats_sum c `elem` medians) stats where medians = if length choices `mod` 2 == 0 then map (stats_sum . (!!) stats) [nchoices `div` 2 - 1, nchoices `div` 2 + 1] else map (stats_sum . (!!) stats) [(nchoices - 1) `div` 2] nchoices = length choices -- choicesbalancesropts = ropts{query_="Choice:"} -- choicesbalances = tail $ fst $ balanceReport ropts (queryFromOpts today choicesbalancesropts) j voteras = filter (isPrefixOf "Voter:" . paccount) $ tpostings opening votests = filter ((== "Vote") . tdescription) $ ts votesnum = length votests votersnum = length voteras votechoicesps = filter (isPrefixOf "Choice:" . paccount) $ tpostings opening