Add by-tag mode for the leaderboard

This commit is contained in:
Filip Gralinski 2018-09-08 21:21:21 +02:00
parent 20fc29159f
commit 055687506b
6 changed files with 36 additions and 18 deletions

View File

@ -74,7 +74,7 @@ submissionsToJSON condition challengeName = do
(entries, _) <- getLeaderboardEntriesByCriterion challengeId (entries, _) <- getLeaderboardEntriesByCriterion challengeId
condition condition
(\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId) (\(TableEntry (Entity submissionId _) _ _ _ _ _) -> [submissionId])
tests <- runDB $ selectList [TestChallenge ==. challengeId] [] tests <- runDB $ selectList [TestChallenge ==. challengeId] []
@ -91,7 +91,9 @@ submissionsToJSON condition challengeName = do
"edges" .= map forkToEdge forks ] "edges" .= map forkToEdge forks ]
getNaturalRange :: TestId -> [LeaderboardEntry] -> Double getNaturalRange :: TestId -> [LeaderboardEntry] -> Double
getNaturalRange testId entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (\entry -> evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId)) entries) getNaturalRange testId entries = 2.0 * (interQuantile
$ Data.Maybe.catMaybes
$ map (\entry -> evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId)) entries)
auxSubmissionToNode :: TestId -> Double -> LeaderboardEntry -> Maybe Value auxSubmissionToNode :: TestId -> Double -> LeaderboardEntry -> Maybe Value
auxSubmissionToNode testId naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId) of auxSubmissionToNode testId naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId) of
@ -137,7 +139,7 @@ quantileAsc q xs
| q < 0 || q > 1 = error "quantile out of range" | q < 0 || q > 1 = error "quantile out of range"
| otherwise = xs !! (quantIndex (length xs) q) | otherwise = xs !! (quantIndex (length xs) q)
where quantIndex :: Int -> Double -> Int where quantIndex :: Int -> Double -> Int
quantIndex len q = case round $ q * (fromIntegral len - 1) of quantIndex len q' = case round $ q' * (fromIntegral len - 1) of
idx | idx < 0 -> error "Quantile index too small" idx | idx < 0 -> error "Quantile index too small"
| idx >= len -> error "Quantile index too large" | idx >= len -> error "Quantile index too large"
| otherwise -> idx | otherwise -> idx

View File

@ -57,7 +57,7 @@ getSampleLeaderboard :: Text -> HandlerFor App (WidgetFor App ())
getSampleLeaderboard name = do getSampleLeaderboard name = do
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
(leaderboard, (_, tests)) <- getLeaderboardEntries challengeId (leaderboard, (_, tests)) <- getLeaderboardEntries BySubmitter challengeId
let leaderboardWithRanks = zip [1..] (take 10 leaderboard) let leaderboardWithRanks = zip [1..] (take 10 leaderboard)
app <- getYesod app <- getYesod

View File

@ -44,15 +44,17 @@ import Data.List (nub)
getShowChallengeR :: Text -> Handler Html getShowChallengeR :: Text -> Handler Html
getShowChallengeR name = do getShowChallengeR name = do
app <- getYesod
let leaderboardStyle = appLeaderboardStyle $ appSettings app
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
Just repo <- runDB $ get $ challengePublicRepo challenge Just repo <- runDB $ get $ challengePublicRepo challenge
(leaderboard, (entries, tests)) <- getLeaderboardEntries challengeId (leaderboard, (entries, tests)) <- getLeaderboardEntries leaderboardStyle challengeId
mauth <- maybeAuth mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth let muserId = (\(Entity uid _) -> uid) <$> mauth
let params = getNumericalParams entries let params = getNumericalParams entries
app <- getYesod
let scheme = appRepoScheme $ appSettings app let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge challengeRepo <- runDB $ get404 $ challengePublicRepo challenge

View File

