Preselect items for faster generation of leaderboards

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'
 

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
 

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

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

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

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
+                                 -> Key Challenge
-                                             -> ((Entity Submission) -> Bool)
+                                 -> ((Entity Submission) -> Bool)
-                                             -> (TableEntry -> [a])
+                                 -> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
-                                             -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
+                                 -> (TableEntry -> [a])
-getLeaderboardEntriesByCriterion maxPriority challengeId condition selector = do
+                                 -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
-  (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) challengeId
+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])
+                                -> ([(Int, (Entity Submission, Entity Variant))] -> [(Int, (Entity Submission, Entity Variant))])
-getChallengeSubmissionInfos maxMetricPriority condition variantCondition challengeId = do
+                                -> 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)