From 7deba8132004626fe4c2ea7b9efa176caf59c03b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 20 May 2019 00:06:15 +0200 Subject: [PATCH] Additional testing --- package.yaml | 1 + src/Handler/Utils/Submission.hs | 8 +++--- test/Handler/Utils/SubmissionSpec.hs | 41 +++++++++++++++++++++++++--- 3 files changed, 42 insertions(+), 8 deletions(-) diff --git a/package.yaml b/package.yaml index 098fb0bec..417b74e26 100644 --- a/package.yaml +++ b/package.yaml @@ -243,6 +243,7 @@ tests: - uniworx - hspec >=2.0.0 - QuickCheck + - HUnit - yesod-test - conduit-extra - quickcheck-classes diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 9f604afd1..8fededf3f 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -188,7 +188,7 @@ assignSubmissions sid restriction = do -- 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 + (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, 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 @@ -205,9 +205,9 @@ 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}|] + $logDebugS "assignSubmissions" [st|#{tshow i} Tutors for #{tshow subId}: #{tshow tutors}|] + $logDebugS "assignSubmissions" [st|#{tshow i} Current (#{tshow subId}) relevant deficits: #{tshow deficits}|] + $logDebugS "assignSubmissions" [st|#{tshow i} Assigning #{tshow subId} to one of #{tshow bestCorrectors}|] ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index e25a087fb..4caeba5fa 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -3,11 +3,13 @@ module Handler.Utils.SubmissionSpec where import qualified Yesod import TestImport +-- import qualified Test.HUnit.Base as HUnit import Handler.Utils.Submission import ModelSpec () import qualified Data.Set as Set +import Data.Map ((!?)) import qualified Data.Map as Map import Data.List (genericLength) @@ -19,10 +21,12 @@ import System.IO.Unsafe import System.Random.Shuffle import Control.Monad.Random.Class -import Database.Persist.Sql (fromSqlKey) +import Database.Persist.Sql (toSqlKey, fromSqlKey) import qualified Database.Esqueleto as E +-- import Data.Maybe (fromJust) + userNumber :: TVar Natural userNumber = unsafePerformIO $ newTVarIO 1 @@ -135,10 +139,27 @@ spec = withApp . describe "Submission distribution" $ do countResult `shouldNotSatisfy` Map.member Nothing countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList ) + it "follows non-constant cumulative distribution over multiple sheets" $ do + let ns = replicate 4 100 + loads = do + (onesBefore, onesAfter) <- zip [0,2..6] [6,4..0] + return $ replicate onesBefore (Just $ Load Nothing 1) + ++ replicate 2 (Just $ Load Nothing 2) + ++ replicate onesAfter (Just $ Load Nothing 1) + distributionExample + (return $ zip ns loads) + (\_ _ -> return ()) + (\result -> do + let countResult = Map.map Set.size result + countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> fromSqlKey sheetCorrectorUser) countResult + countResult `shouldNotSatisfy` Map.member Nothing + countResult' `shouldSatisfy` all (\(Just _, subsSet) -> subsSet == 50) . 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) + loads = replicate 6 (Just $ Load (Just True) 1) ++ replicate 2 (Just $ Load (Just True) 2) + tutSubIds <- liftIO $ newTVarIO Map.empty distributionExample (return [ (n, loads) | n <- ns' ]) (\subs corrs -> do @@ -146,6 +167,7 @@ spec = withApp . describe "Submission distribution" $ do subs' <- liftIO $ shuffleM subs forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do Entity _ SheetCorrector{..} <- liftIO $ uniform corrs + atomically . modifyTVar tutSubIds . Map.insertWith mappend sheetCorrectorUser $ Set.singleton subId Sheet{..} <- getJust submissionSheet tut <- liftIO $ generate arbitrary <&> \c -> c { tutorialName = CI.mk $ "Tut for " <> tshow (fromSqlKey subId), tutorialCourse = sheetCourse } tutId <- insert tut @@ -157,6 +179,17 @@ spec = withApp . describe "Submission distribution" $ do (\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 + tutSubIds' <- liftIO $ readTVarIO tutSubIds + + countResult' `shouldNotSatisfy` Map.member Nothing + countResult' `shouldSatisfy` all (\(Just (corr, prop), subsSet) -> fromIntegral subsSet <= max (50 * prop) (maybe 0 (fromIntegral . Set.size) $ tutSubIds' !? toSqlKey corr)) . Map.toList + + -- -- Does not currently work, because `User`s are reused within `distributionExample`, so submissions end up having more associated course-tutors, because the same user might be a member of a tutorial created for another submission + -- + -- let subs = fold tutSubIds' + -- forM_ subs $ \subId -> do + -- let tutors = Map.keysSet $ Map.filter (Set.member subId) tutSubIds' + -- assignedTo = Set.map (sheetCorrectorUser . fromJust) . Map.keysSet $ Map.filter (Set.member subId) result + -- HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to multiple correctors") 1 $ Set.size assignedTo + -- HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to non-tutors (" <> show (Set.map fromSqlKey tutors) <> ")") Set.empty (Set.map fromSqlKey $ assignedTo `Set.difference` tutors) )