fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(submissions): fix distribution without consideration for deficit

Browse Source 
Fixes #713
This commit is contained in:
Gregor Kleen 2021-06-07 14:48:27 +02:00
parent fd704e7d23
commit 5035dff902
2 changed files with 40 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
src/Handler/Utils/Submission.hs
View File

@ -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

22
test/Handler/Utils/SubmissionSpec.hs
View File

@ -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
)