Show all main metrics in the leaderboard

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
+  (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 :: TestId -> [LeaderboardEntry] -> Double
-getNaturalRange entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (evaluationScore . leaderboardEvaluation) entries)
+getNaturalRange testId entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (\entry -> evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId)) entries)
 
-auxSubmissionToNode :: Double -> LeaderboardEntry -> Maybe Value
+auxSubmissionToNode :: TestId -> Double -> LeaderboardEntry -> Maybe Value
-auxSubmissionToNode naturalRange entry = case evaluationScore $ leaderboardEvaluation entry of
+auxSubmissionToNode testId naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId) of
   Just score ->  Just $ object [
     "id" .= (nodeId $ leaderboardBestSubmissionId entry),
     "x"  .= (stampToX $ submissionStamp $ leaderboardBestSubmission entry),

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

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''

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 =

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 :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry)
-leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
+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)
+  let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestId)
-  entries' <- mapM (toLeaderboardEntry challengeId mainTestEnt)
+                                                     (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 :: (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 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)

templates/show-challenge.hamlet

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