From 2b23600a2287e96e5b482c4e53125a55b64bbb93 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 16 Jul 2019 10:10:21 +0200 Subject: [PATCH] feat(exams): show exam bonus in webinterface --- messages/uniworx/de.msg | 8 +- src/Handler/Exam.hs | 152 +++++++++++++++++-------------- src/Handler/Utils/Exam.hs | 36 ++++++++ src/Handler/Utils/Table/Cells.hs | 3 + src/Model/Types/Sheet.hs | 28 ++++-- src/Utils.hs | 6 ++ 6 files changed, 157 insertions(+), 76 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8d72c3384..783f75491 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -433,7 +433,9 @@ HasCorrector: Korrektor zugeteilt AssignedTime: Zuteilung AchievedBonusPoints: Erreichte Bonuspunkte AchievedNormalPoints: Erreichte Punkte -AchievedPassPoints: Erreichte Punkte +AchievedPoints: Erreichte Punkte +AchievedPassPoints: Erreichte Punkte zum Bestehen +AchievedPasses: Bestandene Blätter AchievedOf achieved@Points possible@Points: #{achieved} von #{possible} PassAchievedOf points@Points passingPoints@Points maxPoints@Points: #{points} von #{maxPoints} (Bestanden ab #{passingPoints}) PassedResult: Ergebnis @@ -1185,4 +1187,6 @@ CsvModifyExisting: Existierende Einträge angleichen CsvAddNew: Neue Einträge einfügen CsvDeleteMissing: Fehlende Einträge entfernen BtnCsvExport: CSV-Datei exportieren -BtnCsvImport: CSV-Datei importieren \ No newline at end of file +BtnCsvImport: CSV-Datei importieren + +Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%) \ No newline at end of file diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 03d92e282..230bb405c 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -831,73 +831,93 @@ instance DefaultOrdered ExamUserTableCsv where getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn - - let - examUsersDBTable = DBTable{..} - where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do - E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField - E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree - E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) - E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) - E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) - E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) - E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence - E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) - dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) - dbtProj = return - dbtColonnade = dbColonnade $ mconcat - [ colUserNameLink (CourseR tid ssh csh . CUserR) - , colUserMatriclenr - , colField resultStudyField - , colDegreeShort resultStudyDegree - , colFeaturesSemester resultStudyFeatures - , sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence - ] - dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserSurname queryUser - , sortUserDisplayName queryUser - , sortUserMatriclenr queryUser - , sortField queryStudyField - , sortDegreeShort queryStudyDegree - , sortFeaturesSemester queryStudyFeatures - , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - ] - dbtFilter = Map.fromList - [ fltrUserNameEmail queryUser - , fltrUserMatriclenr queryUser - , fltrField queryStudyField - , fltrDegree queryStudyDegree - , fltrFeaturesSemester queryStudyFeatures - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - , fltrFieldUI mPrev - , fltrDegreeUI mPrev - , fltrFeaturesSemesterUI mPrev - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "exam-users" - dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv - dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv - <$> view (resultUser . _entityVal . _userSurname) - <*> view (resultUser . _entityVal . _userDisplayName) - <*> view (resultUser . _entityVal . _userMatrikelnummer) - <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) - <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) - <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) - <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - dbtCsvDecode = Nothing + ((), examUsersTable) <- runDB $ do + exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn + bonus <- examBonus exam - examUsersDBTableValidator = def - ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable + let + allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus + showPasses = numSheetsPasses allBoni /= 0 + showPoints = getSum (numSheetsPoints allBoni) - getSum (numSheetsPassPoints allBoni) /= 0 + showPassPoints = numSheetsPassPoints allBoni /= 0 + + let + examUsersDBTable = DBTable{..} + where + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) + E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence + E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) + dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) + dbtProj = return + dbtColonnade = dbColonnade . mconcat $ catMaybes + [ pure $ colUserNameLink (CourseR tid ssh csh . CUserR) + , pure colUserMatriclenr + , pure $ colField resultStudyField + , pure $ colDegreeShort resultStudyDegree + , pure $ colFeaturesSemester resultStudyFeatures + , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus + SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) + , guardOn showPassPoints $ sortable Nothing (i18nCell MsgAchievedPassPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPassPoints} <- examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPassPoints} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPassPoints) (getSum sumSheetsPassPoints) + , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPoints, achievedPassPoints} <- examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPoints, sumSheetsPassPoints} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPoints - getSum achievedPassPoints) (getSum sumSheetsPoints - getSum sumSheetsPassPoints) + ] + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserSurname queryUser + , sortUserDisplayName queryUser + , sortUserMatriclenr queryUser + , sortField queryStudyField + , sortDegreeShort queryStudyDegree + , sortFeaturesSemester queryStudyFeatures + , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + ] + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , fltrField queryStudyField + , fltrDegree queryStudyDegree + , fltrFeaturesSemester queryStudyFeatures + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + , fltrFieldUI mPrev + , fltrDegreeUI mPrev + , fltrFeaturesSemesterUI mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "exam-users" + dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv + dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv + <$> view (resultUser . _entityVal . _userSurname) + <*> view (resultUser . _entityVal . _userDisplayName) + <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) + <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) + <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) + <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) + dbtCsvDecode = Nothing + + examUsersDBTableValidator = def + dbTable examUsersDBTableValidator examUsersDBTable siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 3d1d43845..f3cda795c 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,6 +1,7 @@ module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam + , examBonus, examBonusPossible, examBonusAchieved ) where import Import.NoFoundation @@ -12,6 +13,10 @@ import Database.Esqueleto.Utils.TH import Utils.Lens +import qualified Data.Conduit.List as C + +import qualified Data.Map as Map + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -45,3 +50,34 @@ fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutoria fetchCourseIdExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam) fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn + + +examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary) +examBonus (Entity eId Exam{..}) = runConduit $ + let + rawData = E.selectSource . E.from $ \((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` (sheet `E.InnerJoin` submission)) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do + E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId) + E.on $ E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser + E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId + ) + E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId + E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse + E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId + E.where_ $ E.case_ + [ E.when_ + ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence ) + E.then_ + ( E.just (sheet E.^. SheetActiveTo) E.<=. examOccurrence E.?. ExamOccurrenceStart + E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart + ) + ] + ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom + ) + return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission) + accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) -> + Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub + in rawData .| accum + +examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary +examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap +examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 8262140eb..948febc54 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -214,6 +214,9 @@ maybeDateTimeCell = maybe mempty dateTimeCell numCell :: (IsDBTable m a, Num b, ToMessage b) => b -> DBCell m a numCell = textCell . toMessage +propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a +propCell curr max' = i18nCell $ MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max') + int64Cell :: (IsDBTable m a) => Int64-> DBCell m a int64Cell = numCell diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index b4a6b0a90..4a6c60a32 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -12,6 +12,7 @@ import Model.Types.Common import Utils.Lens.TH import Control.Lens +import Control.Lens.Extras (is) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Set (Set) @@ -40,6 +41,7 @@ deriveJSON defaultOptions derivePersistFieldJSON ''SheetGrading makeLenses_ ''SheetGrading +makePrisms ''SheetGrading _passingBound :: Fold SheetGrading (Either () Points) _passingBound = folding passPts @@ -57,17 +59,22 @@ gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound data SheetGradeSummary = SheetGradeSummary { numSheets :: Count -- Total number of sheets, includes all - , numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses - , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd + , numSheetsPasses :: Count -- Number of sheets admitting passing FKA: numGradePasses + , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd + , numSheetsPassPoints :: Count -- Number of sheets where passing is by points , sumSheetsPoints :: Sum Points -- Total of all points in all sheets + , sumSheetsPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points -- Marking dependend , numMarked :: Count -- Number of already marked sheets , numMarkedPasses :: Count -- Number of already marked sheets with passes , numMarkedPoints :: Count -- Number of already marked sheets with points + , numMarkedPassPoints :: Count -- Number of already marked sheets where passing is by points , sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets + , sumMarkedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points -- , achievedPasses :: Count -- Achieved passes (within marked sheets) , achievedPoints :: Sum Points -- Achieved points (within marked sheets) + , achievedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points } deriving (Generic, Read, Show, Eq) instance Monoid SheetGradeSummary where @@ -82,19 +89,24 @@ makeLenses_ ''SheetGradeSummary sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary sheetGradeSum gr Nothing = mempty { numSheets = 1 - , numSheetsPasses = bool mempty 1 $ has _passingBound gr - , numSheetsPoints = bool mempty 1 $ has _maxPoints gr + , numSheetsPasses = bool mempty 1 $ has _passingBound gr + , numSheetsPoints = bool mempty 1 $ has _maxPoints gr + , numSheetsPassPoints = bool mempty 1 $ is _PassPoints gr , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints + , sumSheetsPassPoints = maybe mempty Sum . (<* guard (is _PassPoints gr)) $ gr ^? _maxPoints } sheetGradeSum gr (Just p) = let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing in unmarked - { numMarked = numSheets - , numMarkedPasses = numSheetsPasses - , numMarkedPoints = numSheetsPoints - , sumMarkedPoints = sumSheetsPoints + { numMarked = numSheets + , numMarkedPasses = numSheetsPasses + , numMarkedPoints = numSheetsPoints + , numMarkedPassPoints = numSheetsPassPoints + , sumMarkedPoints = sumSheetsPoints + , sumMarkedPassPoints = sumSheetsPassPoints , achievedPasses = maybe mempty (bool 0 1) (gradingPassed gr p) , achievedPoints = bool mempty (Sum p) $ has _maxPoints gr + , achievedPassPoints = bool mempty (Sum p) $ is _PassPoints gr } diff --git a/src/Utils.hs b/src/Utils.hs index 96dd4535e..06639a3c1 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -262,6 +262,9 @@ rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy :: HasR rationalToFixed3 :: Rational -> Fixed E3 rationalToFixed3 = rationalToFixed + +rationalToFixed2 :: Rational -> Fixed E2 +rationalToFixed2 = rationalToFixed -- | Convert `part` and `whole` into percentage including symbol -- showing trailing zeroes and to decimal digits @@ -693,6 +696,9 @@ assertM_ f x = guard . f =<< x assertM' :: Alternative m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) +guardOn :: Alternative m => Bool -> a -> m a +guardOn b x = x <$ guard b + -- Some Utility Functions from Agda.Utils.Monad -- | Monadic if-then-else. ifM :: Monad m => m Bool -> m a -> m a -> m a