Preselect items for faster generation of leaderboards

This commit is contained in:
Filip Gralinski 2020-01-04 10:32:52 +01:00
parent 13b2ab7169
commit 00f2c4567a
6 changed files with 28 additions and 16 deletions

View File

@ -251,7 +251,7 @@ getOngoingTargets challengeId = do
return indicator return indicator
indicatorEntries <- mapM indicatorToEntry indicators indicatorEntries <- mapM indicatorToEntry indicators
theNow <- liftIO $ getCurrentTime 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 let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries
return indicatorEntries' return indicatorEntries'

View File

@ -33,7 +33,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do
test <- runDB $ get404 testId test <- runDB $ get404 testId
let testRef = getTestReference (Entity testId test) 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 let values = map (findParamValue paramName) entries
@ -85,6 +85,7 @@ submissionsToJSON condition challengeName = do
(entries, _) <- getLeaderboardEntriesByCriterion 1 challengeId (entries, _) <- getLeaderboardEntriesByCriterion 1 challengeId
condition condition
onlyTheBestVariant
(\entry -> [entityKey $ tableEntrySubmission entry]) (\entry -> [entityKey $ tableEntrySubmission entry])
@ -162,7 +163,7 @@ getIndicatorGraphDataR indicatorId = do
test <- runDB $ get404 testId test <- runDB $ get404 testId
let mPrecision = testPrecision test 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 theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line

View File

@ -36,7 +36,7 @@ getPresentation4RealR = do
(Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) 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' let evaluationMaps = take 10 evaluationMaps'
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName sampleLeaderboard <- getSampleLeaderboard sampleChallengeName
@ -57,7 +57,7 @@ getPresentationPSNC2019R = do
(Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) 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' let evaluationMaps = take 10 evaluationMaps'
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName sampleLeaderboard <- getSampleLeaderboard sampleChallengeName

View File

@ -189,6 +189,7 @@ getViewVariantR variantId = do
([entry], tests') <- runDB $ getChallengeSubmissionInfos 3 ([entry], tests') <- runDB $ getChallengeSubmissionInfos 3
(\e -> entityKey e == theSubmissionId) (\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId) (\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission) (submissionChallenge theSubmission)
let tests = sortBy (flip testComparator) tests' let tests = sortBy (flip testComparator) tests'
@ -299,6 +300,7 @@ resultTable (Entity submissionId submission) = do
$ getChallengeSubmissionInfos 2 $ getChallengeSubmissionInfos 2
(\s -> entityKey s == submissionId) (\s -> entityKey s == submissionId)
(const True) (const True)
id
(submissionChallenge submission) (submissionChallenge submission)
let paramNames = let paramNames =
nub nub

View File

@ -461,7 +461,7 @@ checkIndicators user challengeId submissionId submissionLink relevantIndicators
checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler () checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do 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) mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler () 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 :: ((Entity Submission) -> Bool) -> Text -> Handler Html
getChallengeSubmissions condition name = do getChallengeSubmissions condition name = do
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name 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' let tests = sortBy testComparator tests'
mauth <- maybeAuth mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth let muserId = (\(Entity uid _) -> uid) <$> mauth

View File

@ -241,12 +241,13 @@ compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM)
<> (aP `compare` bP) <> (aP `compare` bP)
getLeaderboardEntriesByCriterion :: (Ord a) => Int 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 mainTests = getMainTests tests
let mainTestEnt = getMainTest tests let mainTestEnt = getMainTest tests
let mainTestRef = getTestReference mainTestEnt let mainTestRef = getTestReference mainTestEnt
@ -320,11 +321,13 @@ getLeaderboardEntries maxPriority BySubmitter challengeId =
getLeaderboardEntriesByCriterion maxPriority getLeaderboardEntriesByCriterion maxPriority
challengeId challengeId
(const True) (const True)
onlyTheBestVariant
(\entry -> [entityKey $ tableEntrySubmitter entry]) (\entry -> [entityKey $ tableEntrySubmitter entry])
getLeaderboardEntries maxPriority ByTag challengeId = getLeaderboardEntries maxPriority ByTag challengeId =
getLeaderboardEntriesByCriterion maxPriority getLeaderboardEntriesByCriterion maxPriority
challengeId challengeId
(const True) (const True)
onlyTheBestVariant
(noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo) (noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo)
where noEmptyList [] = [Nothing] where noEmptyList [] = [Nothing]
noEmptyList l = map Just l noEmptyList l = map Just l
@ -335,6 +338,9 @@ compareResult _ (Just _) Nothing = GT
compareResult _ Nothing (Just _) = LT compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ 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, getChallengeSubmissionInfos :: (MonadIO m,
PersistQueryRead backend, PersistQueryRead backend,
BackendCompatible SqlBackend backend, BackendCompatible SqlBackend backend,
@ -342,8 +348,10 @@ getChallengeSubmissionInfos :: (MonadIO m,
=> Int => Int
-> (Entity Submission -> Bool) -> (Entity Submission -> Bool)
-> (Entity Variant -> 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 challenge <- get404 challengeId
let commit = challengeVersion challenge let commit = challengeVersion challenge
@ -361,7 +369,8 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition challen
scores <- mapM (getScore (entityKey mainTest)) $ map (entityKey . snd) allSubmissionsVariants scores <- mapM (getScore (entityKey mainTest)) $ map (entityKey . snd) allSubmissionsVariants
let allSubmissionsVariantsWithRanks = 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` `thenCmp`
(r2 `compare` r1)) (r2 `compare` r1))
$ filter (\(_, (s, _)) -> condition s) $ filter (\(_, (s, _)) -> condition s)