From 00f2c4567afbec97711ce2cbd132c7e34da24445 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 4 Jan 2020 10:32:52 +0100 Subject: [PATCH] Preselect items for faster generation of leaderboards --- Handler/Dashboard.hs | 2 +- Handler/Graph.hs | 5 +++-- Handler/Presentation.hs | 4 ++-- Handler/Query.hs | 2 ++ Handler/ShowChallenge.hs | 4 ++-- Handler/Tables.hs | 27 ++++++++++++++++++--------- 6 files changed, 28 insertions(+), 16 deletions(-) diff --git a/Handler/Dashboard.hs b/Handler/Dashboard.hs index e26e86e..8845f08 100644 --- a/Handler/Dashboard.hs +++ b/Handler/Dashboard.hs @@ -251,7 +251,7 @@ getOngoingTargets challengeId = do return indicator indicatorEntries <- mapM indicatorToEntry indicators theNow <- liftIO $ getCurrentTime - (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) id challengeId let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries return indicatorEntries' diff --git a/Handler/Graph.hs b/Handler/Graph.hs index 921a236..7f01015 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -33,7 +33,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do test <- runDB $ get404 testId let testRef = getTestReference (Entity testId test) - (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) id challengeId let values = map (findParamValue paramName) entries @@ -85,6 +85,7 @@ submissionsToJSON condition challengeName = do (entries, _) <- getLeaderboardEntriesByCriterion 1 challengeId condition + onlyTheBestVariant (\entry -> [entityKey $ tableEntrySubmission entry]) @@ -162,7 +163,7 @@ getIndicatorGraphDataR indicatorId = do test <- runDB $ get404 testId let mPrecision = testPrecision test - (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) (testChallenge test) + (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) id (testChallenge test) theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index 1a68e6d..0d80f03 100644 --- a/Handler/Presentation.hs +++ b/Handler/Presentation.hs @@ -36,7 +36,7 @@ getPresentation4RealR = do (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) - (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId + (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) onlyTheBestVariant challengeId let evaluationMaps = take 10 evaluationMaps' sampleLeaderboard <- getSampleLeaderboard sampleChallengeName @@ -57,7 +57,7 @@ getPresentationPSNC2019R = do (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) - (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId + (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos 1 condition (const True) onlyTheBestVariant challengeId let evaluationMaps = take 10 evaluationMaps' sampleLeaderboard <- getSampleLeaderboard sampleChallengeName diff --git a/Handler/Query.hs b/Handler/Query.hs index 60f8267..7f17615 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -189,6 +189,7 @@ getViewVariantR variantId = do ([entry], tests') <- runDB $ getChallengeSubmissionInfos 3 (\e -> entityKey e == theSubmissionId) (\e -> entityKey e == variantId) + id (submissionChallenge theSubmission) let tests = sortBy (flip testComparator) tests' @@ -299,6 +300,7 @@ resultTable (Entity submissionId submission) = do $ getChallengeSubmissionInfos 2 (\s -> entityKey s == submissionId) (const True) + id (submissionChallenge submission) let paramNames = nub diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index b7e34e0..9def0cf 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -461,7 +461,7 @@ checkIndicators user challengeId submissionId submissionLink relevantIndicators checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler () checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do - (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (\(Entity sid _) -> sid == submissionId) (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (\(Entity sid _) -> sid == submissionId) (const True) id challengeId mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator) checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler () @@ -559,7 +559,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html getChallengeSubmissions condition name = do Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name - (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) challengeId + (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId let tests = sortBy testComparator tests' mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 72e01e1..2fdad4e 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -241,12 +241,13 @@ compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM) <> (aP `compare` bP) getLeaderboardEntriesByCriterion :: (Ord a) => Int - -> Key Challenge - -> ((Entity Submission) -> Bool) - -> (TableEntry -> [a]) - -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) -getLeaderboardEntriesByCriterion maxPriority challengeId condition selector = do - (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) challengeId + -> Key Challenge + -> ((Entity Submission) -> Bool) + -> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))]) + -> (TableEntry -> [a]) + -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) +getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector selector = do + (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) preselector challengeId let mainTests = getMainTests tests let mainTestEnt = getMainTest tests let mainTestRef = getTestReference mainTestEnt @@ -320,11 +321,13 @@ getLeaderboardEntries maxPriority BySubmitter challengeId = getLeaderboardEntriesByCriterion maxPriority challengeId (const True) + onlyTheBestVariant (\entry -> [entityKey $ tableEntrySubmitter entry]) getLeaderboardEntries maxPriority ByTag challengeId = getLeaderboardEntriesByCriterion maxPriority challengeId (const True) + onlyTheBestVariant (noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo) where noEmptyList [] = [Nothing] noEmptyList l = map Just l @@ -335,6 +338,9 @@ compareResult _ (Just _) Nothing = GT compareResult _ Nothing (Just _) = LT compareResult _ Nothing Nothing = EQ +onlyTheBestVariant :: [(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))] +onlyTheBestVariant = DL.nubBy (\(_, (Entity aid _, _)) (_, (Entity bid _, _)) -> aid == bid) -- assumes items sorted by rank + getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, @@ -342,8 +348,10 @@ getChallengeSubmissionInfos :: (MonadIO m, => Int -> (Entity Submission -> Bool) -> (Entity Variant -> Bool) - -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test]) -getChallengeSubmissionInfos maxMetricPriority condition variantCondition challengeId = do + -> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))]) + -> Key Challenge + -> ReaderT backend m ([TableEntry], [Entity Test]) +getChallengeSubmissionInfos maxMetricPriority condition variantCondition preselector challengeId = do challenge <- get404 challengeId let commit = challengeVersion challenge @@ -361,7 +369,8 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition challen scores <- mapM (getScore (entityKey mainTest)) $ map (entityKey . snd) allSubmissionsVariants let allSubmissionsVariantsWithRanks = - sortBy (\(r1, (s1, _)) (r2, (s2, _)) -> (submissionStamp (entityVal s2) `compare` submissionStamp (entityVal s1)) + preselector + $ sortBy (\(r1, (s1, _)) (r2, (s2, _)) -> (submissionStamp (entityVal s2) `compare` submissionStamp (entityVal s1)) `thenCmp` (r2 `compare` r1)) $ filter (\(_, (s, _)) -> condition s)