diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 09c59f6b3..17bcc2b73 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -13,27 +13,25 @@ module Handler.Utils.Submission import Import hiding (joinPath) import Jobs.Queue -import Prelude (lcm) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Utils.Lens -import Control.Monad.State hiding (forM_, mapM_,foldM) +import Control.Monad.State as State (StateT) +import Control.Monad.State.Class as State import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter) -import Control.Monad.RWS.Lazy (RWST) +import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST) import qualified Control.Monad.Random as Rand import qualified System.Random.Shuffle as Rand (shuffleM) import Data.Maybe () -import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set -import Data.Map (Map) +import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map import qualified Data.Text as Text -import Data.Ratio import Data.Monoid (Monoid, Any(..), Sum(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) @@ -56,155 +54,163 @@ import Text.Hamlet (ihamletFile) import qualified Control.Monad.Catch as E (Handler(..)) -data AssignSubmissionException = NoCorrectorsByProportion +data AssignSubmissionException = NoCorrectors + | NoCorrectorsByProportion + | SubmissionsNotFound (NonNull (Set SubmissionId)) deriving (Typeable, Show) instance Exception AssignSubmissionException -- | Assigns all submissions according to sheet corrector loads -assignSubmissions :: SheetId -- ^ Sheet do distribute to correction +assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider -> YesodDB UniWorX ( Set SubmissionId , Set SubmissionId ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load assignSubmissions sid restriction = do Sheet{..} <- getJust sid - correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] [] - let - -- byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ] - corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto - corrsProp = filter hasPositiveLoad correctors - countsToLoad' :: UserId -> Bool - countsToLoad' uid = Map.findWithDefault True uid loadMap - loadMap :: Map UserId Bool - loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial] - - currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor') -> do - let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group - -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do - E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial) - E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial) - E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser) - E.where_ (tutor E.^. TutorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial)) - return $ tutor E.^. TutorUser - E.on $ tutor' E.?. UserId `E.in_` E.justList tutors - E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid - E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction) - return (submission E.^. SubmissionId, tutor' E.?. UserId) - - let subTutor' :: Map SubmissionId (Set UserId) - subTutor' = Map.fromListWith Set.union $ currentSubs - & mapped._2 %~ (maybe Set.empty Set.singleton . E.unValue) - & mapped._1 %~ E.unValue - - prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do - E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser) - E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial) - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial - E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser - E.where_ $ tutor E.^. TutorUser E.==. sheetCorrector E.^. SheetCorrectorUser - E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission) - E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse - E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors) - return (sheetCorrector, isByTutorial, E.isNothing (submission E.?. SubmissionId)) + correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.where_ $ sheetCorrector E.^. SheetCorrectorState `E.in_` E.valList [CorrectorNormal, CorrectorMissing] + return (sheet E.^. SheetId, sheetCorrector) let - prevSubs' :: Map SheetId (Map UserId (Rational, Integer)) - prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do - (Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs - guard $ maybe True (not isByTutorial ||) byTutorial - let proportion - | CorrectorExcused <- sheetCorrectorState = 0 - | otherwise = byProportion - return . Map.singleton sheetCorrectorSheet $ Map.singleton sheetCorrectorUser (proportion, bool 1 0 isPlaceholder) + correctors :: Map SheetId (Map UserId (Load, CorrectorState)) + correctors = Map.fromList $ do + E.Value sheetId <- Set.toList $ setOf (folded . _1) correctorsRaw + let loads = Map.fromList $ do + (E.Value sheetId', Entity _ SheetCorrector{..}) + <- correctorsRaw + guard $ sheetId' == sheetId + return (sheetCorrectorUser, (sheetCorrectorLoad, sheetCorrectorState)) + return (sheetId, loads) - deficit :: Map UserId Integer - deficit = Map.filter (> 0) $ Map.foldr (Map.unionWith (+) . toDeficit) Map.empty prevSubs' - - toDeficit :: Map UserId (Rational, Integer) -> Map UserId Integer - toDeficit assignments = toDeficit' <$> assignments + sheetCorrectors :: Map UserId Load + sheetCorrectors = Map.mapMaybe filterLoad $ correctors ! sid where - assigned' = getSum $ foldMap (Sum . snd) assignments - props = getSum $ foldMap (Sum . fst) assignments + filterLoad (l@Load{..}, CorrectorNormal) = l <$ guard (isJust byTutorial || byProportion /= 0) + filterLoad _ = Nothing - toDeficit' (prop, assigned) = let - target - | props == 0 = 0 - | otherwise = round $ fromInteger assigned' * (prop / props) - in target - assigned + unless (Map.member sid correctors) $ + throwM NoCorrectors - $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs' - $logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit + submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorialUser `E.InnerJoin` tutor)) -> do + E.on $ tutor E.?. TutorTutorial E.==. tutorialUser E.?. TutorialParticipantTutorial + E.on $ tutorialUser E.?. TutorialParticipantUser E.==. E.just (submissionUser E.^. SubmissionUserUser) + E.&&. tutor E.?. TutorUser `E.in_` E.justList (E.valList $ foldMap Map.keys correctors) + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + + E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse + + return (sheet E.^. SheetId, submission, tutor E.?. TutorUser) let - lcd :: Integer - lcd = foldr lcm 1 $ map (denominator . byProportion . sheetCorrectorLoad . entityVal) corrsProp - wholeProps :: Map UserId Integer - wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ] - detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit - detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps + -- | All submissions in this course so far + submissionData :: Map SubmissionId + ( Maybe UserId -- Corrector + , Map UserId (Sum Natural) -- Tutors + , SheetId + ) + submissionData = Map.fromListWith merge $ map process submissionDataRaw + where + process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) mTutId, sheetId)) + merge (corrA, tutorsA, sheetA) (corrB, tutorsB, sheetB) + | corrA /= corrB = error "Same submission seen with different correctors" + | sheetA /= sheetB = error "Same submission seen with different sheets" + | otherwise = (corrA, Map.unionWith mappend tutorsA tutorsB, sheetA) - $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue + targetSubmissions = Set.fromList $ do + (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw + guard $ sheetId == sid + case restriction of + Just restriction' -> + guard $ subId `Set.member` restriction' + Nothing -> + guard $ is _Nothing submissionRatingBy + return subId - queue <- liftIO . Rand.evalRandIO . execWriterT $ do - tell $ map Just detQueue - forever $ - tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ] + targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions + oldSubmissionData = Map.withoutKeys submissionData targetSubmissions - $logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue) + whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing -> + throwM $ SubmissionsNotFound missing let - assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m () - assignSubmission countsToLoad smid tutid = do - _1 %= Map.insert smid tutid - _3 . at tutid %= assertM' (> 0) . maybe (-1) pred - when countsToLoad $ - _2 %= List.delete (Just tutid) + withSubmissionData :: MonadRWS (Map SubmissionId a) w (Map SubmissionId a) m + => (Map SubmissionId a -> b) + -> m b + withSubmissionData f = f <$> (mappend <$> ask <*> State.get) + + -- | How many additional submission should the given corrector be assigned, if possible? + calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Integer + calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet + where + sheetSizes :: Map SheetId Integer + -- ^ 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) - maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId) - maximumDeficit = do - transposed <- uses _3 invertMap - traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed) + deficitBySheet :: Map SheetId Integer + -- ^ Deficite of @corrector@ per sheet + deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do + let assigned :: Integer + assigned = fromIntegral . Map.size $ 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 + corrProportion (Load{..}, _) = Sum byProportion + extra + | Just (Load{..}, corrState) <- correctors !? sheetId >>= Map.lookup corrector + = sum + [ assigned + , fromMaybe 0 $ do -- If corrections assigned by tutorial do not count against proportion, substract them from deficit + 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 + , fromMaybe 0 $ do + guard $ corrState /= CorrectorExcused + return . negate . floor $ (byProportion / proportionSum) * fromIntegral sheetSize + ] + | otherwise + = assigned + return $ negate extra - subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor' + targetSubmissions' <- liftIO . Rand.shuffleM $ Set.toList targetSubmissions - subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do - let - restrictTuts - | Set.null tuts = id - | otherwise = flip Map.restrictKeys tuts - byDeficit <- withStateT (over _3 restrictTuts) maximumDeficit - case byDeficit of - Just q' -> do - $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)" - assignSubmission False smid q' - Nothing - | Set.null tuts -> do - q <- preuse $ _2 . _head . _Just - case q of - Just q' -> do - $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (queue)" - assignSubmission True smid q' - Nothing -> return () - | otherwise -> do - q <- liftIO . Rand.evalRandIO $ Rand.uniform tuts - $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)" - assignSubmission (countsToLoad' q) smid q + (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ targetSubmissions' $ \subId -> do + tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural) + let acceptableCorrectors + | correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors + , not $ null correctorsByTut + = Map.keysSet correctorsByTut + | otherwise + = Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors + + when (not $ null acceptableCorrectors) $ do + deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit + let + bestCorrectors :: Set UserId + bestCorrectors = acceptableCorrectors + & maximumsBy (deficits !) + & maximumsBy (tutors !?) + + ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) now <- liftIO getCurrentTime - forM_ (Map.toList subTutor) $ - \(smid, tutid) -> update smid [ SubmissionRatingBy =. Just tutid - , SubmissionRatingAssigned =. Just now ] - - let assignedSubmissions = Map.keysSet subTutor - unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions - return (assignedSubmissions, unassigendSubmissions) - where - hasPositiveLoad = (> 0) . byProportion . sheetCorrectorLoad . entityVal - hasTutorialLoad = isJust . byTutorial . sheetCorrectorLoad . entityVal + execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, (mCorrector, _, _)) -> case mCorrector of + Just corrector -> do + lift $ update subId [ SubmissionRatingBy =. Just corrector + , SubmissionRatingAssigned =. Just now + ] + tell (Set.singleton subId, mempty) + Nothing -> + tell (mempty, Set.singleton subId) + where + maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a + maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 51aa57fd0..b4cd5a572 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -77,6 +77,8 @@ hasEntityUser = hasEntity makeLenses_ ''SheetCorrector +makeLenses_ ''Load + makeLenses_ ''SubmissionGroup makeLenses_ ''SheetGrading