From 23c2cb0072a5a4cc916b48bf45789bb1501a8086 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Filip=20Grali=C5=84ski?= Date: Tue, 24 Jul 2018 14:08:47 +0200 Subject: [PATCH] show variant information at leaderboard --- Handler/Graph.hs | 14 ++++++++------ Handler/Tables.hs | 47 ++++++++++++++++++++++++++--------------------- 2 files changed, 34 insertions(+), 27 deletions(-) diff --git a/Handler/Graph.hs b/Handler/Graph.hs index 010b706..0a51ec1 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -13,27 +13,29 @@ getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeN submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value submissionsToJSON condition challengeName = do - challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName challengeName + (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId let mainTestEnt = getMainTest tests - let (Entity mainTestId mainTest) = mainTestEnt + let (Entity mainTestId _) = mainTestEnt let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps let naturalRange = getNaturalRange auxSubmissions - let submissionIds = map (\(Entity k _, _) -> k) $ concat $ map (\(_, (_, p)) -> p) auxSubmissions + let submissionIds = map (\(Entity k _, _, _) -> k) $ concat $ map (\(_, (_, p)) -> p) auxSubmissions forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] [] return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ zip [0..] auxSubmissions), "edges" .= map forkToEdge forks ] +getNaturalRange :: [(a1, (a2, [(a3, a4, Evaluation)]))] -> Double getNaturalRange auxSubmissions = (2.0 * (interQuantile $ Data.Maybe.catMaybes $ map getScore auxSubmissions)) +getScore :: (a1, (a2, [(a3, a4, Evaluation)])) -> Maybe Double getScore (_, (_, [])) = Nothing -getScore (_, (_, [(_, evaluation)])) = evaluationScore evaluation +getScore (_, (_, [(_, _, evaluation)])) = evaluationScore evaluation -auxSubmissionToNode :: Double -> (Int, (Key User, (User, [(Entity Submission, Evaluation)]))) -> Maybe Value +auxSubmissionToNode :: Double -> (Int, (Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))) -> Maybe Value auxSubmissionToNode _ (_, (_, (_, []))) = Nothing -auxSubmissionToNode naturalRange (n, (_, (_, [(Entity submissionId submission, evaluation)]))) = case evaluationScore evaluation of +auxSubmissionToNode naturalRange (n, (_, (_, [(Entity submissionId submission, Entity variantId _, evaluation)]))) = case evaluationScore evaluation of Just score -> Just $ object [ "id" .= nodeId submissionId, "x" .= (stampToX $ submissionStamp submission), diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 75aa56e..4d9d77c 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -27,9 +27,12 @@ data LeaderboardEntry = LeaderboardEntry { leaderboardUserId :: UserId, leaderboardBestSubmission :: Submission, leaderboardBestSubmissionId :: SubmissionId, + leaderboardBestVariant :: Variant, + leaderboardBestVariantId :: VariantId, leaderboardEvaluation :: Evaluation, leaderboardNumberOfSubmissions :: Int, - leaderboardTags :: [(Entity Tag, Entity SubmissionTag)] + leaderboardTags :: [(Entity Tag, Entity SubmissionTag)], + leaderboardParams :: [Parameter] } data TableEntry = TableEntry (Entity Submission) @@ -82,7 +85,11 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty leaderboardDescriptionCell :: Table site (a, LeaderboardEntry) leaderboardDescriptionCell = Table.widget "description" ( - \(_,entry) -> fragmentWithSubmissionTags (submissionDescription $ leaderboardBestSubmission entry) (leaderboardTags entry)) + \(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry) + (leaderboardBestVariant entry) + (leaderboardParams entry)) + (leaderboardTags entry) + ) @@ -113,22 +120,13 @@ statusCellWidget challengeName repoScheme challengeRepo (submissionId, submissio else Nothing -getAuxSubmissions :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [(Submission, Evaluation)]))] -getAuxSubmissions testId evaluationMaps = map processEvaluationMap evaluationMaps - where processEvaluationMap ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of - Just e -> [(s, e)] - Nothing -> [])) - - -getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [((Entity Submission), Evaluation)]))] +getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))] getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps - where processEvaluationMap (TableEntry s _ (Entity ui u) m _ _) = (ui, (u, case Map.lookup testId m of - Just e -> [(s, e)] + where processEvaluationMap (TableEntry s v (Entity ui u) m _ _) = (ui, (u, case Map.lookup testId m of + Just e -> [(s, v, e)] Nothing -> [])) - - getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry]) getLeaderboardEntries challengeId = do (evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId @@ -142,23 +140,30 @@ getLeaderboardEntries challengeId = do return (mainTest, entries) -toEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Test -> (Key User, (User, t (Entity Submission, Evaluation))) -> HandlerFor site LeaderboardEntry +toEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Test -> (Key User, (User, t (Entity Submission, Entity Variant, Evaluation))) -> HandlerFor site LeaderboardEntry toEntry challengeId mainTest (ui, (u, ss)) = do let bestOne = DL.maximumBy submissionComparator ss - let submissionId = entityKey $ fst bestOne + let (bestSubmission, bestVariant, bestEvaluation) = bestOne + let submissionId = entityKey bestSubmission tagEnts <- runDB $ getTags submissionId + + parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName] + -- get all user submissions, including hidden ones allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. ui] [Desc SubmissionStamp] return $ LeaderboardEntry { leaderboardUser = u, leaderboardUserId = ui, - leaderboardBestSubmission = (\(Entity _ s) -> s) $ fst bestOne, - leaderboardBestSubmissionId = (\(Entity si _) -> si) $ fst bestOne, - leaderboardEvaluation = snd bestOne, + leaderboardBestSubmission = entityVal bestSubmission, + leaderboardBestSubmissionId = entityKey bestSubmission, + leaderboardBestVariant = entityVal bestVariant, + leaderboardBestVariantId = entityKey bestVariant, + leaderboardEvaluation = bestEvaluation, leaderboardNumberOfSubmissions = length allUserSubmissions, - leaderboardTags = tagEnts + leaderboardTags = tagEnts, + leaderboardParams = map entityVal parameters } - where submissionComparator (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2) + where submissionComparator (_, _, e1) (_, _, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2) compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering