+++ /dev/null
-#!/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
dépôts / tool / hledger.git / blobdiff