Abgaben Zuteilung überarbeitet

.vscode/tasks.json

@@ -14,6 +14,7 @@
         "reveal": "always",
         "focus": false,
         "panel": "dedicated",
+        "clear": true,
         "showReuseMessage": false
       }
     },

messages/uniworx/de.msg

@@ -34,6 +34,12 @@ GenericShort: Kürzel
 GenericIsNew: Neu
 GenericHasConflict: Konflikt
 GenericBack: Zurück
+GenericChange: Änderung
+GenericNumChange: +/-
+GenericMin: Min
+GenericAvg: Avg
+GenericMax: Max
+GenericAll: Insgesamt
 
 SummerTerm year@Integer: Sommersemester #{display year}
 WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
@@ -316,6 +322,7 @@ Correctors: Korrektoren
 CorState: Status
 CorByTut: Zuteilung nach Tutorium
 CorProportion: Anteil
+CorDeficit: Defizit
 CorByProportionOnly proportion@Rational: #{display proportion} Anteile
 CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium
 CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium
@@ -391,10 +398,11 @@ UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neue
 NoCorrector: Kein Korrektor
 RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
 UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt.
+UpdatedSheetCorrectorsAutoAssigned n@Int: #{display n} #{pluralDE n "Abgabe wurde einem Korrektor" "Abgaben wurden Korrektoren"} zugteilt.
+UpdatedSheetCorrectorsAutoFailed n@Int: #{display n} #{pluralDE n "Abgabe konnte" "Abgaben konnten"} nicht automatisch zugewiesen werden.
 CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
 SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
 
-
 CorrectionSheets: Übersicht Korrekturen nach Blättern
 CorrectionCorrectors: Übersicht Korrekturen nach Korrektoren
 AssignSubmissionExceptionNoCorrectors: Es sind keine Korrektoren eingestellt
@@ -402,13 +410,15 @@ AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit
 AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden
 NrSubmittorsTotal: Abgebende
 NrSubmissionsTotal: Abgaben
+NrSubmissionsTotalShort: Abg.
 NrSubmissionsUnassigned: Ohne Korrektor
 NoCorrectorAssigned: Ohne Korrektor
 NrCorrectors: Korrektoren
 NrSubmissionsNewlyAssigned: Neu zugeteilt
 NrSubmissionsNotAssigned: Nicht zugeteilt
 NrSubmissionsNotCorrected: Unkorrigiert
-CorrectionTime: Korrekturdauer (Min/Avg/Max)
+NrSubmissionsNotCorrectedShort: Unkg.
+CorrectionTime: Korrekturdauer
 AssignSubmissionsRandomWarning: Die Zuteilungsvorschau kann von der tatsächlichen Zuteilung abweichen, wenn mehrere Blätter auf einmal zugeteilt werden, da beim Ausgleich der Kontigente nur bereits zugeteilte Abgaben berücksichtigt werden. Da es ein randomisierte Prozess ist, kann es auch bei einzelnen Blättern gerinfgügige Abweichungen geben.
 
 CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
@@ -831,6 +841,7 @@ MenuCourseDelete: Kurs löschen
 MenuSubmissionNew: Abgabe anlegen
 MenuSubmissionOwn: Abgabe
 MenuCorrectors: Korrektoren
+MenuCorrectorsChange: Korrektoren ändern
 MenuSheetEdit: Übungsblatt editieren
 MenuSheetDelete: Übungsblatt löschen
 MenuSheetClone:  Als neues Übungsblatt klonen

src/Foundation.hs

@@ -206,6 +206,15 @@ noneOneMoreDE num noneText singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
+noneMoreDE :: (Eq a, Num a)
+            =>    a -- ^ Count
+            -> Text -- ^ None
+            -> Text -- ^ Some
+            -> Text
+noneMoreDE num noneText someText
+  | num == 0  = noneText
+  | otherwise = someText
+
 -- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
 type IntMaybe  = Maybe Int
 type TextList  = [Text]

src/Handler/Corrections.hs

@@ -1137,30 +1137,33 @@ assignHandler tid ssh csh cid assignSids = do
             in  List.foldr foldFun False sheetList
 
       -- plan or assign unassigned submissions for given sheets
