Preselect items for faster generation of leaderboards
This commit is contained in:
parent
13b2ab7169
commit
00f2c4567a
@ -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'
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user