X-Git-Url: http://git.cyclocoop.org/?p=tool%2Fhledger.git;a=blobdiff_plain;f=script%2Fhledger-range-voting.hs;fp=script%2Fhledger-range-voting.hs;h=2bcc33001647a9e01843abf24f303c907ab56ed2;hp=0000000000000000000000000000000000000000;hb=707b0a621cd3c97d5d7e22e855272b3f865a2d56;hpb=30e9b83c521f5149836e1ef0b544676370721efe

diff --git a/script/hledger-range-voting.hs b/script/hledger-range-voting.hs
new file mode 100755
index 0000000..2bcc330
--- /dev/null
+++ b/script/hledger-range-voting.hs
@@ -0,0 +1,201 @@
+#!/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