Neue Statistik nun auch für Blattübersicht
This commit is contained in:
SJost
parent
16771ae8c5
commit
2ef4bbc014
@ -391,7 +391,8 @@ SheetTypeNormal grading@SheetGrading: Normal
|
||||
SheetTypeInformational grading@SheetGrading: Keine Wertung
|
||||
SheetTypeNotGraded: Unbewertet
|
||||
SheetTypeInfo: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer.
|
||||
SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den normalen Punkten hinzugezählt.
|
||||
SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
|
||||
SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben/Blätter
|
||||
|
||||
SheetTypeBonus': Bonus
|
||||
SheetTypeNormal': Normal
|
||||
|
||||
@ -102,6 +102,10 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
shn = sheetName $ entityVal sheet
|
||||
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
|
||||
|
||||
colSheetType :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty
|
||||
@ -383,23 +387,6 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
let route = CSubmissionR tid ssh csh shn cID SAssignR
|
||||
(== Authorized) <$> evalAccessDB route True
|
||||
|
||||
gradeSummaryWidget :: SheetTypeSummary -> Widget
|
||||
gradeSummaryWidget sts =
|
||||
let SheetTypeSummary{..} = addBonusToPoints sts
|
||||
sumSummaries = (normalSummary <> bonusSummary <> informationalSummary) -- # _numSheets %~ (<> numNotGraded)
|
||||
hasPassings = positiveSum $ numGradePasses sumSummaries
|
||||
hasPoints = positiveSum $ sumGradePoints sumSummaries
|
||||
rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow")
|
||||
| (sumHeader,summary) <-
|
||||
[ (MsgSheetTypeNormal' ,normalSummary)
|
||||
, (MsgSheetTypeBonus' ,bonusSummary)
|
||||
, (MsgSheetTypeInformational' ,informationalSummary)
|
||||
] ]
|
||||
in if 0 == numSheets sumSummaries
|
||||
then mempty
|
||||
else $(widgetFile "widgets/gradingSummary")
|
||||
|
||||
|
||||
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
|
||||
|
||||
downloadAction :: ActionCorrections'
|
||||
@ -448,6 +435,7 @@ postCorrectionsR = do
|
||||
, colAssigned
|
||||
, colRating
|
||||
, colRated
|
||||
, colSheetType
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
@ -468,6 +456,7 @@ postCCorrectionsR tid ssh csh = do
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSubmissionLink
|
||||
, colSheetType
|
||||
, colRating
|
||||
, colRated
|
||||
, colCorrector
|
||||
@ -782,6 +771,7 @@ postCorrectionsGradeR = do
|
||||
, colSheet
|
||||
, colPseudonyms
|
||||
, colSubmissionLink
|
||||
, colSheetType
|
||||
, colRated
|
||||
, colRatedField
|
||||
, colPointsField
|
||||
|
||||
@ -41,7 +41,7 @@ import qualified Data.Map as Map
|
||||
|
||||
import Data.Map (Map, (!?))
|
||||
|
||||
import Data.Monoid (Sum(..), Any(..))
|
||||
import Data.Monoid (Any(..))
|
||||
|
||||
-- import Control.Lens
|
||||
import Utils.Lens
|
||||
@ -152,7 +152,8 @@ getSheetListR tid ssh csh = do
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return (sheet, lastSheetEdit sheet, submission)
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ sortable (Just "name") (i18nCell MsgSheet)
|
||||
[ -- TODO: dbRow add numbers
|
||||
sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
|
||||
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
|
||||
$ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
|
||||
@ -228,7 +229,7 @@ getSheetListR tid ssh csh = do
|
||||
, dbtIdent = "sheets" :: Text
|
||||
}
|
||||
-- Collect summary over all Sheets, not just the ones shown due to pagination:
|
||||
SheetTypeSummary{..} <- do
|
||||
statistics <- gradeSummaryWidget <$> do
|
||||
rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
|
||||
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
||||
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
||||
@ -236,7 +237,6 @@ getSheetListR tid ssh csh = do
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
|
||||
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
|
||||
let statistics = $(widgetFile "widgets/sheetTypeSummary")
|
||||
defaultLayout $ do
|
||||
$(widgetFile "sheetList")
|
||||
|
||||
|
||||
@ -12,6 +12,7 @@ module Handler.Utils.Rating
|
||||
, parseRating
|
||||
, SubmissionContent
|
||||
, extractRatings
|
||||
, gradeSummaryWidget
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -32,6 +33,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
||||
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
||||
|
||||
import Data.Monoid (Sum(..))
|
||||
|
||||
import Text.Read (readEither)
|
||||
|
||||
import System.FilePath
|
||||
@ -51,7 +54,7 @@ instance Pretty x => Pretty (CI x) where
|
||||
pretty = pretty . CI.original
|
||||
|
||||
|
||||
instance Pretty SheetGrading where
|
||||
instance Pretty SheetGrading where
|
||||
pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String)
|
||||
pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
|
||||
pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
|
||||
@ -59,12 +62,12 @@ instance Pretty SheetGrading where
|
||||
|
||||
validateRating :: SheetType -> Rating' -> [RatingException]
|
||||
validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
|
||||
| rp < 0
|
||||
= [RatingNegative]
|
||||
| NotGraded <- ratingSheetType
|
||||
| rp < 0
|
||||
= [RatingNegative]
|
||||
| NotGraded <- ratingSheetType
|
||||
= [RatingNotExpected]
|
||||
| (Just maxPoints ) <- ratingSheetType ^? _grading . _maxPoints
|
||||
, rp > maxPoints
|
||||
, rp > maxPoints
|
||||
= [RatingExceedsMax]
|
||||
| (Just PassBinary) <- ratingSheetType ^? _grading
|
||||
, not (rp == 0 || rp == 1)
|
||||
@ -98,7 +101,7 @@ getRating submissionId = runMaybeT $ do
|
||||
, E.unValue -> ratingComment
|
||||
, E.unValue -> ratingTime
|
||||
) ] <- lift query
|
||||
|
||||
|
||||
return Rating{ ratingValues = Rating'{..}, .. }
|
||||
|
||||
formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString
|
||||
@ -199,3 +202,35 @@ isRatingFile' (takeFileName -> fName)
|
||||
= Just cID
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
-- TODO: maybe move elsewhere, but Model is a bit overful already
|
||||
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
|
||||
addBonusToPoints sts =
|
||||
sts & _normalSummary . _achievedPoints %~ maxBonusPts . addBonusPts
|
||||
& _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
|
||||
where
|
||||
bonusPoints = sts ^. _bonusSummary . _achievedPoints
|
||||
maxPoints = sts ^. _normalSummary . _sumGradePoints
|
||||
maxBonusPts = fmap $ min maxPoints
|
||||
addBonusPts = maybeAdd bonusPoints
|
||||
|
||||
bonusPasses = sts ^. _bonusSummary . _achievedPasses
|
||||
maxPasses = sts ^. _normalSummary . _numGradePasses
|
||||
maxBonusPass = fmap $ min maxPasses
|
||||
addBonusPass = maybeAdd bonusPasses
|
||||
|
||||
gradeSummaryWidget :: SheetTypeSummary -> Widget
|
||||
gradeSummaryWidget sts =
|
||||
let SheetTypeSummary{..} = addBonusToPoints sts
|
||||
sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
|
||||
hasPassings = positiveSum $ numGradePasses sumSummaries
|
||||
hasPoints = positiveSum $ sumGradePoints sumSummaries
|
||||
rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow")
|
||||
| (sumHeader,summary) <-
|
||||
[ (MsgSheetTypeNormal' ,normalSummary)
|
||||
, (MsgSheetTypeBonus' ,bonusSummary)
|
||||
, (MsgSheetTypeInformational' ,informationalSummary)
|
||||
] ]
|
||||
in if 0 == numSheets sumSummaries
|
||||
then mempty
|
||||
else $(widgetFile "widgets/gradingSummary")
|
||||
|
||||
@ -183,7 +183,7 @@ instance Default (PSValidator m x) where
|
||||
Just pi -> swap . (\act -> execRWS act pi def) $ do
|
||||
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
|
||||
asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
|
||||
|
||||
|
||||
l <- asks piLimit
|
||||
case l of
|
||||
Just l'
|
||||
@ -258,7 +258,7 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
|
||||
|
||||
data DBCell m x :: *
|
||||
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
|
||||
|
||||
|
||||
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
-- | Format @DBTable@ when sort-circuiting
|
||||
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
|
||||
@ -284,7 +284,7 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
|
||||
dbCell = iso
|
||||
(\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
|
||||
(uncurry WidgetCell)
|
||||
|
||||
|
||||
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||
dbWidget _ _ = return . snd
|
||||
dbHandler _ _ f = return . over _2 f
|
||||
@ -331,7 +331,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
dbCell = iso
|
||||
(\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
|
||||
(\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
|
||||
|
||||
|
||||
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
||||
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
||||
dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
|
||||
@ -353,10 +353,10 @@ addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragmen
|
||||
instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
|
||||
mempty = FormCell mempty (return mempty)
|
||||
(FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
|
||||
|
||||
|
||||
instance IsDBTable m a => IsString (DBCell m a) where
|
||||
fromString = cell . fromString
|
||||
|
||||
|
||||
|
||||
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
|
||||
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
|
||||
@ -378,7 +378,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
, fieldView = error "multiTextField: should not be rendered"
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
|
||||
piResult <- lift . runInputGetResult $ PaginationInput
|
||||
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
||||
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
|
||||
@ -571,6 +571,7 @@ formCell genIndex genForm input = FormCell
|
||||
|
||||
-- Predefined colonnades
|
||||
|
||||
--Number column?
|
||||
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
|
||||
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
|
||||
|
||||
|
||||
@ -2,8 +2,6 @@ module Model.Rating where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Model
|
||||
import Utils
|
||||
import Control.Lens
|
||||
-- import Data.Text (Text)
|
||||
import Data.Text.Encoding.Error (UnicodeException(..))
|
||||
import GHC.Generics (Generic)
|
||||
@ -36,19 +34,3 @@ data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to p
|
||||
deriving (Show, Eq, Generic, Typeable)
|
||||
|
||||
instance Exception RatingException
|
||||
|
||||
-- TODO: maybe move elsewhere, but Model is a bit overful already
|
||||
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
|
||||
addBonusToPoints sts =
|
||||
sts & _normalSummary . _achievedPoints %~ maxBonusPts . addBonusPts
|
||||
& _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
|
||||
where
|
||||
bonusPoints = sts ^. _bonusSummary . _achievedPoints
|
||||
maxPoints = sts ^. _normalSummary . _sumGradePoints
|
||||
maxBonusPts = fmap $ min maxPoints
|
||||
addBonusPts = maybeAdd bonusPoints
|
||||
|
||||
bonusPasses = sts ^. _bonusSummary . _achievedPasses
|
||||
maxPasses = sts ^. _normalSummary . _numGradePasses
|
||||
maxBonusPass = fmap $ min maxPasses
|
||||
addBonusPass = maybeAdd bonusPasses
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
$# Displays gradings Summary for various purposes
|
||||
$# --
|
||||
<div>
|
||||
<h3>_{MsgSheetGradingSummaryTitle $ getSum $ numSheets $ sumSummaries}
|
||||
<table .table .table--striped>
|
||||
<tr .table__row .table__row--head>
|
||||
<th>
|
||||
@ -23,7 +24,9 @@ $# --
|
||||
<td .table__td>#{display nrNoGrade}
|
||||
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
|
||||
<p>_{MsgSheetTypeInfo}
|
||||
<p>_{MsgSheetGradingBonusIncluded}
|
||||
$maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
|
||||
<p>_{MsgSheetGradingBonusIncluded}
|
||||
$nothing
|
||||
$#TODO: MsgSheetTypeInfo into part about Bonus and about Informational
|
||||
$maybe _ <- positiveSum $ informationalSummary ^. _numSheets
|
||||
<p>_{MsgSheetTypeInfo}
|
||||
Loading…
Reference in New Issue
Block a user