1 #!/usr/bin/env runhaskell
3 hledger-range-voting [-f JOURNALFILE]
5 Perform range voting calculus
6 on the default or specified journal.
10 --import Data.List (mapAccumL)
13 import Data.Time.Calendar
14 import System.Console.CmdArgs.Explicit
16 import qualified Data.Map as Map
20 import Hledger.Cli.Options
21 -- import Prelude hiding (putStr)
22 import Hledger.Utils.UTF8IOCompat (putStr)
25 argsmode :: Mode RawOpts
26 argsmode = (defCommandMode ["range-voting"])
27 { modeHelp = "perform range voting"
28 , modeGroupFlags = Group
30 [ ("Input",inputflags)
31 , ("Reporting",reportflags)
40 -- like Register.summarisePostings
41 -- | Print various statistics for the journal.
44 opts <- getCliOpts argsmode
46 \CliOpts{reportopts_=reportopts_} j -> do
48 let q = queryFromOpts d reportopts_
49 let l = ledgerFromJournal q j
50 let reportspan = (ledgerDateSpan l) `spanDefaultsFrom` (queryDateSpan False q)
51 let intervalspans = splitSpan (intervalFromOpts reportopts_) reportspan
52 let s = intercalate "\n" $ map (showRangeVoting reportopts_{empty_=True} l d) intervalspans
57 { stats_choice :: String
59 , stats_blank_count :: Int
60 , stats_null_count :: Int
61 , stats_null_value :: Double
62 , stats_values :: [(Int,Int)]
68 , stats_blank_count = 0
69 , stats_null_count = 0
70 , stats_null_value = 0.0
75 showRangeVoting :: ReportOpts -> Ledger -> Day -> DateSpan -> String
76 showRangeVoting ropts l today span =
77 unlines $ map (\(label,value) -> concatBottomPadded [printf fmt1 label, value]) main
79 fmt1 = "%-" ++ show w1 ++ "s: "
80 -- fmt2 = "%-" ++ show w2 ++ "s"
81 w1 = maximum $ map (length . fst) main
82 -- w2 = maximum $ map (length . show . snd) main
85 [ [("Span vote (official)", printf "%s to %s (%d days)" (show $ (tdate opening)) (show $ (tdate2 opening)) votedays)
86 ,("Span vote (actual)", printf "%s to %s (%d days)" (start span) (end span) days)
87 ,("Cardinal", printf "%d" cardinal)
88 ,("Values", "{"++(intercalate "," $ map (printf "%d") values)++"}")
89 ,("Quorum", printf "%d/%d (%f%%)" votesnum votersnum (fromIntegral votesnum*100.0/fromIntegral votersnum::Double))
90 ,("Blanks", printf "%d" $ foldl (\acc t -> acc + stats_blank_count t) 0 stats)
91 ,("Nulls", printf "%d" $ foldl (\acc t -> acc + stats_null_count t) 0 stats)
95 ( printf " - %s" (stats_choice t)
96 , printf "sum: %+.f" (stats_sum t)
98 , [("Choices", printf "%d" nchoices)
102 ( printf " - %s" (stats_choice t)
103 , printf "sum: %+f = %d*(0:blank) + %d*(%+.2f:null) + %s"
105 (stats_blank_count t)
108 (intercalate " + " $ map (\(value,sum) -> printf "%d*(%+d)" sum value) (stats_values t))
111 --,("Commodities", printf "%s (%s)" (show $ length cs) (intercalate ", " cs))
115 ts = sortBy (comparing tdate) $ filter (spanContainsDate span . tdate) $ jtxns j
116 as = nub $ map paccount $ concatMap tpostings ts
117 cs = Map.keys $ canonicalStyles $ concatMap amounts $ map pamount $ concatMap tpostings ts
118 showelapsed Nothing = ""
119 showelapsed (Just days) = printf " (%d %s)" days' direction
120 where days' = abs days
121 direction | days >= 0 = "days ago" :: String
122 | otherwise = "days from now"
123 start (DateSpan (Just d) _) = show d
125 end (DateSpan _ (Just d)) = show d
127 days = fromMaybe 0 $ daysInSpan span
128 votedays = fromMaybe 0 $ daysInSpan
130 (Just (tdate opening))
131 (maybe Nothing Just (tdate2 opening)))
133 openings = filter ((== "Opening") . tdescription) $ ts
134 opening | null openings = error' "\"Opening\" transaction is missing"
135 | otherwise = head $ openings
136 cardinals = filter ((== "Cardinal") . fst) $ ttags opening
137 cardinal | null cardinals = error' "\"Cardinal\" tag is missing on \"Opening\" transaction"
138 | otherwise = read $ snd $ head $ cardinals :: Int
139 values | (cardinal `mod` 2 == 0) = delete 0 [-cardinal`div`2..cardinal`div`2]
140 | otherwise = [-(cardinal-1)`div`2..(cardinal-1)`div`2]
143 filter (isPrefixOf "Choice:" . paccount) $
146 votes = filter ((== "Vote") . tdescription) $ ts
148 sortBy (\a b -> (stats_sum b) `compare` (stats_sum a)) $
150 let mean = fromIntegral (foldl (\acc (v,c) -> acc + (v * c)) 0 (stats_values s)) / fromIntegral (length (stats_values s)) in
152 { stats_null_value = mean
153 , stats_sum = (stats_sum s) + (mean * fromIntegral (stats_null_count s))
157 case filter ((== stats_choice s) . paccount) (tpostings vote) of
158 [] -> s { stats_blank_count = stats_blank_count s + 1 }
160 case pamount choice_posting of
161 Mixed [Amount{acommodity="", aquantity=q, aprice=NoPrice}] ->
163 if snd (properFraction q) == 0.0 && i `elem` values
165 { stats_sum = stats_sum s + fromIntegral i
166 , stats_values = map (\(v,c) -> if v == i then (v,c+1) else (v,c)) (stats_values s)
168 else s { stats_null_count = stats_null_count s + 1 } -- error' $ printf "TODO: null vote: invalid value: %f" q
169 _ -> s { stats_null_count = stats_null_count s + 1 } -- error' "TODO: null vote: too much informations"
170 _ -> s { stats_null_count = stats_null_count s + 1 }
175 { stats_choice = choice
177 , stats_blank_count = 0
178 , stats_null_count = 0
179 , stats_null_value = 0.0
180 , stats_values = [(value,0) | value<-values]
186 filter (\c -> stats_sum c `elem` medians) stats
188 if length choices `mod` 2 == 0
189 then map (stats_sum . (!!) stats) [nchoices `div` 2 - 1, nchoices `div` 2 + 1]
190 else map (stats_sum . (!!) stats) [(nchoices - 1) `div` 2]
192 nchoices = length choices
194 -- choicesbalancesropts = ropts{query_="Choice:"}
195 -- choicesbalances = tail $ fst $ balanceReport ropts (queryFromOpts today choicesbalancesropts) j
197 voteras = filter (isPrefixOf "Voter:" . paccount) $ tpostings opening
198 votests = filter ((== "Vote") . tdescription) $ ts
199 votesnum = length votests
200 votersnum = length voteras
201 votechoicesps = filter (isPrefixOf "Choice:" . paccount) $ tpostings opening