Correction stats coded, but not yet used online

.vscode/tasks.json

@@ -58,6 +58,11 @@
       "type": "npm",
       "script": "start",
       "problemMatcher": []
+    },
+    {
+      "type": "npm",
+      "script": "frontend:lint",
+      "problemMatcher": []
     }
   ]
 }

messages/uniworx/de.msg

@@ -394,14 +394,21 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den
 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
 AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit Anteil ungleich Null eingestellt
 AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden
+NrSubmittorsTotal: Abgebende
 NrSubmissionsTotal: Abgaben
 NrSubmissionsUnassigned: Ohne Korrektor
+NoCorrectorAssigned: Ohne Korrektor
 NrCorrectors: Korrektoren
 NrSubmissionsNewlyAssigned: Neu zugeteilt
 NrSubmissionsNotAssigned: Nicht zugeteilt
+NrSubmissionsNotCorrected: Unkorrigiert
+CorrectionTime: Korrekturdauer (Min/Avg/Max)
 
 CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
 NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
@@ -971,7 +978,7 @@ TutorialDelete: Löschen
 
 CourseTutorials: Übungen
 
-ParticipantsN n@Int: Teilnehmer
+ParticipantsN n@Int: #{tshow n} Teilnehmer
 TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen?
 TutorialDeleted: Tutorium gelöscht
 
@@ -1007,6 +1014,7 @@ HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden w
 HealthSMTPConnect: SMTP-Server kann erreicht werden
 HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
 
+CourseParticipants n@Int: Derzeit #{tshow n} angemeldete Kursteilnehmer
 CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
 CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
 CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}

models/sheets

@@ -4,7 +4,7 @@ Sheet   -- exercise sheet for a given course
     description     Html Maybe
     type            SheetType        -- Does it count towards overall course grade?
     grouping        SheetGroup       -- May participants submit in groups of certain sizes?
-    markingText     Html Maybe       -- Instructions for correctors, included in marking templates
+    markingText     Html Maybe       -- Instructons for correctors, included in marking templates
     visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before
     activeFrom      UTCTime          -- Download of questions and submission is permitted afterwards
     activeTo        UTCTime          -- Submission is only permitted before

src/Handler/Corrections.hs

@@ -5,6 +5,7 @@ import Import
 
 import Jobs
 import Handler.Utils
+import Handler.Utils.Corrections
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
 import Handler.Utils.SheetType
@@ -13,11 +14,11 @@ import Handler.Utils.Delete
 
 import Utils.Lens
 
-import Data.List (nub)
+import Data.List as List (nub, foldl, foldr)
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map, (!))
+import Data.Map.Strict (Map, (!))
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
 
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
@@ -250,7 +251,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
           E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
           return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
-          submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
+          submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
         dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
   dbTable psValidator DBTable
     { dbtSQLQuery
@@ -1035,7 +1036,7 @@ embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
 instance Button UniWorX ButtonSubmissionsAssign where
   btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
 
--- | Gather info about corrector assignment per sheet
+-- | DEPRECATED use CorrectorInfo instead. Gather info about corrector assignment per sheet
 data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int }
 
 getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -1092,3 +1093,134 @@ assignHandler tid ssh csh rawSids = do
       then linkBack  -- TODO: convenience link might be unnecessary: either via breadcrumb or closing model. Remove, if modal works fine. Otherwise change to PrimaryAction?
       else btnForm
 
