--- /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