Add by-tag mode for the leaderboard

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

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

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

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 :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
-getLeaderboardEntries challengeId =
+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

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             <- 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
+        appLeaderboardStyle       <- toLeaderboardStyle <$> o .: "leaderboard-style"
 
         return AppSettings {..}
 

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.