hledger-range-voting.hs

   1 #!/usr/bin/env runhaskell
   2 {-|
   3 hledger-range-voting [-f JOURNALFILE]
   4
   5 Perform range voting calculus
   6 on the default or specified journal.
   7 |-}
   8
   9 import Data.List
  10 --import Data.List (mapAccumL)
  11 import Data.Maybe
  12 import Data.Ord
  13 import Data.Time.Calendar
  14 import System.Console.CmdArgs.Explicit
  15 import Text.Printf
  16 import qualified Data.Map as Map
  17
  18 import Hledger
  19 import Hledger.Cli
  20 import Hledger.Cli.Options
  21 -- import Prelude hiding (putStr)
  22 import Hledger.Utils.UTF8IOCompat (putStr)
  23
  24
  25 argsmode :: Mode RawOpts
  26 argsmode = (defCommandMode ["range-voting"])
  27         { modeHelp = "perform range voting"
  28         , modeGroupFlags = Group
  29                 { groupNamed =
  30                         [ ("Input",inputflags)
  31                         , ("Reporting",reportflags)
  32                         , ("Misc",helpflags)
  33                         ]
  34                 , groupUnnamed = []
  35                 , groupHidden = []
  36                 }
  37         }
  38
  39
  40 -- like Register.summarisePostings
  41 -- | Print various statistics for the journal.
  42 main :: IO ()
  43 main = do
  44         opts <- getCliOpts argsmode
  45         withJournalDo opts $
  46          \CliOpts{reportopts_=reportopts_} j -> do
  47                 d <- getCurrentDay
  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
  53                 putStr s
  54
  55 data Stats =
  56         Stats
  57          { stats_choice      :: String
  58          , stats_sum         :: Double
  59          , stats_blank_count :: Int
  60          , stats_null_count  :: Int
  61          , stats_null_value  :: Double
  62          , stats_values      :: [(Int,Int)]
  63          }
  64 stats :: Stats
  65 stats = Stats
  66  { stats_choice      = ""
  67  , stats_sum         = 0.0
  68  , stats_blank_count = 0
  69  , stats_null_count  = 0
  70  , stats_null_value  = 0.0
  71  , stats_values      = []
  72  }
  73
  74
  75 showRangeVoting :: ReportOpts -> Ledger -> Day -> DateSpan -> String
  76 showRangeVoting ropts l today span =
  77         unlines $ map (\(label,value) -> concatBottomPadded [printf fmt1 label, value]) main
  78          where
  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
  83                 main =
  84                  concat $
  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)
  92                          ,("Medians", "")
  93                          ]
  94                  , map (\t ->
  95                         ( printf "  - %s" (stats_choice t)
  96                         , printf "sum: %+.f" (stats_sum t)
  97                         ) ) medians
  98                  , [("Choices", printf "%d" nchoices)
  99                          ]
 100                  , map
 101                          (\t ->
 102                                 ( printf "  - %s" (stats_choice t)
 103                                 , printf "sum: %+f = %d*(0:blank) + %d*(%+.2f:null) + %s"
 104                                          (stats_sum t)
 105                                          (stats_blank_count t)
 106                                          (stats_null_count t)
 107                                          (stats_null_value t)
 108                                          (intercalate " + " $ map (\(value,sum) -> printf "%d*(%+d)" sum value) (stats_values t))
 109                                 )
 110                          ) stats
 111                  --,("Commodities", printf "%s (%s)" (show $ length cs) (intercalate ", " cs))
 112                  ]
 113                  where
 114                         j = ljournal l
 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
 124                         start _ = ""
 125                         end (DateSpan _ (Just d)) = show d
 126                         end _ = ""
 127                         days = fromMaybe 0 $ daysInSpan span
 128                         votedays = fromMaybe 0 $ daysInSpan
 129                          (DateSpan
 130                                  (Just (tdate opening))
 131                                  (maybe Nothing Just (tdate2 opening)))
 132                         acctnum = length as
 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]
 141                         choices =
 142                                 map paccount $
 143                                 filter (isPrefixOf "Choice:" . paccount) $
 144                                 tpostings opening
 145
 146                         votes = filter ((== "Vote") . tdescription) $ ts
 147                         stats =
 148                                 sortBy (\a b -> (stats_sum b) `compare` (stats_sum a)) $
 149                                 map (\s ->
 150                                         let mean = fromIntegral (foldl (\acc (v,c) -> acc + (v * c)) 0 (stats_values s)) / fromIntegral (length (stats_values s)) in
 151                                         s
 152                                          { stats_null_value = mean
 153                                          , stats_sum        = (stats_sum s) + (mean * fromIntegral (stats_null_count s))
 154                                          }) $
 155                                 foldl (\s vote ->
 156                                         map (\s ->
 157                                                 case filter ((== stats_choice s) . paccount) (tpostings vote) of
 158                                                  [] -> s { stats_blank_count = stats_blank_count s + 1 }
 159                                                  [choice_posting] ->
 160                                                         case pamount choice_posting of
 161                                                          Mixed [Amount{acommodity="", aquantity=q, aprice=NoPrice}] ->
 162                                                                 let i = floor q in
 163                                                                 if snd (properFraction q) == 0.0 && i `elem` values
 164                                                                 then s
 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)
 167                                                                          }
 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 }
 171                                          )
 172                                          s
 173                                  )
 174                                  [ Stats
 175                                         { stats_choice      = choice
 176                                         , stats_sum         = 0.0
 177                                         , stats_blank_count = 0
 178                                         , stats_null_count  = 0
 179                                         , stats_null_value  = 0.0
 180                                         , stats_values      = [(value,0) | value<-values]
 181                                         }
 182                                  | choice<-choices ]
 183                                  votes
 184
 185                         medians =
 186                                 filter (\c -> stats_sum c `elem` medians) stats
 187                                  where medians =
 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]
 191
 192                         nchoices = length choices
 193
 194                         -- choicesbalancesropts = ropts{query_="Choice:"}
 195                         -- choicesbalances = tail $ fst $ balanceReport ropts (queryFromOpts today choicesbalancesropts) j
 196
 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