s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects Releases Wiki Activity

generalize toLeaderboardEntries

Browse Source
This commit is contained in:
Filip Graliński 2018-07-24 15:02:37 +02:00
parent 23c2cb0072
commit 92f16f6c5d
1 changed files with 15 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
Handler/Tables.hs
View File

@ -127,33 +127,33 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation
Nothing -> [])) Nothing -> []))
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry]) getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> (TableEntry -> a) -> Handler (Test, [LeaderboardEntry])
getLeaderboardEntries challengeId = do getLeaderboardEntriesByCriterion challengeId selector = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId (evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId
let mainTestEnt = getMainTest tests let mainTestEnt = getMainTest tests
let (Entity mainTestId mainTest) = mainTestEnt let (Entity mainTestId mainTest) = mainTestEnt
let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps let auxItems = map (\i -> (selector i, [i])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps
let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions let auxItemsMap = Map.fromListWith (++) auxItems
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b) let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
entries' <- mapM (toEntry challengeId mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser entries' <- mapM (toLeaderboardEntry challengeId mainTestEnt) $ filter (\ll -> not (null ll)) $ map snd $ Map.toList auxItemsMap
let entries = sortBy (flip entryComparator) entries' let entries = sortBy (flip entryComparator) entries'
return (mainTest, entries) return (mainTest, entries)
toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Entity Test -> t TableEntry -> HandlerFor site LeaderboardEntry
toEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Test -> (Key User, (User, t (Entity Submission, Entity Variant, Evaluation))) -> HandlerFor site LeaderboardEntry toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do
toEntry challengeId mainTest (ui, (u, ss)) = do
let bestOne = DL.maximumBy submissionComparator ss let bestOne = DL.maximumBy submissionComparator ss
let (bestSubmission, bestVariant, bestEvaluation) = bestOne let (TableEntry bestSubmission bestVariant user evals _ _) = bestOne
let bestEvaluation = evals Map.! mainTestId
let submissionId = entityKey bestSubmission let submissionId = entityKey bestSubmission
tagEnts <- runDB $ getTags submissionId tagEnts <- runDB $ getTags submissionId
parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName] parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
-- get all user submissions, including hidden ones -- get all user submissions, including hidden ones
allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. ui] [Desc SubmissionStamp] allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. entityKey user] [Desc SubmissionStamp]
return $ LeaderboardEntry { return $ LeaderboardEntry {
leaderboardUser = u, leaderboardUser = entityVal user,
leaderboardUserId = ui, leaderboardUserId = entityKey user,
leaderboardBestSubmission = entityVal bestSubmission, leaderboardBestSubmission = entityVal bestSubmission,
leaderboardBestSubmissionId = entityKey bestSubmission, leaderboardBestSubmissionId = entityKey bestSubmission,
leaderboardBestVariant = entityVal bestVariant, leaderboardBestVariant = entityVal bestVariant,
@ -163,8 +163,10 @@ toEntry challengeId mainTest (ui, (u, ss)) = do
leaderboardTags = tagEnts, leaderboardTags = tagEnts,
leaderboardParams = map entityVal parameters leaderboardParams = map entityVal parameters
} }
where submissionComparator (_, _, e1) (_, _, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2) where submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId))
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry])
getLeaderboardEntries challengeId = getLeaderboardEntriesByCriterion challengeId (\(TableEntry _ _ (Entity userId _) _ _ _) -> userId)
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y