-      let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int))
+      let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational))
           buildA acc sid = maybeT (return acc) $ do
             let shn = sheetName $ sheets ! sid
             -- is sheet closed?
             guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR  -- we must check, whether the submission is already closed and thus assignable
-            -- has at least one uncorrected / unassigned submisison?
+            -- ask for assignment plan
-            [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> do
+            let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections
-              E.where_ $ submission E.^. SubmissionSheet    E.==. E.val sid
+                ignoreExceptions NoCorrectors             = return mempty
-              E.where_ $ E.isNothing $ submission E.^. SubmissionRatingBy   -- no corrector
+                ignoreExceptions NoCorrectorsByProportion = return mempty
-              E.where_ $ E.isNothing $ submission E.^. SubmissionRatingTime -- not done
+                ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing
-            guard hasSubmission
+            (plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
-            -- has at least one active corrector?
+            guard $ not $ null plan -- only proceed if there is a plan for this sheet
-            [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do
+            -- implement assignment plan
-              E.where_ $ corrector E.^. SheetCorrectorSheet E.==. E.val sid
-              E.where_ $ corrector E.^. SheetCorrectorState E.==. E.val CorrectorNormal
-              -- E.where_ $ corrector E.^. SheetCorrectorLoad  E./=. E.val (Load {byTutorial = Nothing, byProportion = 0})
-            guard hasCorrector
-            -- TODO: Refactor guards above! We already have these informations, but forcing the maps inside the DB acces might not be a good idea
-            -- TODO: Maybe refactor planSubmissions instead to not throw exceptions, but signal "ok" or "not possible" instead!
-            plan <- lift $ planSubmissions sid Nothing
             status <- lift $ case btnResult of
               Nothing -> return (Set.empty, Set.empty)
-              (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan -- TODO: this comes to late!!
+              (Just BtnSubmissionsAssign) -> do
-            return $ Map.insert shn (status, countMapElems plan) acc
+                status@(sub_ok,sub_fail) <- writeSubmissionPlan plan
+                let nr_ok      = olength sub_ok
+                    nr_fail    = olength sub_fail
+                    alert_ok   = toMaybe (nr_ok   > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok
+                    alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed   nr_fail
+                    msg_status = bool Success Error $ nr_fail > 0
+                    msg_header = SomeMessage $ shn <> ":"
+                when (nr_ok > 0 || nr_fail > 0) $
+                  addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail]
+                return status
+            return $ Map.insert shn (status, countMapElems plan, deficit) acc
       assignment <- foldM buildA Map.empty assignSids
 
       correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do
@@ -1211,28 +1214,50 @@ assignHandler tid ssh csh cid assignSids = do
       -- create aggregate maps
       sheetMap :: Map SheetName CorrectionInfo
       sheetMap = Map.map fold infoMap
+
+      sheetLoad :: Map SheetName Load
+      sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap)
+        let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc
+            buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal}
+              = Map.insertWith (<>) s l acc
+            buildL acc _ _ = acc
+        in  Map.foldl buildSL Map.empty correctorMap
+
+      deficitMap :: Map UserId Rational
+      deficitMap = foldMap (view _3) assignment
+
       corrMap  :: Map (Maybe UserId) CorrectionInfo
       corrMap  = Map.unionsWith (<>) $ Map.elems infoMap
       sheetNames = Map.keys infoMap
   let -- whamlet convenience functions
-      -- avoid nestes hamelt $maybe with duplicated $nothing
+      -- avoid nestes hamlet $maybe with duplicated $nothing
       getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector)
       getCorrector (Just uid)
         | Just (User{..},loadMap) <- Map.lookup uid correctorMap
         = (nameEmailWidget userEmail userDisplayName userSurname, loadMap)
       getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty)
-      -- avoid nestes hamelt $maybe with duplicated $nothing
+      -- avoid nestes hamlet $maybe with duplicated $nothing
       getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo
       getCorrSheetStatus corr shn
         | (Just smap) <- Map.lookup shn infoMap
         = Map.lookup corr smap
       getCorrSheetStatus _ _ = Nothing
