From 848dc7470a79e200bb48cee505b3f7b6311fb209 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 19 May 2019 20:19:46 +0200 Subject: [PATCH] Additional testing --- models/tutorials | 1 + src/Handler/Utils/Submission.hs | 31 +++++++++++++++++++++------- test/Handler/Utils/SubmissionSpec.hs | 31 ++++++++++++++++++++++++++-- test/Model/TypesSpec.hs | 17 +++++++++++++++ test/ModelSpec.hs | 15 ++++++++++++++ 5 files changed, 85 insertions(+), 10 deletions(-) diff --git a/models/tutorials b/models/tutorials index 444d988cd..4961e0bd5 100644 --- a/models/tutorials +++ b/models/tutorials @@ -11,6 +11,7 @@ Tutorial json deregisterUntil UTCTime Maybe lastChanged UTCTime default=now() UniqueTutorial course name + deriving Generic Tutor tutorial TutorialId user UserId diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 17bcc2b73..9f604afd1 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -94,10 +94,12 @@ assignSubmissions sid restriction = do unless (Map.member sid correctors) $ throwM NoCorrectors - 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 + submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorial `E.InnerJoin` tutorialUser `E.InnerJoin` tutor)) -> do + E.on $ tutor E.?. TutorTutorial E.==. tutorial E.?. TutorialId + E.on $ tutorialUser E.?. TutorialParticipantTutorial E.==. tutorial E.?. TutorialId 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.&&. tutorial E.?. TutorialCourse E.==. E.just (E.val sheetCourse) E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId @@ -114,12 +116,15 @@ assignSubmissions sid restriction = do ) 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)) + process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) $ assertM isCorrectorByTutorial 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) + -- Not done in esqueleto, since inspection of `Load`-Values is difficult + isCorrectorByTutorial = maybe False (\Load{..} -> is _Just byTutorial) . flip Map.lookup sheetCorrectors + targetSubmissions = Set.fromList $ do (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw guard $ sheetId == sid @@ -143,7 +148,7 @@ assignSubmissions sid restriction = do 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 :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet where sheetSizes :: Map SheetId Integer @@ -152,10 +157,10 @@ assignSubmissions sid restriction = do (_, (Just _, _, sheetId)) <- Map.toList submissionState return (sheetId, Sum 1) - deficitBySheet :: Map SheetId Integer + deficitBySheet :: Map SheetId Rational -- ^ Deficite of @corrector@ per sheet deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do - let assigned :: Integer + let assigned :: Rational 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 @@ -172,13 +177,16 @@ assignSubmissions sid restriction = do 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 + return . negate $ (byProportion / proportionSum) * fromIntegral sheetSize ] | otherwise = assigned return $ negate extra - targetSubmissions' <- liftIO . Rand.shuffleM $ Set.toList targetSubmissions + -- Sort target submissions by those that have tutors first and otherwise random + -- + -- Deficit produced by restriction to tutors can thus be fixed by later submissions + targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ targetSubmissions' $ \subId -> do tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural) @@ -197,6 +205,10 @@ assignSubmissions sid restriction = do & maximumsBy (deficits !) & maximumsBy (tutors !?) + $logDebugS "assignSubmissions" [st|Tutors for #{tshow subId}: #{tshow tutors}|] + $logDebugS "assignSubmissions" [st|Current (#{tshow subId}) relevant deficits: #{tshow deficits}|] + $logDebugS "assignSubmissions" [st|Assigning #{tshow subId} to one of #{tshow bestCorrectors}|] + ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) now <- liftIO getCurrentTime @@ -212,6 +224,9 @@ assignSubmissions sid restriction = do 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 + unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a] + unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp + submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index 995ae63d5..e25a087fb 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -21,6 +21,8 @@ import Control.Monad.Random.Class import Database.Persist.Sql (fromSqlKey) +import qualified Database.Esqueleto as E + userNumber :: TVar Natural userNumber = unsafePerformIO $ newTVarIO 1 @@ -57,8 +59,8 @@ distributionExample mkParameters setupHook cont = do participants <- makeUsers subsN correctors <- makeUsers correctorsN - situations <- forM steps $ \(subsN', loads) -> do - sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetCourse = cid } + situations <- forM (zip [1..] steps) $ \(i, (subsN', loads)) -> do + sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetName = CI.mk $ "Sheet " <> tshow (i :: Integer), sheetCourse = cid } sid <- insert sheet participants' <- liftIO $ take (fromIntegral subsN') <$> shuffleM participants @@ -133,3 +135,28 @@ spec = withApp . describe "Submission distribution" $ do countResult `shouldNotSatisfy` Map.member Nothing countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList ) + it "handles tutorials with proportion" $ do + ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100) + let ns' = ns ++ [500 - sum ns] + loads = replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2) + distributionExample + (return [ (n, loads) | n <- ns' ]) + (\subs corrs -> do + tutSubmissions <- liftIO $ getRandomR (1,500) + subs' <- liftIO $ shuffleM subs + forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do + Entity _ SheetCorrector{..} <- liftIO $ uniform corrs + Sheet{..} <- getJust submissionSheet + tut <- liftIO $ generate arbitrary <&> \c -> c { tutorialName = CI.mk $ "Tut for " <> tshow (fromSqlKey subId), tutorialCourse = sheetCourse } + tutId <- insert tut + void . insert $ Tutor tutId sheetCorrectorUser + E.insertSelect . E.from $ \submissionUser -> do + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId + return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) + ) + (\result -> do + let countResult = Map.map Set.size result + countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult + countResult `shouldNotSatisfy` Map.member Nothing + countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList + ) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 354ef20e6..ad74f5831 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -21,6 +21,8 @@ import Text.Blaze.Renderer.Text import qualified Data.Set as Set +import Time.Types (WeekDay(..)) + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -193,6 +195,21 @@ instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key r instance Arbitrary Html where arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary shrink = map preEscapedToHtml . shrink . renderMarkup + +instance Arbitrary WeekDay where + arbitrary = oneof $ map pure [minBound..maxBound] + +instance Arbitrary OccurenceSchedule where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary OccurenceException where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary Occurences where + arbitrary = genericArbitrary + shrink = genericShrink spec :: Spec diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index f530ec26a..e5fbdb9c3 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -54,6 +54,21 @@ instance Arbitrary Sheet where <*> arbitrary shrink = genericShrink +instance Arbitrary Tutorial where + arbitrary = Tutorial + <$> (CI.mk . pack . getPrintableString <$> arbitrary) + <*> arbitrary + <*> (CI.mk . pack . getPrintableString <$> arbitrary) + <*> (fmap getPositive <$> arbitrary) + <*> (pack . getPrintableString <$> arbitrary) + <*> arbitrary + <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink = genericShrink + instance Arbitrary User where arbitrary = do userIdent <- CI.mk . pack <$> oneof