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

Additional testing

Browse Source
This commit is contained in:
Gregor Kleen 2019-05-19 20:19:46 +02:00
parent 27a5b83f55
commit 848dc7470a
5 changed files with 85 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
models/tutorials
View File

@ -11,6 +11,7 @@ Tutorial json
deregisterUntil UTCTime Maybe
lastChanged UTCTime default=now()
UniqueTutorial course name
deriving Generic
Tutor
tutorial TutorialId
user UserId

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

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

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

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

17
test/Model/TypesSpec.hs
View File

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

15
test/ModelSpec.hs
View File

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