+
+assignHandler' :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html
+assignHandler' tid ssh csh _rawSids = do
+  -- gather data
+  (nrParticipants, groupsPossible, infoMap, correctorMap) <- runDB $ do
+      cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+      nrParticipants <- count [CourseParticipantCourse ==. cid]
+
+      sheetList <- selectList [SheetCourse ==. cid] [Asc SheetName]
+      let sheets = entities2map sheetList
+          sheetIds = Map.keys sheets
+          groupsPossible :: Bool
+          groupsPossible =
+            let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups
+            in  List.foldr foldFun False sheetList
+
+      correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do
+          E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+          E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
+          return (corrector, user)
+      let correctorMap :: Map UserId (SheetCorrector,User)
+          correctorMap = foldl (\m (Entity _ corr, Entity uid user)-> Map.insert uid (corr,user) m) Map.empty correctors
+
+      submissions <- E.select . E.from $ \submission -> do
+          E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
+          let numSubmittors = E.sub_select . E.from $ \subUser -> do
+                E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
+                return E.countRows
+          return (submission, numSubmittors)
+      -- prepare map
+      let infoMap  :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
+          infoMap  = List.foldl (flip buildS) emptySheets submissions
+
+          -- ensure that all sheets are shown, including those without any submissions
+          emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) Map.empty m) Map.empty sheetIds
+
+          buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo)
+          buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m =
+              let shnm    = sheetName $ sheets ! submissionSheet
+                  corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned
+                  cinf    = Map.singleton submissionRatingBy $ CorrectionInfo
+                            { ciSubmittors  = fromIntegral nrSbmtrs
+                            , ciSubmissions = 1
+                            , ciAssigned    = maybe 0 (const 1) submissionRatingBy
+                            , ciCorrected   = maybe 0 (const 1) submissionRatingTime
+                            , ciCorrector   = submissionRatingBy
+                            , ciMin = corTime
+                            , ciTot = corTime
+                            , ciMax = corTime
+                            }
+              in Map.insertWith (Map.unionWith (<>)) shnm cinf m
+      return (nrParticipants, groupsPossible, infoMap, correctorMap)
+
+  let -- create aggregate maps
+      sheetMap :: Map SheetName CorrectionInfo
+      sheetMap = Map.map fold infoMap
+      corrMap  :: Map (Maybe UserId) CorrectionInfo
+      corrMap  = Map.unionsWith (<>) $ Map.elems infoMap
+      sheetNames = Map.keys infoMap
+  let -- whamlet convenience functions
+      showCorrector :: Maybe UserId -> Widget
+      showCorrector (Just uid)
+        | Just (_,User{..}) <- Map.lookup uid correctorMap
+        = nameEmailWidget userEmail userDisplayName userSurname
+      showCorrector _ = [whamlet|_{MsgNoCorrectorAssigned}|]
+      showDiffDays :: Maybe NominalDiffTime -> Text
+      showDiffDays = foldMap formatDiffDays
+      showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
+      showAvgsDays Nothing   _ = mempty
+      showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
+  let headingShort = MsgMenuCorrectionsAssign
+      headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
+  siteLayoutMsg headingShort $ do
+    setTitleI headingLong
+    -- TODO: Move whamlet into separate Widget-File, once completed
+    [whamlet|
+      <div>
+          <h2>_{MsgCorrectionSheets}
+          _{MsgCourseParticipants nrParticipants}
+          <table .table .table--striped .table--hover>
+            <tr .table__row .table__row--head>
+              <th .table__th>_{MsgSheet}
+              $if groupsPossible
+                <th .table__th>_{MsgNrSubmittorsTotal}
+              <th .table__th>_{MsgNrSubmissionsTotal}
+              <th .table__th>_{MsgNrSubmissionsNotAssigned}
+              <th .table__th>_{MsgNrSubmissionsNotCorrected}
+              <th .table__th colspan=3>_{MsgCorrectionTime}
+            $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}
+                <td .table__td>#{ciSubmissions - ciAssigned}
+                <td .table__td>#{ciSubmissions - ciCorrected}
+                <td .table__td>#{showDiffDays ciMin}
+                <td .table__td>#{showAvgsDays ciTot ciCorrected}
+                <td .table__td>#{showDiffDays ciMax}
+      <div>
+          <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 colspan=3>_{MsgCorrectionTime}
+              $forall shn <- sheetNames
+                <th .table__th colspan=3>#{shn}
+            $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap
+              <tr .table__row>
+                <td .table__td>^{showCorrector ciCorrector}
+                <td .table__td>#{ciSubmissions}
+                <td .table__td>#{ciSubmissions - ciCorrected}
+                <td .table__td>#{showDiffDays ciMin}
+                <td .table__td>#{showAvgsDays ciTot ciCorrected}
+                <td .table__td>#{showDiffDays ciMax}
+                $forall shn <- sheetNames
+                  $maybe smap <- Map.lookup shn infoMap
+                    $maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- Map.lookup ciCorrector smap
+                      <td .table__td>#{ciAssigned}
+                      <td .table__td>#{ciAssigned - ciCorrected}
+                      <td .table__td>#{showAvgsDays ciTot ciCorrected}
+                    $nothing
+                      <td .table__td colspan=3>
+                  $nothing
+                    <td .table__td colspan=3>
+    |]
+
+
+

src/Handler/Tutorial.hs

@@ -136,7 +136,7 @@ postTDeleteR tid ssh csh tutn = do
               return E.countRows
         return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
     , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
-        return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (#{tshow ps} _{MsgParticipantsN ps})|]
+        return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|]
     , drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
         return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
     , drCaption = SomeMessage MsgTutorialDeleteQuestion
