diff --git a/Handler/Graph.hs b/Handler/Graph.hs index 92bd318..d62d2dc 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -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 diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index 8e07950..12ef208 100644 --- a/Handler/Presentation.hs +++ b/Handler/Presentation.hs @@ -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 diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 4af0c82..2229c57 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -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 diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 2a7541c..9e982b8 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -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 diff --git a/Settings.hs b/Settings.hs index 53a90df..e0922c6 100644 --- a/Settings.hs +++ b/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 {..} diff --git a/config/settings.yml b/config/settings.yml index ba1ed44..8c306e1 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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.