From 9267bf7f32d060f936b94fafcf1020964e98c4f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Filip=20Grali=C5=84ski?= Date: Mon, 16 Dec 2019 16:39:20 +0100 Subject: [PATCH] Alt alternative leaderboard, fix wrong evaluation --- Handler/Evaluate.hs | 4 ++-- Handler/Graph.hs | 2 +- Handler/Presentation.hs | 2 +- Handler/ShowChallenge.hs | 28 ++++++++++++++++++++++++++-- Handler/Tables.hs | 32 ++++++++++++++++++++++++-------- templates/show-challenge.hamlet | 6 ++++++ 6 files changed, 60 insertions(+), 14 deletions(-) diff --git a/Handler/Evaluate.hs b/Handler/Evaluate.hs index 1331e33..d24b8f2 100644 --- a/Handler/Evaluate.hs +++ b/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 diff --git a/Handler/Graph.hs b/Handler/Graph.hs index ba1737c..921a236 100644 --- a/Handler/Graph.hs +++ b/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]) diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index ea5580b..6beb58a 100644 --- a/Handler/Presentation.hs +++ b/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 diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 697a91c..b7e34e0 100644 --- a/Handler/ShowChallenge.hs +++ b/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 diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 42e87fc..b1e1162 100644 --- a/Handler/Tables.hs +++ b/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 - (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId +getLeaderboardEntriesByCriterion maxPriority challengeId condition selector = do + (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 BySubmitter challengeId = - getLeaderboardEntriesByCriterion challengeId +getLeaderboardEntries :: Int -> LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) +getLeaderboardEntries maxPriority BySubmitter challengeId = + getLeaderboardEntriesByCriterion maxPriority + challengeId (const True) (\entry -> [entityKey $ tableEntrySubmitter entry]) -getLeaderboardEntries ByTag challengeId = - getLeaderboardEntriesByCriterion challengeId +getLeaderboardEntries maxPriority ByTag challengeId = + getLeaderboardEntriesByCriterion maxPriority + challengeId (const True) (noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo) where noEmptyList [] = [Nothing] diff --git a/templates/show-challenge.hamlet b/templates/show-challenge.hamlet index 9e156e4..b7c578e 100644 --- a/templates/show-challenge.hamlet +++ b/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 +