From 5035dff9021260cd45dabfc175bb535bdc19dc71 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 7 Jun 2021 14:48:27 +0200 Subject: [PATCH] fix(submissions): fix distribution without consideration for deficit Fixes #713 --- src/Handler/Utils/Submission.hs | 30 ++++++++++++++++++---------- test/Handler/Utils/SubmissionSpec.hs | 22 +++++++++++++++++++- 2 files changed, 40 insertions(+), 12 deletions(-) diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index ba94bde8f..a2b329f2f 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 - -> 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 + -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider + -> 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 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 - return (sheetId, Sum 1) + (subId, x@(Just _, _, sheetId)) <- Map.toList submissionState + 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 diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index 8cf5bb3a6..b0626592b 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/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 + )