fix(submissions): fix distribution without consideration for deficit

Fixes #713

src/Handler/Utils/Submission.hs

@@ -97,9 +97,8 @@ writeSubmissionPlan newSubmissionData = do
 -- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet!
 --   May throw an exception if there are no suitable correctors
 planSubmissions :: SheetId -- ^ Sheet to distribute to correctors
-                  -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
+                -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
-                  -> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational)
+                -> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational) -- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit
-                  -- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit
 planSubmissions sid restriction = do
     Sheet{..} <- getJust sid
     correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
@@ -186,21 +185,30 @@ planSubmissions sid restriction = do
 
       -- | How many additional submission should the given corrector be assigned, if possible?
       calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
-      calculateDeficit corrector submissionState = (* byDeficit corrLoad) . getSum $ foldMap Sum deficitBySheet
+      calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet
         where
+          deficitWeight :: SubmissionId -> (Maybe UserId, Map UserId _, SheetId) -> Rational
+          deficitWeight subId (_, _, shId)
+            | Just restr' <- restriction = prop $ subId `Set.member` restr'
+            | otherwise = prop $ shId == sid
+            where prop = bool (byDeficit corrLoad) 1
+
+          sumDeficitWeight :: Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
+          sumDeficitWeight = getSum . ifoldMap (\subId x -> Sum $ deficitWeight subId x)
+          
           corrLoad = Map.findWithDefault mempty corrector sheetCorrectors
           
-          sheetSizes :: Map SheetId Integer
+          sheetSizes :: Map SheetId Rational
           -- ^ Number of assigned submissions (to anyone) per sheet
           sheetSizes = Map.map getSum . Map.fromListWith mappend $ do
-            (_, (Just _, _, sheetId)) <- Map.toList submissionState
+            (subId, x@(Just _, _, sheetId)) <- Map.toList submissionState
-            return (sheetId, Sum 1)
+            return (sheetId, Sum $ deficitWeight subId x)
 
           deficitBySheet :: Map SheetId Rational
-          -- ^ Deficite of @corrector@ per sheet
+          -- ^ Deficit of @corrector@ per sheet
           deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do
             let assigned :: Rational
-                assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState
+                assigned = sumDeficitWeight $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState
                 proportionSum :: Rational
                 proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId
                   where corrProportion (_, CorrectorExcused) = mempty
@@ -217,10 +225,10 @@ planSubmissions sid restriction = do
                         tutCounts <- byTutorial
                         guard $ not tutCounts
                         guard $ corrState /= CorrectorExcused
-                        return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState
+                        return . negate . sumDeficitWeight $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState
                     , fromMaybe 0 $ do
                         guard $ corrState /= CorrectorExcused
-                        return . negate $ relativeProportion byProportion * fromIntegral sheetSize
+                        return . negate $ relativeProportion byProportion * sheetSize
                     ]
                   | otherwise
                   = assigned

test/Handler/Utils/SubmissionSpec.hs

@@ -217,8 +217,28 @@ spec = withApp . describe "Submission distribution" $ do
           | otherwise -> return ()
       )
       (\result -> do
-          let secondResult = Map.map (Set.size . Set.filter (views _2 (== Just 1))) result
+          let secondResult = Map.map (Set.size . Set.filter (views _2 (== Just 2))) result
               allEqual [] = True
               allEqual ((_, c) : xs) = all (\(_, c') -> c == c') xs
           secondResult `shouldSatisfy` allEqual . Map.toList
       )
+  it "allows disabling deficit consideration with unequal proportions" $
+    distributionExample
+      (return . replicate 2 $ (550, [Just (Load Nothing 1 0), Just (Load Nothing 10 0)]))
+      (\n subs corrs -> if
+          | n < 2
+          , Entity _ SheetCorrector{ sheetCorrectorUser = corrId } : _ <- corrs
+            -> forM_ subs $ \(Entity subId _) ->
+                 update subId [SubmissionRatingBy =. Just corrId]
+          | otherwise -> return ()
+      )
+      (\result -> do
+          let secondResult = Map.map (Set.size . Set.filter (views _2 (== Just 2))) result
+              secondResultNorm = imap go secondResult
+                where go Nothing x = fromIntegral x
+                      go (Just SheetCorrector{..}) x = fromIntegral x / prop
+                        where prop = byProportion sheetCorrectorLoad
+              allEqual [] = True
+              allEqual ((_, c) : xs) = all (\(_, c') -> c == c') xs
+          secondResultNorm `shouldSatisfy` allEqual . Map.toList
+      )