@@ -199,7 +199,7 @@ postTCommR tid ssh csh tutn = do
         [E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser ->
           E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid
                E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid
-        
+
         isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False
         isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False
 

src/Handler/Utils/Corrections.hs

@@ -0,0 +1,45 @@
+module Handler.Utils.Corrections where
+
+import Import
+
+
+-- CorrectionInfo has seeming redundancies, but these are useful for aggregation
+-- INVARIANT: isJust ciTot `implies` ciCorrected > 0
+data CorrectionInfo = CorrectionInfo
+      { ciSubmittors, ciSubmissions, ciAssigned, ciCorrected :: Integer
+      , ciCorrector :: Maybe UserId
+      , ciTot, ciMin,  ciMax :: Maybe NominalDiffTime
+      }
+
+instance Semigroup CorrectionInfo where
+  corrA <> corrB =
+        assert (isJust (ciTot corrA) `implies` (ciCorrected corrA > 0)) $
+        assert (isJust (ciTot corrB) `implies` (ciCorrected corrB > 0))
+        CorrectionInfo
+          { ciSubmittors  = ciSubmittors  `mergeWith` (+)
+          , ciSubmissions = ciSubmissions `mergeWith` (+)
+          , ciAssigned    = ciAssigned    `mergeWith` (+)
+          , ciCorrected   = ciCorrected   `mergeWith` (+)
+          , ciCorrector   = ciCorrector   `mergeWith` keepEqual
+          , ciTot         = ciTot `mergeWith` ignoreNothing (+)
+          , ciMin         = ciMin `mergeWith` ignoreNothing min
+          , ciMax         = ciMax `mergeWith` ignoreNothing max
+          }
+    where
+      mergeWith :: (CorrectionInfo -> a) -> (a -> a -> c) -> c
+      mergeWith prj f = on f prj corrA corrB
+
+      keepEqual (Just x) (Just y) | x==y = Just x
+      keepEqual _ _ = Nothing
+
+instance Monoid CorrectionInfo where
+  mappend = (<>)
+  mempty  = CorrectionInfo  { ciSubmittors  = 0
+                            , ciSubmissions = 0
+                            , ciAssigned    = 0
+                            , ciCorrected   = 0
+                            , ciCorrector   = Nothing
+                            , ciMin         = Nothing
+                            , ciTot         = Nothing
+                            , ciMax         = Nothing
+                            }

src/Handler/Utils/DateTime.hs

@@ -2,6 +2,7 @@ module Handler.Utils.DateTime
   ( utcToLocalTime
   , localTimeToUTC, TZ.LocalToUTCResult(..)
   , toMidnight, beforeMidnight, toMidday, toMorning
+  , formatDiffDays
   , formatTime, formatTime', formatTimeW
   , getTimeLocale, getDateTimeFormat
   , validDateTimeFormats, dateTimeFormatOptions
@@ -29,6 +30,37 @@ import qualified Data.Set as Set
 import Data.Time.Clock.System (systemEpochDay)
 
 
+
+--------------------
+-- NominalDiffTime
+
+-- | One hour in 'NominalDiffTime'.
+nominalHour :: NominalDiffTime
+nominalHour = 3600
+
+-- | One minute in 'NominalDiffTime'.
+nominalMinute :: NominalDiffTime
+nominalMinute= 60
+
+formatDiffDays :: NominalDiffTime -> Text
+formatDiffDays t
+  | t > nominalDay    = inDays    <> "d"
+  | t > nominalHour   = inHours   <> "h"
+  | t > nominalMinute = inMinutes <> "m"
+  | otherwise         = tshow $ roundToDigits 0 t
+  where
+    convertBy :: NominalDiffTime -> Double
+    convertBy len = realToFrac $ roundToDigits 1 $ t / len
+    inDays    = tshow $ convertBy nominalDay
+    inHours   = tshow $ convertBy nominalHour
+    inMinutes = tshow $ convertBy nominalMinute
+
+
+
+------------
+-- UTCTime
+
+
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
 
@@ -52,7 +84,6 @@ toMorning :: Day -> UTCTime
 toMorning      d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 6 0 0
 
 
-
 class FormatTime t => HasLocalTime t where
   toLocalTime :: t -> LocalTime
 

src/Utils.hs

@@ -343,6 +343,17 @@ notUsedT = notUsed
 
 
 
+----------
+-- Bool --
+----------
+
+-- | Logical implication, readable synonym for (<=) which appears the wrong way around
+implies :: Bool -> Bool -> Bool
+implies True x = x
+implies _    _ = True
+
+
+
 -------------
 -- Numeric --
 -------------
@@ -523,12 +534,6 @@ flipMaybe :: b -> Maybe a -> Maybe b
 flipMaybe x Nothing  = Just x
 flipMaybe _ (Just _) = Nothing
 
-
-maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap
-maybeAdd (Just x) (Just y) = Just (x + y)
-maybeAdd Nothing y  = y
-maybeAdd x Nothing  = x
-
 -- | Deep alternative to avoid any occurrence of Nothing at all costs, left-biased
 deepAlt :: Maybe (Maybe a) -> Maybe (Maybe a) -> Maybe (Maybe a)
 deepAlt Nothing        altSnd  = altSnd
@@ -574,6 +579,12 @@ mcons :: Maybe a -> [a] -> [a]
 mcons Nothing  xs = xs
 mcons (Just x) xs = x:xs
 
+-- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap
+ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
+ignoreNothing _ Nothing y = y
+ignoreNothing _ x Nothing = x
+ignoreNothing f (Just x) (Just y) = Just $ f x y
+
 newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
 
 instance Eq a  => Eq (NTop (Maybe a)) where