Alt alternative leaderboard, fix wrong evaluation

Handler/Evaluate.hs

@@ -217,7 +217,7 @@ checkOrInsertEvaluation repoDir chan version out = do
       msg chan $ "Start evaluation..."
       challengeDir <- getRepoDir $ challengePrivateRepo challenge
       variant <- runDB $ get404 $ outVariant out
-      resultOrException <- liftIO $ rawEval challengeDir (evaluationSchemeMetric $ testMetric test) repoDir (testName test) ((T.unpack $ variantName variant) <.> "tsv")
+      resultOrException <- liftIO $ rawEval challengeDir (testMetric test) repoDir (testName test) ((T.unpack $ variantName variant) <.> "tsv")
       case resultOrException of
         Right (Left _) -> do
           err chan "Cannot parse options, check the challenge repo"
@@ -240,7 +240,7 @@ checkOrInsertEvaluation repoDir chan version out = do
           err chan $ "Evaluation failed: " ++ (T.pack $ show exception)
 
 rawEval :: FilePath
-          -> Metric
+          -> EvaluationScheme
           -> FilePath
           -> Text
           -> FilePath

Handler/Graph.hs

@@ -83,7 +83,7 @@ submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
 submissionsToJSON condition challengeName = do
   (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
 
-  (entries, _) <- getLeaderboardEntriesByCriterion challengeId
+  (entries, _) <- getLeaderboardEntriesByCriterion 1 challengeId
                                                   condition
                                                   (\entry -> [entityKey $ tableEntrySubmission entry])
 

Handler/Presentation.hs

@@ -81,7 +81,7 @@ getSampleLeaderboard :: Text -> HandlerFor App (WidgetFor App ())
 getSampleLeaderboard name = do
   (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
 
-  (leaderboard, (_, tests)) <- getLeaderboardEntries BySubmitter challengeId
+  (leaderboard, (_, tests)) <- getLeaderboardEntries 1 BySubmitter challengeId
   let leaderboardWithRanks = zip [1..] (take 10 leaderboard)
 
   app <- getYesod

Handler/ShowChallenge.hs

@@ -61,7 +61,18 @@ getShowChallengeR name = do
 
   challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
   Just repo <- runDB $ get $ challengePublicRepo challenge
-  (leaderboard, (entries, tests)) <- getLeaderboardEntries leaderboardStyle challengeId
+  (leaderboard, (entries, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
+
+  showAltLeaderboard <- runDB $ hasMetricsOfSecondPriority challengeId
+
+  (altLeaderboard, altTests) <- if showAltLeaderboard
+                               then
+                                do
+                                 (leaderboard', (_, tests')) <- getLeaderboardEntries 2 ByTag challengeId
+                                 return $ (Just leaderboard', Just tests')
+                               else
+                                 return (Nothing, Nothing)
+
   mauth <- maybeAuth
 
   let params = getNumericalParams entries
@@ -76,8 +87,16 @@ getShowChallengeR name = do
                                                       challengeRepo
                                                       repo
                                                       leaderboard
+                                                      altLeaderboard
                                                       params
-                                                      tests)
+                                                      tests
+                                                      altTests)
+
+hasMetricsOfSecondPriority challengeId = do
+  tests' <- selectList [TestChallenge ==. challengeId, TestActive ==. True] []
+  let tests = filter (\t -> (evaluationSchemePriority $ testMetric $ entityVal t) == 2) tests'
+  return $ not (null tests)
+
 
 getChallengeReadmeR :: Text -> Handler Html
 getChallengeReadmeR name = do
@@ -100,8 +119,10 @@ showChallengeWidget :: Maybe (Entity User)
                       -> Repo
                       -> Repo
                       -> [LeaderboardEntry]
+                      -> (Maybe [LeaderboardEntry])
                       -> [Text]
                       -> [Entity Test]
+                      -> (Maybe [Entity Test])
                       -> WidgetFor App ()
 showChallengeWidget mUserEnt
                     (Entity challengeId challenge)
@@ -109,10 +130,13 @@ showChallengeWidget mUserEnt
                     challengeRepo
                     repo
                     leaderboard
+                    mAltLeaderboard
                     params
                     tests
+                    mAltTests
   = $(widgetFile "show-challenge")
   where leaderboardWithRanks = zip [1..] leaderboard
+        mAltLeaderboardWithRanks = zip [1..] <$> mAltLeaderboard
         maybeRepoLink = getRepoLink repo
         delta = Number 4
         higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests

Handler/Tables.hs

@@ -132,6 +132,19 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
                                        leaderboardUserId e,
                                        mauthId))
 
+altLeaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry)
+altLeaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
+  ++ Table.int "#" fst
+  ++ leaderboardDescriptionCell mauthId
+  ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests)
+  ++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
+                                       leaderboardBestSubmission e,
+                                       leaderboardBestVariantId e,
+                                       leaderboardBestVariant e,
+                                       leaderboardUserId e,
+                                       mauthId))
+
+
 extractScoreFromLeaderboardEntry :: TestReference -> LeaderboardEntry -> Maybe Evaluation
 extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry)
 
@@ -219,12 +232,13 @@ compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM)
                                             <> (aN `compare` bN)
                                             <> (aP `compare` bP)
 
-getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
+getLeaderboardEntriesByCriterion :: (Ord a) => Int
+                                             -> Key Challenge
                                              -> ((Entity Submission) -> Bool)
                                              -> (TableEntry -> [a])
                                              -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
-getLeaderboardEntriesByCriterion challengeId condition selector = do
+getLeaderboardEntriesByCriterion maxPriority challengeId condition selector = do
-  (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId
+  (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) challengeId
   let mainTests = getMainTests tests
   let mainTestEnt = getMainTest tests
   let mainTestRef = getTestReference mainTestEnt
@@ -293,13 +307,15 @@ toLeaderboardEntry challengeId tests ss = do
              <>
              (compareVersions v1 v2)
 
-getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
+getLeaderboardEntries :: Int -> LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
-getLeaderboardEntries BySubmitter challengeId =
+getLeaderboardEntries maxPriority BySubmitter challengeId =
-  getLeaderboardEntriesByCriterion challengeId
+  getLeaderboardEntriesByCriterion maxPriority
+                                   challengeId
                                    (const True)
                                    (\entry -> [entityKey $ tableEntrySubmitter entry])
-getLeaderboardEntries ByTag challengeId =
+getLeaderboardEntries maxPriority ByTag challengeId =
-  getLeaderboardEntriesByCriterion challengeId
+  getLeaderboardEntriesByCriterion maxPriority
+                                   challengeId
                                    (const True)
                                    (noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo)
   where noEmptyList [] = [Nothing]

templates/show-challenge.hamlet

@@ -21,6 +21,12 @@ $if (checkIfAdmin mUserEnt)
 
 ^{Table.buildBootstrap (leaderboardTable mUserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks}
 
+$maybe altLeaderboardWithRanks <- mAltLeaderboardWithRanks
+  $maybe altTests <- mAltTests
+    ^{Table.buildBootstrap (altLeaderboardTable mUserId (challengeName challenge) scheme challengeRepo altTests) altLeaderboardWithRanks}
+  $nothing
+$nothing
+
 <div id="graph-container">
 
 <script src="/static/js/sigma.min.js">