format scores

This commit is contained in:
Filip Gralinski 2016-02-17 09:34:34 +01:00
parent b6aad03933
commit c5a2b4e9c3
5 changed files with 38 additions and 15 deletions

View File

@ -119,7 +119,8 @@ checkTestDir chan challengeId challenge commit testDir = do
testName=T.pack $ takeFileName testDir,
testChecksum=(SHA1 checksum),
testCommit=commit,
testActive=True }
testActive=True,
testPrecision=Nothing }
return ()
else
msg chan $ concat ["Test dir ", (T.pack testDir), " does not have expected results."]

View File

@ -33,10 +33,10 @@ getShowChallengeR :: Text -> Handler Html
getShowChallengeR name = do
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
Just repo <- runDB $ get $ challengePublicRepo challenge
leaderboard <- getLeaderboardEntries challengeId
(mainTest, leaderboard) <- getLeaderboardEntries challengeId
mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth
challengeLayout True challenge (showChallengeWidget muserId challenge repo leaderboard)
challengeLayout True challenge (showChallengeWidget muserId challenge mainTest repo leaderboard)
getChallengeReadmeR :: Text -> Handler Html
getChallengeReadmeR name = do
@ -47,7 +47,7 @@ getChallengeReadmeR name = do
contents <- readFile readmeFilePath
challengeLayout False challenge $ toWidget $ markdown def $ TL.fromStrict contents
showChallengeWidget muserId challenge repo leaderboard = $(widgetFile "show-challenge")
showChallengeWidget muserId challenge test repo leaderboard = $(widgetFile "show-challenge")
where leaderboardWithRanks = zip [1..] leaderboard
leaderboardWithRanksAndCurrentUser = map (\e -> (e, muserId)) leaderboardWithRanks
maybeRepoLink = getRepoLink repo

View File

@ -21,6 +21,8 @@ import PersistSHA1
import GEval.Core
import Text.Printf
data LeaderboardEntry = LeaderboardEntry {
leaderboardUser :: User,
leaderboardUserId :: UserId,
@ -35,16 +37,20 @@ submissionsTable challengeName tests = mempty
++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _) -> submitter) . fst)
++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _) -> s) . fst)
++ Table.text "description" (submissionDescription . (\(Entity _ s, _, _) -> s) . fst)
++ mconcat (map (\(Entity k t) -> Table.string (testName t) ((submissionScore k) . fst)) tests)
-- ++ mconcat (map (\(Entity k t) -> Table.string (testName t) ((submissionScore k t) . fst)) tests)
++ mconcat (map (\(Entity k t) -> resultCell t ((extractScore k) . fst)) tests)
++ statusCell challengeName (\((Entity submissionId submission, Entity userId _, _), mauthId) -> (submissionId, submission, userId, mauthId))
leaderboardTable :: Text -> Table App ((Int, LeaderboardEntry), Maybe UserId)
leaderboardTable challengeName = mempty
extractScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation) -> Maybe Evaluation
extractScore k (_, _, m) = lookup k m
leaderboardTable :: Text -> Test -> Table App ((Int, LeaderboardEntry), Maybe UserId)
leaderboardTable challengeName test = mempty
++ Table.int "#" (fst . fst)
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd . fst)
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd . fst)
++ Table.text "description" (submissionDescription . leaderboardBestSubmission . snd . fst)
++ Table.string "result" (presentScore . leaderboardEvaluation . snd . fst)
++ resultCell test ((\e -> Just e) . leaderboardEvaluation . snd . fst)
++ Table.int "×" (leaderboardNumberOfSubmissions . snd . fst)
++ statusCell challengeName (\((_, e), mauthId) -> (leaderboardBestSubmissionId e,
leaderboardBestSubmission e,
@ -63,6 +69,21 @@ timestampCell h timestampFun = hoverTextCell h (Data.Text.pack . shorterFormat .
statusCell :: Text -> (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a
statusCell challengeName fun = Table.widget "" (statusCellWidget challengeName . fun)
resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
resultCell test fun = hoverTextCell ((testName test) ++ "/" ++ (Data.Text.pack $ show $ testMetric test)) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
formatFullScore :: Maybe Evaluation -> Text
formatFullScore (Just evaluation) = fromMaybe "???" (Data.Text.pack <$> show <$> evaluationScore evaluation)
formatFullScore Nothing = "N/A"
formatTruncatedScore :: Maybe Int -> Maybe Evaluation -> Text
formatTruncatedScore Nothing e = formatFullScore e
formatTruncatedScore _ Nothing = formatFullScore Nothing
formatTruncatedScore (Just precision) (Just evaluation) = case evaluationScore evaluation of
Just score -> Data.Text.pack $ printf "%0.*f" precision score
Nothing -> formatFullScore Nothing
statusCellWidget challengeName (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")
where commitHash = fromSHA1ToText $ submissionCommit submission
isPublic = submissionIsPublic submission
@ -94,7 +115,7 @@ getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) e
getLeaderboardEntries :: Key Challenge -> Handler [LeaderboardEntry]
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry])
getLeaderboardEntries challengeId = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId
let mainTestEnt = getMainTest tests
@ -103,7 +124,7 @@ getLeaderboardEntries challengeId = do
let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
let entries = sortBy (flip entryComparator) $ map (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
return entries
return (mainTest, entries)
where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
toEntry mainTest (ui, (u, ss)) = LeaderboardEntry {
leaderboardUser = u,
@ -151,8 +172,8 @@ formatSubmitter user = if userIsAnonymous user
Just name -> name
Nothing -> "[name not given]"
submissionScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation) -> String
submissionScore k (_, _, m) = fromMaybe "N/A" (presentScore <$> lookup k m)
submissionScore :: Key Test -> Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation) -> String
submissionScore k t (_, _, m) = fromMaybe "N/A" (presentScore t <$> lookup k m)
presentScore :: Evaluation -> String
presentScore evaluation = fromMaybe "???" (show <$> evaluationScore evaluation)
presentScore :: Test -> Evaluation -> String
presentScore test evaluation = fromMaybe "???" (show <$> evaluationScore evaluation)

View File

@ -39,6 +39,7 @@ Test
checksum SHA1
commit SHA1
active Bool default=True
precision Int Maybe
UniqueChallengeNameChecksum challenge name checksum
Submission
repo RepoId

View File

@ -5,7 +5,7 @@ $nothing
<h2>Leaderboard
^{Table.buildBootstrap (leaderboardTable (challengeName challenge)) leaderboardWithRanksAndCurrentUser}
^{Table.buildBootstrap (leaderboardTable (challengeName challenge) test) leaderboardWithRanksAndCurrentUser}
<div id="graph-container">