Abgaben Zuteilung überarbeitet

2019-06-26 12:12:19 +02:00 · 2019-06-26 12:12:19 +02:00 · 2f7f733628
commit 2f7f733628
parent 782110a824
6 changed files with 125 additions and 46 deletions
--- a/.vscode/tasks.json
+++ b/.vscode/tasks.json
@ -14,6 +14,7 @@
        "reveal": "always",
        "focus": false,
        "panel": "dedicated",
+        "clear": true,
        "showReuseMessage": false
      }
    },
--- a/messages/uniworx/de.msg
+++ b/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
--- a/src/Foundation.hs
+++ b/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]
--- a/src/Handler/Corrections.hs
+++ b/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?
-            [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> do
-              E.where_ $ submission E.^. SubmissionSheet    E.==. E.val sid
-              E.where_ $ E.isNothing $ submission E.^. SubmissionRatingBy   -- no corrector
-              E.where_ $ E.isNothing $ submission E.^. SubmissionRatingTime -- not done
-            guard hasSubmission
-            -- has at least one active corrector?
-            [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do
-              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
+            -- ask for assignment plan
+            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
+                ignoreExceptions NoCorrectors             = return mempty
+                ignoreExceptions NoCorrectorsByProportion = return mempty
+                ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing
+            (plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
+            guard $ not $ null plan -- only proceed if there is a plan for this sheet
+            -- implement assignment plan
            status <- lift $ case btnResult of
              Nothing -> return (Set.empty, Set.empty)
-              (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan -- TODO: this comes to late!!
-            return $ Map.insert shn (status, countMapElems plan) acc
+              (Just BtnSubmissionsAssign) -> do
+                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
--- a/src/Handler/Utils/Submission.hs
+++ b/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))
-                  -- ^ Return map that assigns submissions to Corrector
+                  -> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational)
+                  -- ^ 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
--- a/templates/corrections-overview.hamlet
+++ b/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 >_{MsgNrSubmissionsTotal}
+        <th .table__th rowspan=2>_{MsgNrSubmittorsTotal}
+      <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>_{MsgNrSubmissionsTotal}
-      <th .table__th>_{MsgNrSubmissionsNotCorrected}
+      <th .table__th rowspan=2>_{MsgCorrector}
+      <th .table__th colspan=2>_{MsgGenericAll}
+      <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>#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
-            $nothing
-              <td .table__td>
+            <td .table__td>
+              $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
+                #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
            $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}