-      -- avoid nestes hamelt $maybe with duplicated $nothing
+      -- avoid nestes hamlet $maybe with duplicated $nothing
       getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int
       getCorrNewAssignment corr shn
-        | (Just (_,cass)) <- Map.lookup shn assignment
+        | (Just (_,cass,_)) <- Map.lookup shn assignment
         = Map.lookup corr cass
       getCorrNewAssignment _ _ = Nothing
+      -- avoid nestes hamlet $maybe with duplicated $nothing
+      getCorrDeficit :: Maybe UserId -> Maybe Rational
+      getCorrDeficit (Just uid) = Map.lookup uid deficitMap
+      getCorrDeficit _          = Nothing
+
+      getLoadSum :: SheetName -> Text
+      getLoadSum shn
+        | (Just load) <- Map.lookup shn sheetLoad
+        = "Σ" <> showCompactCorrectorLoad load CorrectorNormal
+      getLoadSum _ = mempty
 
       showDiffDays :: Maybe NominalDiffTime -> Text
       showDiffDays = foldMap formatDiffDays

src/Handler/Utils/Submission.hs

@@ -66,7 +66,9 @@ assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors
                   -> 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 = planSubmissions sid restriction >>= writeSubmissionPlan
+assignSubmissions sid restriction = do
+    (plan,_) <- planSubmissions sid restriction
+    writeSubmissionPlan plan
 
 -- | Assigns all submissions according to an already given assignment plan
 writeSubmissionPlan :: Map SubmissionId (Maybe UserId)
@@ -89,8 +91,8 @@ writeSubmissionPlan newSubmissionData = do
 --   May throw an exception if there are no suitable correctors
 planSubmissions :: SheetId -- ^ Sheet to distribute to correctors
                   -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
-                  -> YesodDB UniWorX (Map SubmissionId (Maybe UserId))
+                  -> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational)
-                  -- ^ Return map that assigns submissions to Corrector
+                  -- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit
 planSubmissions sid restriction = do
     Sheet{..} <- getJust sid
     correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
@@ -171,6 +173,10 @@ planSubmissions sid restriction = do
                          -> m b
       withSubmissionData f = f <$> (mappend <$> ask <*> State.get)
 
+      -- | Old Deficit for protocol purposes, not used here
+      oldDeficit :: Map UserId Rational
+      oldDeficit = Map.mapWithKey (\k _v -> calculateDeficit k submissionData) sheetCorrectors
+
       -- | 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
@@ -235,7 +241,7 @@ planSubmissions sid restriction = do
 
         ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)
 
-    return $ fmap (view _1) newSubmissionData
+    return (fmap (view _1) newSubmissionData, oldDeficit)
   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

templates/corrections-overview.hamlet

@@ -3,20 +3,26 @@
   _{MsgCourseParticipants nrParticipants}
   <table .table .table--striped .table--hover>
     <tr .table__row .table__row--head>
-      <th .table__th>_{MsgSheet}
+      <th .table__th rowspan=2>_{MsgSheet}
       $if groupsPossible
-        <th .table__th>_{MsgNrSubmittorsTotal}
+        <th .table__th rowspan=2>_{MsgNrSubmittorsTotal}
-      <th .table__th >_{MsgNrSubmissionsTotal}
+      <th .table__th rowspan=2>_{MsgNrSubmissionsTotal}
       <th .table__th colspan=2>_{MsgNrSubmissionsNotAssigned}
-      <th .table__th>_{MsgNrSubmissionsNotCorrected}
+      <th .table__th rowspan=2>_{MsgNrSubmissionsNotCorrected}
       <th .table__th colspan=3>_{MsgCorrectionTime}
+    <tr .table__row .table__row--head>
+      <th .table__th>
+      <th .table__th>_{MsgGenericNumChange}
+      <th .table__th>_{MsgGenericMin}
+      <th .table__th>_{MsgGenericAvg}
+      <th .table__th>_{MsgGenericMax}
     $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- Map.toList sheetMap
       <tr .table__row>
         <td .table__td>^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)}
         $if groupsPossible
           <td .table__td>#{ciSubmittors}
         <td .table__td>#{ciSubmissions}
