From c6a6ec721c2a863d324ddfb5d2b2c1e42e659067 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 11 May 2021 14:17:12 +0200 Subject: [PATCH] feat(submissions): optionally disable consideration for deficit --- .../categories/courses/sheet/de-de-formal.msg | 2 + .../categories/courses/sheet/en-eu.msg | 2 + .../categories/model_types/de-de-formal.de | 13 ---- .../categories/model_types/de-de-formal.msg | 13 ++++ .../utils/navigation/menu/de-de-formal.msg | 2 +- .../{de-de-formal.de => de-de-formal.msg} | 0 .../{de-de-formal.de => de-de-formal.msg} | 0 missing-translations.sh | 1 + src/Handler/Sheet/Form.hs | 7 +- src/Handler/Utils/Submission.hs | 4 +- src/Model/Types/Sheet.hs | 36 ++++++++-- ...ctor-consider-deficits.de-de-formal.hamlet | 2 + .../corrector-consider-deficits.en-eu.hamlet | 2 + templates/sheetCorrectors/add.hamlet | 2 +- templates/sheetCorrectors/cell.hamlet | 2 + templates/sheetCorrectors/layout.hamlet | 3 + test/Database/Fill.hs | 6 +- test/Handler/Utils/SubmissionSpec.hs | 70 +++++++++++++------ test/Model/TypesSpec.hs | 30 +++++--- 19 files changed, 141 insertions(+), 56 deletions(-) delete mode 100644 messages/uniworx/categories/model_types/de-de-formal.de create mode 100644 messages/uniworx/categories/model_types/de-de-formal.msg rename messages/uniworx/utils/table_column/{de-de-formal.de => de-de-formal.msg} (100%) rename messages/uniworx/utils/utils/{de-de-formal.de => de-de-formal.msg} (100%) create mode 100644 templates/i18n/changelog/corrector-consider-deficits.de-de-formal.hamlet create mode 100644 templates/i18n/changelog/corrector-consider-deficits.en-eu.hamlet diff --git a/messages/uniworx/categories/courses/sheet/de-de-formal.msg b/messages/uniworx/categories/courses/sheet/de-de-formal.msg index 5ee0af1b0..699191285 100644 --- a/messages/uniworx/categories/courses/sheet/de-de-formal.msg +++ b/messages/uniworx/categories/courses/sheet/de-de-formal.msg @@ -61,6 +61,8 @@ SheetSubmissionModeNoneWithoutNotGraded: Es wurde "Keine Abgabe" eingestellt, je SheetWarnNoActiveTo: "Aktiv bis/Ende Abgabezeitraum" sollte stets angegeben werden CountTutProp: Tutorien zählen gegen Proportion CountTutPropTip: Wenn Abgaben nach Tutorium zugeteilt werden, zählen diese Zuteilungen in Bezug auf den jeweiligen Anteil? +ConsiderDeficits: Defizite ausgleichen +ConsiderDeficitsTip: Wenn einem Korrektor/einer Korrektorin (nach aktuellem Datenstand) über alle Blätter des Kurses hinweg weniger Korrekturen zugeteilt wurden als nach den Anteilen vorgesehen, soll versucht werden diese Defizite mit diesem Übungsblatt auszugleichen? SheetCorrector: Korrektor CorrectorExists: Nutzer:in ist bereits als Korrektor:in eingetragen SheetCorrectorState: Status diff --git a/messages/uniworx/categories/courses/sheet/en-eu.msg b/messages/uniworx/categories/courses/sheet/en-eu.msg index a1b45af84..32292cc68 100644 --- a/messages/uniworx/categories/courses/sheet/en-eu.msg +++ b/messages/uniworx/categories/courses/sheet/en-eu.msg @@ -61,6 +61,8 @@ SheetSubmissionModeNoneWithoutNotGraded: The sheet was configured to be "No subm SheetWarnNoActiveTo: “Active to/Submission period end” should always be specified CountTutProp: Tutorials count against proportion CountTutPropTip: If submissions are assigned by tutorial, do those assignments count with regard to the set proportion? +ConsiderDeficits: Compensate deficits +ConsiderDeficitsTip: When a corrector (as per the current state) was assigned fewer or more corrections than would be expected according to their proportions, this is considered a deficit. Should Uni2work try to compensate for these deficits when assigning corrections for this sheet? SheetCorrector: Corrector CorrectorExists: User already is a corrector SheetCorrectorState: State diff --git a/messages/uniworx/categories/model_types/de-de-formal.de b/messages/uniworx/categories/model_types/de-de-formal.de deleted file mode 100644 index bd8b07133..000000000 --- a/messages/uniworx/categories/model_types/de-de-formal.de +++ /dev/null @@ -1,13 +0,0 @@ -ChangelogItemFeature: Feature -ChangelogItemBugfix: Bugfix -SexNotKnown: Unbekannt -SexMale: Männlich -SexFemale: Weiblich -SexNotApplicable: Keine Angabe -NoSubmissions: Keine Abgabe -CorrectorSubmissions: Abgabe extern mit Pseudonym -UserSubmissions: Direkte Abgabe in Uni2work -SystemExamOffice: Prüfungsverwaltung -SystemFaculty: Fakultätsmitglied -SystemStudent: Student:in -BothSubmissions: Abgabe direkt in Uni2work & extern mit Pseudonym diff --git a/messages/uniworx/categories/model_types/de-de-formal.msg b/messages/uniworx/categories/model_types/de-de-formal.msg new file mode 100644 index 000000000..115e96b4c --- /dev/null +++ b/messages/uniworx/categories/model_types/de-de-formal.msg @@ -0,0 +1,13 @@ +ChangelogItemFeature: Feature +ChangelogItemBugfix: Bugfix +SexNotKnown: Unknown +SexMale: Male +SexFemale: Female +SexNotApplicable: Not applicable +NoSubmissions: No submission +CorrectorSubmissions: External submission via pseudonym +UserSubmissions: Direct submission in Uni2work +SystemExamOffice: Exam office +SystemFaculty: Faculty member +SystemStudent: Student +BothSubmissions: Submission either directly in Uni2work or externally via pseudonym diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index ac461ade7..eebab4d17 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -128,7 +128,7 @@ MenuGlobalWorkflowInstanceList: Systemweite Workflows MenuTopWorkflowInstanceList: Workflows MenuTopWorkflowWorkflowList: Laufende Workflows MenuTopWorkflowWorkflowListHeader: Workflows -MenuGlossary: +MenuGlossary: Begriffsverzeichnis MenuVersion: Versionsgeschichte MenuCourseNewsNew: Neue Kursnachricht MenuCourseNewsEdit: Kursnachricht bearbeiten diff --git a/messages/uniworx/utils/table_column/de-de-formal.de b/messages/uniworx/utils/table_column/de-de-formal.msg similarity index 100% rename from messages/uniworx/utils/table_column/de-de-formal.de rename to messages/uniworx/utils/table_column/de-de-formal.msg diff --git a/messages/uniworx/utils/utils/de-de-formal.de b/messages/uniworx/utils/utils/de-de-formal.msg similarity index 100% rename from messages/uniworx/utils/utils/de-de-formal.de rename to messages/uniworx/utils/utils/de-de-formal.msg diff --git a/missing-translations.sh b/missing-translations.sh index c8634742c..d866bc0bd 100755 --- a/missing-translations.sh +++ b/missing-translations.sh @@ -21,6 +21,7 @@ function translations() { msgFile=$1 sed -r 's/^([^ :]+).*$/\1/' ${msgFile} \ + | sed -r '/^\s*#/d' \ | sort } diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 375325a06..353b3d11a 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -166,8 +166,7 @@ correctorForm loads' = wFormToAForm $ do loads :: Map (Either UserEmail UserId) (CorrectorState, Load) loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load) - countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> Just True == byTutorial) $ Map.elems loads - + countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads let previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User)) @@ -203,13 +202,15 @@ correctorForm loads' = wFormToAForm $ do miCell _ userIdent initRes nudge csrf = do (stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False + (deficitRes, deficitView) <- mreq checkBoxField ("" & addName (nudge "deficit")) $ ((/= 0) . byDeficit . snd <$> initRes) <|> Just True (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0 let res :: FormResult (CorrectorState, Load) - res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes) + res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes <*> deficitRes') tutRes' | FormSuccess True <- byTutRes = Just <$> countTutRes | otherwise = Nothing <$ byTutRes + deficitRes' = bool 0 1 <$> deficitRes identWidget <- case userIdent of Left email -> return . toWidget $ mailtoHtml email Right uid -> do diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index f7505e10e..7ce366355 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -186,8 +186,10 @@ 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 = getSum $ foldMap Sum deficitBySheet + calculateDeficit corrector submissionState = (* byDeficit corrLoad) . getSum $ foldMap Sum deficitBySheet where + corrLoad = Map.findWithDefault mempty corrector sheetCorrectors + sheetSizes :: Map SheetId Integer -- ^ Number of assigned submissions (to anyone) per sheet sheetSizes = Map.map getSum . Map.fromListWith mappend $ do diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 3a6e015f9..c9cac4fd9 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -320,26 +320,40 @@ classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth -- | Specify a corrector's workload data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } - = Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload + = Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders + , byDeficit :: Rational -- ^ multiply accumulated deficit by this before considering for distribution } deriving (Show, Read, Eq, Ord, Generic) deriving anyclass (Hashable, NFData) -deriveJSON defaultOptions ''Load +instance ToJSON Load where + toJSON Load{..} = Aeson.object $ catMaybes + [ ("byTutorial" Aeson..=) . Just <$> byTutorial + , ("byProportion" Aeson..=) <$> assertM' (/= 0) byProportion + , ("byDeficit" Aeson..=) <$> assertM' (/= 1) byDeficit + ] +instance FromJSON Load where + parseJSON = Aeson.withObject "Load" $ \o -> do + byTutorial <- o Aeson..:? "byTutorial" + byProportion <- o Aeson..:? "byProportion" Aeson..!= 0 + byDeficit <- o Aeson..:? "byDeficit" Aeson..!= 1 + return Load{..} + derivePersistFieldJSON ''Load instance Semigroup Load where - (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') + (Load byTut prop byDeficit) <> (Load byTut' prop' byDeficit') = Load byTut'' (prop + prop') byDeficit'' where byTut'' | Nothing <- byTut = byTut' | Nothing <- byTut' = byTut | Just a <- byTut , Just b <- byTut' = Just $ a || b + byDeficit'' = byDeficit * byDeficit' instance Monoid Load where - mempty = Load Nothing 0 + mempty = Load Nothing 0 1 mappend = (<>) {- Use (is _ByTutorial) instead of this unneeded definition: @@ -363,8 +377,15 @@ derivePersistField "CorrectorState" showCompactCorrectorLoad :: Load -> CorrectorState -> Text showCompactCorrectorLoad load CorrectorMissing = "[" <> showCompactCorrectorLoad load CorrectorNormal <> "]" showCompactCorrectorLoad load CorrectorExcused = "{" <> showCompactCorrectorLoad load CorrectorNormal <> "}" -showCompactCorrectorLoad Load{..} CorrectorNormal | byProportion == 0 = fromMaybe mempty tutorialText - | otherwise = maybe id (\tt pt -> pt <> " + " <> tt) tutorialText proportionText +showCompactCorrectorLoad Load{..} CorrectorNormal + | byProportion == 0 + , Just tutorialText' <- tutorialText + , Just deficitText' <- deficitText + = tutorialText' <> " " <> deficitText' <> " D" + | byProportion == 0 + = fromMaybe mempty $ tutorialText <|> fmap (<> "D") deficitText + | otherwise + = maybe id (\dt acc -> acc <> " " <> dt <> " D") deficitText $ maybe id (\tt acc -> acc <> " + " <> tt) tutorialText proportionText where proportionText = let propDbl :: Double propDbl = fromRational byProportion @@ -372,6 +393,9 @@ showCompactCorrectorLoad Load{..} CorrectorNormal | byProportion == 0 = fromMay tutorialText = byTutorial <&> \case True -> "(T)" False -> "T" + deficitText | byDeficit == 1 = Nothing + | byDeficit > 1 = Just "+" + | otherwise = Just "-" instance Csv.ToField (SheetType epid, Maybe Points) where toField (_, Nothing) = mempty diff --git a/templates/i18n/changelog/corrector-consider-deficits.de-de-formal.hamlet b/templates/i18n/changelog/corrector-consider-deficits.de-de-formal.hamlet new file mode 100644 index 000000000..06d5c7c6e --- /dev/null +++ b/templates/i18n/changelog/corrector-consider-deficits.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Das Ausgleichen von Defiziten beim Verteilen von Korrekturen kann nun deaktiviert werden diff --git a/templates/i18n/changelog/corrector-consider-deficits.en-eu.hamlet b/templates/i18n/changelog/corrector-consider-deficits.en-eu.hamlet new file mode 100644 index 000000000..c82e6e8e3 --- /dev/null +++ b/templates/i18n/changelog/corrector-consider-deficits.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Consideration of corrector deficits when assigning corrections can now be disabled diff --git a/templates/sheetCorrectors/add.hamlet b/templates/sheetCorrectors/add.hamlet index 52ca70f42..03342b9a2 100644 --- a/templates/sheetCorrectors/add.hamlet +++ b/templates/sheetCorrectors/add.hamlet @@ -1,5 +1,5 @@ $newline never - + #{csrf} ^{fvWidget addView} diff --git a/templates/sheetCorrectors/cell.hamlet b/templates/sheetCorrectors/cell.hamlet index 6e6822a89..e014c43c8 100644 --- a/templates/sheetCorrectors/cell.hamlet +++ b/templates/sheetCorrectors/cell.hamlet @@ -11,6 +11,8 @@ $case userIdent #{csrf} ^{fvWidget stateView} + + ^{fvWidget deficitView} ^{fvWidget byTutView} diff --git a/templates/sheetCorrectors/layout.hamlet b/templates/sheetCorrectors/layout.hamlet index 91ee9eec4..7621258c2 100644 --- a/templates/sheetCorrectors/layout.hamlet +++ b/templates/sheetCorrectors/layout.hamlet @@ -4,6 +4,9 @@ $newline never _{MsgTableCorrector} _{MsgTableCorState} + + _{MsgConsiderDeficits} + ^{messageTooltip =<< messageI Info MsgConsiderDeficitsTip} _{MsgCorByTut} _{MsgTableCorProportion} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index f619a1044..fa933ab47 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -918,9 +918,9 @@ fillDb = do forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do p <- liftIO getRandom void . insert $ SheetPseudonym shId p uid - void . insert $ SheetCorrector jost shId (Load (Just True) 0) CorrectorNormal - void . insert $ SheetCorrector gkleen shId (Load (Just True) 1) CorrectorNormal - void . insert $ SheetCorrector svaupel shId (Load (Just True) 1) CorrectorNormal + void . insert $ SheetCorrector jost shId (Load (Just True) 0 1) CorrectorNormal + void . insert $ SheetCorrector gkleen shId (Load (Just True) 1 1) CorrectorNormal + void . insert $ SheetCorrector svaupel shId (Load (Just True) 1 1) CorrectorNormal void $ insertFile (SheetFileResidual shId SheetHint) "H10-2.hs" void $ insertFile (SheetFileResidual shId SheetSolution) "H10-3.hs" void $ insertFile (SheetFileResidual shId SheetExercise) "ProMo_Uebung10.pdf" diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index ff2c1c22b..8cf5bb3a6 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -26,7 +26,13 @@ import Database.Persist.Sql (fromSqlKey) import qualified Database.Esqueleto as E --- import Data.Maybe (fromJust) +import Data.Monoid (First(..)) + +import Utils (guardOn) + +import Control.Lens.Extras (is) + +import Data.Maybe (fromJust) userNumber :: TVar Natural @@ -46,8 +52,8 @@ makeUsers (fromIntegral -> n) = do return $ zipWith Entity uids users distributionExample :: SqlPersistM [(Natural, [Maybe Load])] -- ^ Number of submissions and corrector specification - -> ([Entity Submission] -> [Entity SheetCorrector] -> SqlPersistM ()) -- ^ Setup hook - -> (Map (Maybe SheetCorrector) (Set SubmissionId) -> Expectation) + -> (Natural -> [Entity Submission] -> [Entity SheetCorrector] -> SqlPersistM ()) -- ^ Setup hook + -> (Map (Maybe SheetCorrector) (Set (SubmissionId, Maybe Natural)) -> Expectation) -> YesodExample UniWorX () distributionExample mkParameters setupHook cont = do situations <- runDB $ do @@ -88,11 +94,18 @@ distributionExample mkParameters setupHook cont = do return (sid, (submissions, sheetCorrectors')) - mapM_ (uncurry setupHook) $ map snd situations + mapM_ (\(n, (subs, corrs)) -> setupHook n subs corrs) . zip [1..] $ map snd situations - return situations + situations' <- forM situations $ \(sid, (submissions, sheetCorrectors)) -> (sid, ) <$> do + submissions' <- mapM (fmap fromJust . getEntity . entityKey) submissions + sheetCorrectors' <- mapM (fmap fromJust . getEntity . entityKey) sheetCorrectors + return (submissions', sheetCorrectors') - let subIds = concatMap (\(_, (subs, _)) -> map entityKey subs) situations + return situations' + + let + subIds :: [SubmissionId] + subIds = concatMap (\(_, (subs, _)) -> mapMaybe (\(Entity subId Submission{..}) -> guardOn (is _Nothing submissionRatingBy) subId) subs) situations results <- runHandler . Yesod.runDB . mapM (\sid -> assignSubmissions sid Nothing) $ map fst situations @@ -104,15 +117,16 @@ distributionExample mkParameters setupHook cont = do cont . Map.fromListWith mappend $ do Entity subId Submission{..} <- submissions let key = listToMaybe . filter (\(Entity _ (SheetCorrector uid _ _ _)) -> Just uid == submissionRatingBy) $ concatMap (\(_, (_, corrs)) -> corrs) situations - return (entityVal <$> key, Set.singleton subId) + sheet = getFirst . foldMap (\(n, (sid, _)) -> First $ guardOn (sid == submissionSheet) n) $ zip [1..] situations + return (entityVal <$> key, Set.singleton (subId, sheet)) spec :: Spec spec = withApp . describe "Submission distribution" $ do it "is fair" $ distributionExample - (return [(500, replicate 10 (Just $ Load Nothing 1))]) - (\_ _ -> return ()) + (return [(500, replicate 10 (Just $ Load Nothing 1 1))]) + (\_ _ _ -> return ()) (\result -> do let countResult = Map.map Set.size result countResult `shouldNotSatisfy` Map.member Nothing @@ -120,20 +134,20 @@ spec = withApp . describe "Submission distribution" $ do ) it "follows distribution" $ distributionExample - (return [(500, replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2))]) - (\_ _ -> return ()) + (return [(500, replicate 6 (Just $ Load Nothing 1 1) ++ replicate 2 (Just $ Load Nothing 2 1))]) + (\_ _ _ -> return ()) (\result -> do let countResult = Map.map Set.size result countResult `shouldNotSatisfy` Map.member Nothing - countResult `shouldSatisfy` all (\(Just (SheetCorrector _ _ (Load _ prop) _), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList + countResult `shouldSatisfy` all (\(Just (SheetCorrector _ _ (Load _ prop _) _), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList ) it "follows cumulative distribution over multiple sheets" $ 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 Nothing 1 1) ++ replicate 2 (Just $ Load Nothing 2 1) distributionExample (return [ (n, loads) | n <- ns' ]) - (\_ _ -> return ()) + (\_ _ _ -> return ()) (\result -> do let countResult = Map.map Set.size result countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult @@ -144,12 +158,12 @@ spec = withApp . describe "Submission distribution" $ 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) + return $ replicate onesBefore (Just $ Load Nothing 1 1) + ++ replicate 2 (Just $ Load Nothing 2 1) + ++ replicate onesAfter (Just $ Load Nothing 1 1) distributionExample (return $ zip ns loads) - (\_ _ -> return ()) + (\_ _ _ -> return ()) (\result -> do let countResult = Map.map Set.size result countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> fromSqlKey sheetCorrectorUser) countResult @@ -159,11 +173,11 @@ spec = withApp . describe "Submission distribution" $ do 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 (Just True) 1) ++ replicate 2 (Just $ Load (Just True) 2) + loads = replicate 6 (Just $ Load (Just True) 1 1) ++ replicate 2 (Just $ Load (Just True) 2 1) tutSubIds <- liftIO $ newTVarIO Map.empty distributionExample (return [ (n, loads) | n <- ns' ]) - (\subs corrs -> do + (\_ subs corrs -> do tutSubmissions <- liftIO $ getRandomR (5,10) subs' <- liftIO $ shuffleM subs forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do @@ -192,3 +206,19 @@ spec = withApp . describe "Submission distribution" $ do -- 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) ) + it "allows disabling deficit consideration" $ + distributionExample + (return . replicate 2 $ (500, replicate 2 (Just $ Load Nothing 1 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 1))) result + allEqual [] = True + allEqual ((_, c) : xs) = all (\(_, c') -> c == c') xs + secondResult `shouldSatisfy` allEqual . Map.toList + ) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index a5c011ea5..e1736ce03 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -149,6 +149,7 @@ instance Arbitrary Load where arbitrary = do byTutorial <- arbitrary byProportion <- getNonNegative <$> arbitrary + byDeficit <- oneof [ pure 0, pure 1, arbitrary ] return Load{..} shrink = genericShrink @@ -523,16 +524,29 @@ spec = do toPathPiece ExamCloseSeparate `shouldBe` "separate" toPathPiece (ExamCloseOnFinished False) `shouldBe` "on-finished" toPathPiece (ExamCloseOnFinished True) `shouldBe` "on-finished-hidden" + describe "Load" $ + it "decodes some examples from json" . example $ do + let t str expect = Aeson.eitherDecode str `shouldBe` Right expect + t "{}" $ Load Nothing 0 1 + t "{\"byTutorial\": true, \"byProportion\": {\"numerator\": 0, \"denominator\": 1}}" $ Load (Just True) 0 1 describe "CompactCorrectorLoad" $ do it "matches expectations" . example $ do - showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 0 } CorrectorNormal `shouldBe` "T" - showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 0 } CorrectorNormal `shouldBe` "(T)" - showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorNormal `shouldBe` "1.0" - showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 1 } CorrectorNormal `shouldBe` "1.0 + T" - showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 1 } CorrectorNormal `shouldBe` "1.0 + (T)" - showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 0 } CorrectorNormal `shouldBe` "" - showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorMissing `shouldBe` "[1.0]" - showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorExcused `shouldBe` "{1.0}" + showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 0, byDeficit = 1 } CorrectorNormal `shouldBe` "T" + showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 0, byDeficit = 1 } CorrectorNormal `shouldBe` "(T)" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 1 } CorrectorNormal `shouldBe` "1.0" + showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 1, byDeficit = 1 } CorrectorNormal `shouldBe` "1.0 + T" + showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 1, byDeficit = 1 } CorrectorNormal `shouldBe` "1.0 + (T)" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 0, byDeficit = 1 } CorrectorNormal `shouldBe` "" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 1 } CorrectorMissing `shouldBe` "[1.0]" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 1 } CorrectorExcused `shouldBe` "{1.0}" + showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 0, byDeficit = 0 } CorrectorNormal `shouldBe` "T - D" + showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 0, byDeficit = 0 } CorrectorNormal `shouldBe` "(T) - D" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorNormal `shouldBe` "1.0 - D" + showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 1, byDeficit = 0 } CorrectorNormal `shouldBe` "1.0 + T - D" + showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 1, byDeficit = 0 } CorrectorNormal `shouldBe` "1.0 + (T) - D" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 0, byDeficit = 0 } CorrectorNormal `shouldBe` "-D" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}" termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do