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

Show all main metrics in the leaderboard

This commit is contained in:
Filip Gralinski 2018-09-08 19:21:06 +02:00
parent e20e8dfa63
commit 20fc29159f
6 changed files with 50 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
Handler/Graph.hs
View File

@ -3,7 +3,7 @@ module Handler.Graph where
import Import
import Handler.Tables
import Handler.Shared (formatParameter, formatScore)
import Handler.Shared (formatParameter, formatScore, getMainTest)
import Data.Maybe
import Data.List ((!!))
import Database.Persist.Sql
@ -23,7 +23,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
test <- runDB $ get404 testId
(entries, tests) <- getChallengeSubmissionInfos (const True) challengeId
(entries, _) <- getChallengeSubmissionInfos (const True) challengeId
let values = map (findParamValue paramName) entries
@ -72,23 +72,29 @@ submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
submissionsToJSON condition challengeName = do
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
(_, entries, _) <- getLeaderboardEntriesByCriterion challengeId
condition
(\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId)
(entries, _) <- getLeaderboardEntriesByCriterion challengeId
condition
(\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId)
let naturalRange = getNaturalRange entries
tests <- runDB $ selectList [TestChallenge ==. challengeId] []
let mainTestId = entityKey $ getMainTest tests
let naturalRange = getNaturalRange mainTestId entries
let submissionIds = map leaderboardBestSubmissionId entries
forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] []
return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ entries),
return $ object [ "nodes" .= (Data.Maybe.catMaybes
$ map (auxSubmissionToNode mainTestId naturalRange)
$ entries),
"edges" .= map forkToEdge forks ]
getNaturalRange :: [LeaderboardEntry] -> Double
getNaturalRange entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (evaluationScore . leaderboardEvaluation) entries)
getNaturalRange :: TestId -> [LeaderboardEntry] -> Double
getNaturalRange testId entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (\entry -> evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId)) entries)
auxSubmissionToNode :: Double -> LeaderboardEntry -> Maybe Value
auxSubmissionToNode naturalRange entry = case evaluationScore $ leaderboardEvaluation entry of
auxSubmissionToNode :: TestId -> Double -> LeaderboardEntry -> Maybe Value
auxSubmissionToNode testId naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId) of
Just score -> Just $ object [
"id" .= (nodeId $ leaderboardBestSubmissionId entry),
"x" .= (stampToX $ submissionStamp $ leaderboardBestSubmission entry),

6
Handler/Presentation.hs
View File

@ -53,11 +53,11 @@ getPresentationDATeCH2017R = do
presentationLayout $(widgetFile "presentation-datech-2017")
getSampleLeaderboard :: Text -> HandlerFor App (WidgetT App IO ())
getSampleLeaderboard :: Text -> HandlerFor App (WidgetFor App ())
getSampleLeaderboard name = do
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
(test, leaderboard, _) <- getLeaderboardEntries challengeId
(leaderboard, (_, tests)) <- getLeaderboardEntries challengeId
let leaderboardWithRanks = zip [1..] (take 10 leaderboard)
app <- getYesod
@ -67,7 +67,7 @@ getSampleLeaderboard name = do
return $ Table.buildBootstrap (leaderboardTable Nothing
(challengeName challenge)
scheme challengeRepo test)
scheme challengeRepo tests)
leaderboardWithRanks
presentationLayout widget = do

2
Handler/Shared.hs
View File

@ -330,7 +330,7 @@ getMainTest tests = DL.maximumBy testComparator tests
-- get all the non-dev tests starting with the one with the highest priorty
-- (or all the tests if there are no non-dev tests)
getMainTests :: [Entity Test] -> [Entity Test]
getMainTests tests = sortBy (flip testComparator) tests'
getMainTests tests = sortBy testComparator tests'
where tests' = if null tests''
then tests
else tests''

9
Handler/ShowChallenge.hs
View File

