hjugement/Majority/Section.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 -- | This module implements the composition of a Majority Judgment
   3 -- from a tree of Majority Judgments: for the same question,
   4 -- the same choices, the same judges and the same grades.
   5 -- In that tree, a parent judgment is formed by the aggregation of its children judgments,
   6 -- where a child judgment contributes only for a percentage of the parent judgment.
   7 module Majority.Section where
   8
   9 import Control.Applicative (Applicative(..), Alternative(..))
  10 import Data.Bool
  11 import Data.Either (Either(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Foldable (Foldable(..), any)
  14 import Data.Function (($), (.))
  15 import Data.Functor ((<$>), (<$))
  16 import Data.Hashable (Hashable(..))
  17 import Data.Maybe (Maybe(..), isNothing, maybe, fromMaybe)
  18 import Data.Ord (Ord(..))
  19 import Data.Traversable (Traversable(..))
  20 import Data.Tree as Tree
  21 import Prelude (Num(..), Fractional(..), toRational)
  22 import Text.Show (Show(..))
  23 import qualified Data.HashMap.Strict as HM
  24 import qualified Data.HashSet as HS
  25 import qualified Data.List as List
  26 import qualified Data.Map.Strict as Map
  27
  28 import Majority.Merit
  29
  30 -- * Type 'Section'
  31 -- | An opinion of a 'judge' about a 'choice' at a specific section 'Tree.Node'.
  32 data Section grade
  33  =   Section
  34  {   sectionShare :: Maybe Share
  35      -- ^ A 'Share' within the parent 'Tree.Node'
  36      --   (defaulting to a 'Share' computed as the remaining 'Share' to reach 1
  37      --   divided by the number of defaulted 'Share's).
  38  ,   sectionGrade :: Maybe grade
  39      -- ^ A 'grade' attributed to the current 'Tree.Node'
  40      --   (defaulting to the 'grade' set on an ancestor 'Tree.Node' if any,
  41      --   or the @judge@'s default grade).
  42  } deriving (Eq,Show)
  43
  44 -- ** Type 'SectionByJudge'
  45 type SectionByJudge judge grade = HM.HashMap judge (Section grade)
  46
  47 -- ** Type 'SectionNode'
  48 -- | Node value of a 'Tree' holding a 'Section', per 'judge', per 'choice'.
  49 data SectionNode choice judge grade
  50  =   SectionNode
  51  {   sectionNodeShare       :: Maybe Share
  52      -- ^ A default 'sectionShare' for judges not specifying their own.
  53  ,   sectionByJudgeByChoice :: HM.HashMap choice (SectionByJudge judge grade)
  54  } deriving (Eq,Show)
  55
  56 -- * Type 'ErrorSection'
  57 data ErrorSection choice judge grade
  58  =   ErrorSection_unknown_choices (HS.HashSet choice)
  59      -- ^ When some 'choice's are not known.
  60  |   ErrorSection_unknown_judges (HM.HashMap choice (HS.HashSet judge))
  61      -- ^ When some 'judge's are not known.
  62  |   ErrorSection_invalid_shares (HM.HashMap choice (HM.HashMap judge [Share]))
  63      -- ^ When at least one of the 'Share's is not positive, or when their sum is not 1.
  64  deriving (Eq,Show)
  65
  66 -- | @'opinionsBySection' cs js ss@ computes the 'Opinions' of the given 'Judges' @js@ about the given 'choice's @cs@,
  67 -- from the 'grade' (specified or omitted) attributed to 'choice's
  68 -- and the 'Share's (specified or omitted) attributed to 'Tree.Node'
  69 -- in given 'Tree' @ss@.
  70 opinionsBySection ::
  71  forall choice judge grade.
  72  Eq choice =>
  73  Eq judge =>
  74  Hashable choice =>
  75  Hashable judge =>
  76  Ord grade =>
  77  Choices choice ->
  78  Judges judge grade ->
  79  Tree (SectionNode choice judge grade) ->
  80  Either (ErrorSection choice judge grade)
  81         (Tree (OpinionsByChoice choice judge grade))
  82 opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)
  83         where
  84         go :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) ->
  85               Tree (SectionNode choice judge grade) ->
  86               Either (ErrorSection choice judge grade)
  87                      (Tree (OpinionsByChoice choice judge grade))
  88         go defaultDistJC (Tree.Node (SectionNode _sectionNodeShare currOpinJC) childOpinJCS) =
  89                 -- From current 'Tree.Node''s value.
  90                         let currDistJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =
  91                                 -- Collect the 'Distribution' of current 'Tree.Node',
  92                                 -- and insert default 'Distribution'
  93                                 -- for each unspecified 'judge'
  94                                 -- of each (specified or unspecified) 'choice'.
  95                                 let specifiedDistJC =
  96                                         HM.mapWithKey (\choice ->
  97                                                 let defaultDistJ = defaultDistJC HM.!choice in
  98                                                 HM.mapWithKey (\judge ->
  99                                                         maybe (defaultDistJ HM.!judge) singleGrade .
 100                                                         sectionGrade))
 101                                          currOpinJC
 102                                 in
 103                                 HM.unionWith HM.union
 104                                  specifiedDistJC
 105                                  defaultDistJC
 106                         in
 107                 -- From children 'Tree.Node's.
 108                         let maybeChildShareSJC :: HM.HashMap choice (HM.HashMap judge [Maybe Share]) =
 109                                 -- Collect the (specified or explicitely (with 'Nothing') unspecified) 'Share's by section,
 110                                 -- and insert all unspecified 'Share's when a 'choice' or a 'judge' is unspecified.
 111                                 foldr (\(Tree.Node SectionNode{sectionNodeShare, sectionByJudgeByChoice} _) ->
 112                                         let defaultChildShareSJC = ([sectionNodeShare] <$ js) <$ defaultDistJC in
 113                                         let specifiedChildShareSJC =
 114                                                 (<$> sectionByJudgeByChoice) $
 115                                                 (pure . (<|> sectionNodeShare) . sectionShare <$>) in
 116                                         -- Fusion specified 'choice's into accum.
 117                                         HM.unionWith (HM.unionWith (List.++)) $
 118                                                 -- Add default 'Share' for this 'Tree.Node',
 119                                                 -- for each unspecified 'judge' of specified and unspecified 'choice'.
 120                                                 HM.unionWith HM.union
 121                                                  specifiedChildShareSJC
 122                                                  defaultChildShareSJC)
 123                                  HM.empty
 124                                  childOpinJCS
 125                         in
 126                         let childShareSJC :: HM.HashMap choice (HM.HashMap judge [Share]) =
 127                                 -- Replace unspecified shares of each child 'Tree.Node'
 128                                 -- by an even default: the total remaining 'Share'
 129                                 -- divided by the number of unspecified 'Share's.
 130                                 (<$> maybeChildShareSJC) $ \maybeShareSJ ->
 131                                         (<$> maybeShareSJ) $ \maybeShareS ->
 132                                                 let specifiedShare    = sum $ fromMaybe 0 <$> maybeShareS in
 133                                                 let unspecifiedShares = toRational $ List.length $ List.filter isNothing maybeShareS in
 134                                                 let defaultShare      = (1 - specifiedShare) / unspecifiedShares in
 135                                                 fromMaybe defaultShare <$> maybeShareS
 136                         in
 137                 case childOpinJCS of
 138                 -- Test for unknown choices.
 139                  _ | unknownChoices <- currOpinJC`HM.difference`defaultDistJC
 140                    , not $ null unknownChoices ->
 141                         Left $ ErrorSection_unknown_choices $
 142                                 HS.fromMap $ (() <$) $ unknownChoices
 143                 -- Test for unknown judges.
 144                  _ | unknownJudgesC <- HM.filter (not . null) $
 145                                        HM.intersectionWith HM.difference
 146                                         currOpinJC
 147                                         defaultDistJC
 148                    , not $ null unknownJudgesC ->
 149                         Left $ ErrorSection_unknown_judges $
 150                                 HS.fromMap . (() <$) <$> unknownJudgesC
 151                 -- Handle no child 'Tree.Node':
 152                 -- current 'Distribution' is computed from current 'Tree.Node''s value ('currOpinJC')
 153                 -- and inherited default 'Distribution' ('defaultDistJC').
 154                  [] -> Right $ Tree.Node currDistJC []
 155                 -- Test for invalid shares.
 156                  _ | invalidSharesJC <-
 157                        HM.filter (not . null) $
 158                        HM.filter (\ss -> any (< 0) ss || sum ss /= 1)
 159                        <$> childShareSJC
 160                    , not $ null invalidSharesJC ->
 161                         Left $ ErrorSection_invalid_shares invalidSharesJC
 162                 -- Handle children 'Tree.Node's:
 163                 -- current 'Opinions' is computed from the 'Opinions' of the children 'Tree.Node's.
 164                  _ -> do
 165                         distJCS :: [Tree (HM.HashMap choice (HM.HashMap judge (Distribution grade)))] <-
 166                                 traverse (go $ currDistJC) childOpinJCS
 167                                 -- 'grade's set at current 'Tree.Node' ('currDistJC')
 168                                 -- become the new default 'grade's ('defaultDistJC')
 169                                 -- within its children 'Tree.Node's.
 170                         let distSJC :: HM.HashMap choice (HM.HashMap judge [Distribution grade]) =
 171                                 -- Collect the 'Distribution's by section.
 172                                 foldr (\distJC ->
 173                                         let newDistSJC = (pure <$>) <$> rootLabel distJC in
 174                                         HM.unionWith (HM.unionWith (List.++)) newDistSJC)
 175                                  HM.empty
 176                                  distJCS
 177                         let distJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =
 178                                 -- Compute the current 'Distribution' by scaling (share *) and merging (+)
 179                                 -- the children 'Distribution's.
 180                                 HM.mapWithKey (\choice ->
 181                                         let childShareSJ = childShareSJC HM.!choice in
 182                                         HM.mapWithKey (\judge ->
 183                                                 let childShareS = childShareSJ HM.!judge in
 184                                                 Map.unionsWith (+) .
 185                                                 List.zipWith
 186                                                  (\share dist -> (share *) <$> dist)
 187                                                  childShareS))
 188                                  distSJC
 189                         Right $ Tree.Node distJC distJCS