@ -139,14 +139,15 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation
getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
-> ((Entity Submission) -> Bool) -> ((Entity Submission) -> Bool)
-> (TableEntry -> a) -> (TableEntry -> [a])
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntriesByCriterion challengeId condition selector = do getLeaderboardEntriesByCriterion challengeId condition selector = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
let mainTests = getMainTests tests let mainTests = getMainTests tests
let mainTestEnt = getMainTest tests let mainTestEnt = getMainTest tests
let (Entity mainTestId mainTest) = mainTestEnt let (Entity mainTestId mainTest) = mainTestEnt
let auxItems = map (\i -> (selector i, [i])) let auxItems = concat
$ map (\i -> map (\s -> (s, [i])) (selector i))
$ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em)
$ evaluationMaps $ evaluationMaps
let auxItemsMap = Map.fromListWith (++) auxItems let auxItemsMap = Map.fromListWith (++) auxItems
@ -156,7 +157,8 @@ getLeaderboardEntriesByCriterion challengeId condition selector = do
$ filter (\ll -> not (null ll)) $ filter (\ll -> not (null ll))
$ map snd $ map snd
$ Map.toList auxItemsMap $ Map.toList auxItemsMap
let entries = sortBy (flip entryComparator) entries' let entries = DL.nubBy (\a b -> leaderboardBestVariantId a == leaderboardBestVariantId b)
$ sortBy (flip entryComparator) entries'
return (entries, (evaluationMaps, mainTests)) return (entries, (evaluationMaps, mainTests))
toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry
@ -189,11 +191,17 @@ toLeaderboardEntry challengeId tests ss = do
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId))
(evaluationScore (em2 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId))
getLeaderboardEntries :: Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries challengeId = getLeaderboardEntries BySubmitter challengeId =
getLeaderboardEntriesByCriterion challengeId getLeaderboardEntriesByCriterion challengeId
(const True) (const True)
(\(TableEntry _ _ (Entity userId _) _ _ _) -> userId) (\(TableEntry _ _ (Entity userId _) _ _ _) -> [userId])
getLeaderboardEntries ByTag challengeId =
getLeaderboardEntriesByCriterion challengeId
(const True)
(noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo)
where noEmptyList [] = [Nothing]
noEmptyList l = map Just l
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

View File

@ -32,6 +32,13 @@ toTagPermissions :: Text -> TagPermissions
toTagPermissions "everybody-can-add-new-tags" = EverybodyCanAddNewTags toTagPermissions "everybody-can-add-new-tags" = EverybodyCanAddNewTags
toTagPermissions _ = OnlyAdminCanAddNewTags toTagPermissions _ = OnlyAdminCanAddNewTags
data LeaderboardStyle = BySubmitter | ByTag
deriving (Eq, Show)
toLeaderboardStyle :: Text -> LeaderboardStyle
toLeaderboardStyle "by-tag" = ByTag
toLeaderboardStyle _ = BySubmitter
-- | Runtime settings to configure this application. These settings can be -- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files, -- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database. -- theoretically even a database.
@ -80,6 +87,7 @@ data AppSettings = AppSettings
, appRepoScheme :: RepoScheme , appRepoScheme :: RepoScheme
, appTagPermissions :: TagPermissions , appTagPermissions :: TagPermissions
, appAutoOpening :: Bool , appAutoOpening :: Bool
, appLeaderboardStyle :: LeaderboardStyle
} }
instance FromJSON AppSettings where instance FromJSON AppSettings where
@ -114,13 +122,10 @@ instance FromJSON AppSettings where
appRepoHost <- o .: "repo-host" appRepoHost <- o .: "repo-host"
scheme <- o .: "repo-scheme" appRepoScheme <- toRepoScheme <$> o .: "repo-scheme"
appRepoScheme <- return $ toRepoScheme scheme appTagPermissions <- toTagPermissions <$> o .: "tag-permissions"
tagPermissions <- o .: "tag-permissions"
appTagPermissions <- return $ toTagPermissions tagPermissions
appAutoOpening <- o .:? "auto-opening" .!= False appAutoOpening <- o .:? "auto-opening" .!= False
appLeaderboardStyle <- toLeaderboardStyle <$> o .: "leaderboard-style"
return AppSettings {..} return AppSettings {..}

View File

@ -12,6 +12,7 @@ repo-host: "_env:REPO_HOST:ssh://gitolite@gonito.net/"
repo-scheme: "_env:REPO_SCHEME:selfhosted" repo-scheme: "_env:REPO_SCHEME:selfhosted"
tag-permissions: "_env:TAG_PERMISSIONS:only-admin-can-add-new-tags" tag-permissions: "_env:TAG_PERMISSIONS:only-admin-can-add-new-tags"
auto-opening: "_env:AUTO_OPENING:false" auto-opening: "_env:AUTO_OPENING:false"
leaderboard-style: "_env:LEADERBOARD_STYLE:by-submitter"
# Optional values with the following production defaults. # Optional values with the following production defaults.
# In development, they default to the inverse. # In development, they default to the inverse.