-        $maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment
+        $maybe ((splus,sfailed),_,_) <- Map.lookup sheetName assignment
           $if 0 < Set.size sfailed
             <td .table__td>#{ciSubmissions - ciAssigned}
             <td .table__td .alert-danger>(-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)})
@@ -24,9 +30,11 @@
             <td .table__td>#{ciSubmissions - ciAssigned}
             <td .table__td .alert-info>(-#{show (Set.size splus)})
           $else
-            <td .table__td colspan=2>#{ciSubmissions - ciAssigned}
+            <td .table__td>#{ciSubmissions - ciAssigned}
+            <td .table__td>
         $nothing
-          <td .table__td colspan=2>#{ciSubmissions - ciAssigned}
+          <td .table__td>#{ciSubmissions - ciAssigned}
+          <td .table__td>
         <td .table__td>#{ciSubmissions - ciCorrected}
         <td .table__td>#{showDiffDays ciMin}
         <td .table__td>#{showAvgsDays ciTot ciCorrected}
@@ -35,43 +43,62 @@
   <h2>_{MsgCorrectionCorrectors}
   <table .table .table--striped .table--hover>
     <tr .table__row .table__row--head>
-      <th .table__th>_{MsgCorrector}
+      <th .table__th rowspan=2>_{MsgCorrector}
-      <th .table__th>_{MsgNrSubmissionsTotal}
+      <th .table__th colspan=2>_{MsgGenericAll}
-      <th .table__th>_{MsgNrSubmissionsNotCorrected}
+      <th .table__th>_{MsgCorProportion}
       <th .table__th colspan=3>_{MsgCorrectionTime}
       $forall shn <- sheetNames
         <th .table__th colspan=5>#{shn}
         $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
+    <tr .table__row .table__row--head>
+      <th .table__th>_{MsgNrSubmissionsTotal}
+      <th .table__th>_{MsgNrSubmissionsNotCorrected}
+      <th .table__th>_{MsgCorDeficit}
+      <th .table__th>_{MsgGenericMin}
+      <th .table__th>_{MsgGenericAvg}
+      <th .table__th>_{MsgGenericMax}
+      $forall _shn <- sheetNames
+        <th .table__th>_{MsgCorProportion}
+        <th .table__th>_{MsgNrSubmissionsTotalShort}
+        <th .table__th>_{MsgGenericNumChange}
+        <th .table__th>_{MsgNrSubmissionsNotCorrectedShort}
+        <th .table__th>_{MsgGenericAvg}
     $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap
       $with (nameW,loadM) <- getCorrector ciCorrector
         <tr .table__row>
           <td .table__td>^{nameW}
           <td .table__td>#{ciSubmissions}
           <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
+          <td .table__td>
+              $maybe deficit <- getCorrDeficit ciCorrector
+                #{display deficit}
           <td .table__td>#{showDiffDays ciMin}
           <td .table__td>#{showAvgsDays ciTot ciCorrected}
           <td .table__td>#{showDiffDays ciMax}
           $forall shn <- sheetNames
-            $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
+            <td .table__td>
-              <td .table__td>#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
+              $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
-            $nothing
+                #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
-              <td .table__td>
             $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
+              <td .table__td>#{ciSubmissions}
               $maybe nrNew <- getCorrNewAssignment ciCorrector shn
-                <td .table__td>#{ciSubmissions}
                 $# <td .table__td>#{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap`
                 <td .table__td .alert-info>(+#{nrNew})
               $nothing
-                <td .table__td colspan=2>#{ciSubmissions}
+                <td .table__td>
               <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
               <td .table__td>#{showAvgsDays ciTot ciCorrected}
             $nothing
-              <td .table__td colspan=4>
+              <td .table__td>
+              <td .table__td>
+              <td .table__td>
+              <td .table__td>
     $if 0 < length sheetNames
       <tr .table__row>
         <td colspan=6>
         $forall shn <- sheetNames
-          <td .table__td colspan=5>^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
+          <td .table__td>#{getLoadSum shn}
+          <td .table__td colspan=4>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
   ^{btnWdgt}
  <div>
   <p>_{MsgAssignSubmissionsRandomWarning}