From 20fc29159fa2306c4137bb5bba2d6427e4a89d7f Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 8 Sep 2018 19:21:06 +0200 Subject: [PATCH] Show all main metrics in the leaderboard --- Handler/Graph.hs | 28 +++++++++++++--------- Handler/Presentation.hs | 6 ++--- Handler/Shared.hs | 2 +- Handler/ShowChallenge.hs | 9 +++----- Handler/Tables.hs | 41 ++++++++++++++++++++------------- templates/show-challenge.hamlet | 2 +- 6 files changed, 50 insertions(+), 38 deletions(-) diff --git a/Handler/Graph.hs b/Handler/Graph.hs index 1daf991..92bd318 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -3,7 +3,7 @@ module Handler.Graph where import Import import Handler.Tables -import Handler.Shared (formatParameter, formatScore) +import Handler.Shared (formatParameter, formatScore, getMainTest) import Data.Maybe import Data.List ((!!)) import Database.Persist.Sql @@ -23,7 +23,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName test <- runDB $ get404 testId - (entries, tests) <- getChallengeSubmissionInfos (const True) challengeId + (entries, _) <- getChallengeSubmissionInfos (const True) challengeId let values = map (findParamValue paramName) entries @@ -72,23 +72,29 @@ submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value submissionsToJSON condition challengeName = do (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName - (_, entries, _) <- getLeaderboardEntriesByCriterion challengeId - condition - (\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId) + (entries, _) <- getLeaderboardEntriesByCriterion challengeId + condition + (\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId) - let naturalRange = getNaturalRange entries + + tests <- runDB $ selectList [TestChallenge ==. challengeId] [] + let mainTestId = entityKey $ getMainTest tests + + let naturalRange = getNaturalRange mainTestId entries let submissionIds = map leaderboardBestSubmissionId entries forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] [] - return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ entries), + return $ object [ "nodes" .= (Data.Maybe.catMaybes + $ map (auxSubmissionToNode mainTestId naturalRange) + $ entries), "edges" .= map forkToEdge forks ] -getNaturalRange :: [LeaderboardEntry] -> Double -getNaturalRange entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (evaluationScore . leaderboardEvaluation) entries) +getNaturalRange :: TestId -> [LeaderboardEntry] -> Double +getNaturalRange testId entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (\entry -> evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId)) entries) -auxSubmissionToNode :: Double -> LeaderboardEntry -> Maybe Value -auxSubmissionToNode naturalRange entry = case evaluationScore $ leaderboardEvaluation entry of +auxSubmissionToNode :: TestId -> Double -> LeaderboardEntry -> Maybe Value +auxSubmissionToNode testId naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId) of Just score -> Just $ object [ "id" .= (nodeId $ leaderboardBestSubmissionId entry), "x" .= (stampToX $ submissionStamp $ leaderboardBestSubmission entry), diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index b4c428b..8e07950 100644 --- a/Handler/Presentation.hs +++ b/Handler/Presentation.hs @@ -53,11 +53,11 @@ getPresentationDATeCH2017R = do presentationLayout $(widgetFile "presentation-datech-2017") -getSampleLeaderboard :: Text -> HandlerFor App (WidgetT App IO ()) +getSampleLeaderboard :: Text -> HandlerFor App (WidgetFor App ()) getSampleLeaderboard name = do (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name - (test, leaderboard, _) <- getLeaderboardEntries challengeId + (leaderboard, (_, tests)) <- getLeaderboardEntries challengeId let leaderboardWithRanks = zip [1..] (take 10 leaderboard) app <- getYesod @@ -67,7 +67,7 @@ getSampleLeaderboard name = do return $ Table.buildBootstrap (leaderboardTable Nothing (challengeName challenge) - scheme challengeRepo test) + scheme challengeRepo tests) leaderboardWithRanks presentationLayout widget = do diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 7021783..7321e2c 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -330,7 +330,7 @@ getMainTest tests = DL.maximumBy testComparator tests -- get all the non-dev tests starting with the one with the highest priorty -- (or all the tests if there are no non-dev tests) getMainTests :: [Entity Test] -> [Entity Test] -getMainTests tests = sortBy (flip testComparator) tests' +getMainTests tests = sortBy testComparator tests' where tests' = if null tests'' then tests else tests'' diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index baabc60..4af0c82 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -46,7 +46,7 @@ getShowChallengeR :: Text -> Handler Html getShowChallengeR name = do (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name Just repo <- runDB $ get $ challengePublicRepo challenge - (mainTest, leaderboard, (entries, tests)) <- getLeaderboardEntries challengeId + (leaderboard, (entries, tests)) <- getLeaderboardEntries challengeId mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth @@ -60,7 +60,6 @@ getShowChallengeR name = do challengeLayout True challenge (showChallengeWidget muserId challenge scheme challengeRepo - mainTest repo leaderboard params @@ -85,7 +84,6 @@ showChallengeWidget :: Maybe UserId -> Challenge -> RepoScheme -> Repo - -> Test -> Repo -> [LeaderboardEntry] -> [Text] @@ -95,7 +93,6 @@ showChallengeWidget muserId challenge scheme challengeRepo - test repo leaderboard params @@ -104,7 +101,7 @@ showChallengeWidget muserId where leaderboardWithRanks = zip [1..] leaderboard maybeRepoLink = getRepoLink repo delta = Number 4 - higherTheBetterArray = getIsHigherTheBetterArray [test] + higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests getRepoLink :: Repo -> Maybe Text getRepoLink repo @@ -589,7 +586,7 @@ challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions paramGraphsWidget :: Challenge -> [Entity Test] -> [Text] -> WidgetFor App () paramGraphsWidget challenge tests params = $(widgetFile "param-graphs") where chartJSs = getChartJss challenge selectedTests params - selectedTests = getMainTests tests + selectedTests = reverse $ getMainTests tests getChartJss :: Challenge -> [Entity Test] -> [Text] -> JavascriptUrl (Route App) getChartJss challenge tests params = diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 45c287b..2a7541c 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -29,7 +29,7 @@ data LeaderboardEntry = LeaderboardEntry { leaderboardBestSubmissionId :: SubmissionId, leaderboardBestVariant :: Variant, leaderboardBestVariantId :: VariantId, - leaderboardEvaluation :: Evaluation, + leaderboardEvaluationMap :: Map (Key Test) Evaluation, leaderboardNumberOfSubmissions :: Int, leaderboardTags :: [(Entity Tag, Entity SubmissionTag)], leaderboardParams :: [Parameter] @@ -75,13 +75,13 @@ descriptionToBeShown s v params = (submissionDescription s) ++ (Data.Text.pack v extractScore :: Key Test -> TableEntry -> Maybe Evaluation extractScore k (TableEntry _ _ _ m _ _) = lookup k m -leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> Test -> Table App (Int, LeaderboardEntry) -leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty +leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry) +leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty ++ Table.int "#" fst ++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd) ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd) ++ leaderboardDescriptionCell - ++ resultCell test ((\e -> Just e) . leaderboardEvaluation . snd) + ++ mconcat (map (\(Entity k t) -> resultCell t (extractScoreFromLeaderboardEntry k . snd)) tests) ++ Table.int "×" (leaderboardNumberOfSubmissions . snd) ++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e, leaderboardBestSubmission e, @@ -90,6 +90,9 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty leaderboardUserId e, mauthId)) +extractScoreFromLeaderboardEntry :: Key Test -> LeaderboardEntry -> Maybe Evaluation +extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry) + leaderboardDescriptionCell :: Table site (a, LeaderboardEntry) leaderboardDescriptionCell = Table.widget "description" ( \(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry) @@ -137,26 +140,29 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> ((Entity Submission) -> Bool) -> (TableEntry -> a) - -> Handler (Test, [LeaderboardEntry], ([TableEntry], [Entity Test])) + -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntriesByCriterion challengeId condition selector = do - infos@(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId + (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId + let mainTests = getMainTests tests let mainTestEnt = getMainTest tests let (Entity mainTestId mainTest) = mainTestEnt - let auxItems = map (\i -> (selector i, [i])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps + let auxItems = map (\i -> (selector i, [i])) + $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) + $ evaluationMaps let auxItemsMap = Map.fromListWith (++) auxItems - let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b) - entries' <- mapM (toLeaderboardEntry challengeId mainTestEnt) + let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestId) + (evaluationScore $ leaderboardEvaluationMap b Map.! mainTestId) + entries' <- mapM (toLeaderboardEntry challengeId mainTests) $ filter (\ll -> not (null ll)) $ map snd $ Map.toList auxItemsMap let entries = sortBy (flip entryComparator) entries' - return (mainTest, entries, infos) + return (entries, (evaluationMaps, mainTests)) -toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Entity Test -> t TableEntry -> HandlerFor site LeaderboardEntry -toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do +toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry +toLeaderboardEntry challengeId tests ss = do let bestOne = DL.maximumBy submissionComparator ss let (TableEntry bestSubmission bestVariant user evals _ _) = bestOne - let bestEvaluation = evals Map.! mainTestId let submissionId = entityKey bestSubmission tagEnts <- runDB $ getTags submissionId @@ -173,14 +179,17 @@ toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do leaderboardBestSubmissionId = entityKey bestSubmission, leaderboardBestVariant = entityVal bestVariant, leaderboardBestVariantId = entityKey bestVariant, - leaderboardEvaluation = bestEvaluation, + leaderboardEvaluationMap = evals, leaderboardNumberOfSubmissions = length allUserSubmissions, leaderboardTags = tagEnts, leaderboardParams = map entityVal parameters } - where submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId)) + where (Entity mainTestId mainTest) = getMainTest tests + submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = + (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) + (evaluationScore (em2 Map.! mainTestId)) -getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry], ([TableEntry], [Entity Test])) +getLeaderboardEntries :: Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntries challengeId = getLeaderboardEntriesByCriterion challengeId (const True) diff --git a/templates/show-challenge.hamlet b/templates/show-challenge.hamlet index cd09f4c..0639e2d 100644 --- a/templates/show-challenge.hamlet +++ b/templates/show-challenge.hamlet @@ -5,7 +5,7 @@ $nothing

Leaderboard -^{Table.buildBootstrap (leaderboardTable muserId (challengeName challenge) scheme challengeRepo test) leaderboardWithRanks} +^{Table.buildBootstrap (leaderboardTable muserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks}