Add by-tag mode for the leaderboard
This commit is contained in:
Filip Gralinski
parent
20fc29159f
commit
055687506b
|
|
@ -74,7 +74,7 @@ submissionsToJSON condition challengeName = do
|
|||
|
||||
(entries, _) <- getLeaderboardEntriesByCriterion challengeId
|
||||
condition
|
||||
(\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId)
|
||||
(\(TableEntry (Entity submissionId _) _ _ _ _ _) -> [submissionId])
|
||||
|
||||
|
||||
tests <- runDB $ selectList [TestChallenge ==. challengeId] []
|
||||
|
|
@ -91,7 +91,9 @@ submissionsToJSON condition challengeName = do
|
|||
"edges" .= map forkToEdge forks ]
|
||||
|
||||
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 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"
|
||||
| otherwise = xs !! (quantIndex (length xs) q)
|
||||
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 >= len -> error "Quantile index too large"
|
||||
| otherwise -> idx
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ getSampleLeaderboard :: Text -> HandlerFor App (WidgetFor App ())
|
|||
getSampleLeaderboard name = do
|
||||
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
|
||||
|
||||
(leaderboard, (_, tests)) <- getLeaderboardEntries challengeId
|
||||
(leaderboard, (_, tests)) <- getLeaderboardEntries BySubmitter challengeId
|
||||
let leaderboardWithRanks = zip [1..] (take 10 leaderboard)
|
||||
|
||||
app <- getYesod
|
||||
|
|
|
|||
|
|
@ -44,15 +44,17 @@ import Data.List (nub)
|
|||
|
||||
getShowChallengeR :: Text -> Handler Html
|
||||
getShowChallengeR name = do
|
||||
app <- getYesod
|
||||
let leaderboardStyle = appLeaderboardStyle $ appSettings app
|
||||
|
||||
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
|
||||
Just repo <- runDB $ get $ challengePublicRepo challenge
|
||||
(leaderboard, (entries, tests)) <- getLeaderboardEntries challengeId
|
||||
(leaderboard, (entries, tests)) <- getLeaderboardEntries leaderboardStyle challengeId
|
||||
mauth <- maybeAuth
|
||||
let muserId = (\(Entity uid _) -> uid) <$> mauth
|
||||
|
||||
let params = getNumericalParams entries
|
||||
|
||||
app <- getYesod
|
||||
let scheme = appRepoScheme $ appSettings app
|
||||
|
||||
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
||||
|
|
|
|||
|
|
@ -139,14 +139,15 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation
|
|||
|
||||
getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
|
||||
-> ((Entity Submission) -> Bool)
|
||||
-> (TableEntry -> a)
|
||||
-> (TableEntry -> [a])
|
||||
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
|
||||
getLeaderboardEntriesByCriterion challengeId condition selector = do
|
||||
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
|
||||
let mainTests = getMainTests tests
|
||||
let mainTestEnt = getMainTest tests
|
||||
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)
|
||||
$ evaluationMaps
|
||||
let auxItemsMap = Map.fromListWith (++) auxItems
|
||||
|
|
@ -156,7 +157,8 @@ getLeaderboardEntriesByCriterion challengeId condition selector = do
|
|||
$ filter (\ll -> not (null ll))
|
||||
$ map snd
|
||||
$ 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))
|
||||
|
||||
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))
|
||||
(evaluationScore (em2 Map.! mainTestId))
|
||||
|
||||
getLeaderboardEntries :: Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
|
||||
getLeaderboardEntries challengeId =
|
||||
getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
|
||||
getLeaderboardEntries BySubmitter challengeId =
|
||||
getLeaderboardEntriesByCriterion challengeId
|
||||
(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 (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y
|
||||
|
|
|
|||
17
Settings.hs
17
Settings.hs
|
|
@ -32,6 +32,13 @@ toTagPermissions :: Text -> TagPermissions
|
|||
toTagPermissions "everybody-can-add-new-tags" = EverybodyCanAddNewTags
|
||||
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
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
-- theoretically even a database.
|
||||
|
|
@ -80,6 +87,7 @@ data AppSettings = AppSettings
|
|||
, appRepoScheme :: RepoScheme
|
||||
, appTagPermissions :: TagPermissions
|
||||
, appAutoOpening :: Bool
|
||||
, appLeaderboardStyle :: LeaderboardStyle
|
||||
}
|
||||
|
||||
instance FromJSON AppSettings where
|
||||
|
|
@ -114,13 +122,10 @@ instance FromJSON AppSettings where
|
|||
|
||||
appRepoHost <- o .: "repo-host"
|
||||
|
||||
scheme <- o .: "repo-scheme"
|
||||
appRepoScheme <- return $ toRepoScheme scheme
|
||||
|
||||
tagPermissions <- o .: "tag-permissions"
|
||||
appTagPermissions <- return $ toTagPermissions tagPermissions
|
||||
|
||||
appRepoScheme <- toRepoScheme <$> o .: "repo-scheme"
|
||||
appTagPermissions <- toTagPermissions <$> o .: "tag-permissions"
|
||||
appAutoOpening <- o .:? "auto-opening" .!= False
|
||||
appLeaderboardStyle <- toLeaderboardStyle <$> o .: "leaderboard-style"
|
||||
|
||||
return AppSettings {..}
|
||||
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ repo-host: "_env:REPO_HOST:ssh://gitolite@gonito.net/"
|
|||
repo-scheme: "_env:REPO_SCHEME:selfhosted"
|
||||
tag-permissions: "_env:TAG_PERMISSIONS:only-admin-can-add-new-tags"
|
||||
auto-opening: "_env:AUTO_OPENING:false"
|
||||
leaderboard-style: "_env:LEADERBOARD_STYLE:by-submitter"
|
||||
|
||||
# Optional values with the following production defaults.
|
||||
# In development, they default to the inverse.
|
||||
|
|
|
|||
Loading…
Reference in New Issue