@ -46,7 +46,7 @@ getShowChallengeR :: Text -> Handler Html
getShowChallengeR name = do
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
Just repo <- runDB $ get $ challengePublicRepo challenge
(mainTest, leaderboard, (entries, tests)) <- getLeaderboardEntries challengeId
(leaderboard, (entries, tests)) <- getLeaderboardEntries challengeId
mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth
@ -60,7 +60,6 @@ getShowChallengeR name = do
challengeLayout True challenge (showChallengeWidget muserId
challenge scheme
challengeRepo
mainTest
repo
leaderboard
params
@ -85,7 +84,6 @@ showChallengeWidget :: Maybe UserId
-> Challenge
-> RepoScheme
-> Repo
-> Test
-> Repo
-> [LeaderboardEntry]
-> [Text]
@ -95,7 +93,6 @@ showChallengeWidget muserId
challenge
scheme
challengeRepo
test
repo
leaderboard
params
@ -104,7 +101,7 @@ showChallengeWidget muserId
where leaderboardWithRanks = zip [1..] leaderboard
maybeRepoLink = getRepoLink repo
delta = Number 4
higherTheBetterArray = getIsHigherTheBetterArray [test]
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
getRepoLink :: Repo -> Maybe Text
getRepoLink repo
@ -589,7 +586,7 @@ challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions
paramGraphsWidget :: Challenge -> [Entity Test] -> [Text] -> WidgetFor App ()
paramGraphsWidget challenge tests params = $(widgetFile "param-graphs")
where chartJSs = getChartJss challenge selectedTests params
selectedTests = getMainTests tests
selectedTests = reverse $ getMainTests tests
getChartJss :: Challenge -> [Entity Test] -> [Text] -> JavascriptUrl (Route App)
getChartJss challenge tests params =

41
Handler/Tables.hs
View File

@ -29,7 +29,7 @@ data LeaderboardEntry = LeaderboardEntry {
leaderboardBestSubmissionId :: SubmissionId,
leaderboardBestVariant :: Variant,
leaderboardBestVariantId :: VariantId,
leaderboardEvaluation :: Evaluation,
leaderboardEvaluationMap :: Map (Key Test) Evaluation,
leaderboardNumberOfSubmissions :: Int,
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)],
leaderboardParams :: [Parameter]
@ -75,13 +75,13 @@ descriptionToBeShown s v params = (submissionDescription s) ++ (Data.Text.pack v
extractScore :: Key Test -> TableEntry -> Maybe Evaluation
extractScore k (TableEntry _ _ _ m _ _) = lookup k m
leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> Test -> Table App (Int, LeaderboardEntry)
leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry)
leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.int "#" fst
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
++ leaderboardDescriptionCell
++ resultCell test ((\e -> Just e) . leaderboardEvaluation . snd)
++ mconcat (map (\(Entity k t) -> resultCell t (extractScoreFromLeaderboardEntry k . snd)) tests)
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
leaderboardBestSubmission e,
@ -90,6 +90,9 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
leaderboardUserId e,
mauthId))
extractScoreFromLeaderboardEntry :: Key Test -> LeaderboardEntry -> Maybe Evaluation
extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry)
leaderboardDescriptionCell :: Table site (a, LeaderboardEntry)
leaderboardDescriptionCell = Table.widget "description" (
\(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry)
@ -137,26 +140,29 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation
getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
-> ((Entity Submission) -> Bool)
-> (TableEntry -> a)
-> Handler (Test, [LeaderboardEntry], ([TableEntry], [Entity Test]))
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntriesByCriterion challengeId condition selector = do
infos@(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
(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])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps
let auxItems = map (\i -> (selector i, [i]))
$ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em)
$ evaluationMaps
let auxItemsMap = Map.fromListWith (++) auxItems
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
entries' <- mapM (toLeaderboardEntry challengeId mainTestEnt)
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestId)
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestId)
entries' <- mapM (toLeaderboardEntry challengeId mainTests)
$ filter (\ll -> not (null ll))
$ map snd
$ Map.toList auxItemsMap
let entries = sortBy (flip entryComparator) entries'
return (mainTest, entries, infos)
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 challengeId (Entity mainTestId mainTest) ss = do
toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry
toLeaderboardEntry challengeId tests ss = do
let bestOne = DL.maximumBy submissionComparator ss
let (TableEntry bestSubmission bestVariant user evals _ _) = bestOne
let bestEvaluation = evals Map.! mainTestId
let submissionId = entityKey bestSubmission
tagEnts <- runDB $ getTags submissionId
@ -173,14 +179,17 @@ toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do
leaderboardBestSubmissionId = entityKey bestSubmission,
leaderboardBestVariant = entityVal bestVariant,
leaderboardBestVariantId = entityKey bestVariant,
leaderboardEvaluation = bestEvaluation,
leaderboardEvaluationMap = evals,
leaderboardNumberOfSubmissions = length allUserSubmissions,
leaderboardTags = tagEnts,
leaderboardParams = map entityVal parameters
}
where submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId))
where (Entity mainTestId mainTest) = getMainTest tests
submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) =
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestId))
(evaluationScore (em2 Map.! mainTestId))
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries :: Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries challengeId =
getLeaderboardEntriesByCriterion challengeId
(const True)

2
templates/show-challenge.hamlet
View File

@ -5,7 +5,7 @@ $nothing
<h2>Leaderboard
^{Table.buildBootstrap (leaderboardTable muserId (challengeName challenge) scheme challengeRepo test) leaderboardWithRanks}
^{Table.buildBootstrap (leaderboardTable muserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks}
<div id="graph-container">