filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

graph shows challenges with variants correctly

Browse Source
This commit is contained in:
Filip Graliński 2018-07-24 15:21:20 +02:00
parent 92f16f6c5d
commit 3c157290b9
2 changed files with 17 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
Handler/Graph.hs
View File

@ -14,34 +14,28 @@ getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeN
submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
submissionsToJSON condition challengeName = do submissionsToJSON condition challengeName = do
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
let mainTestEnt = getMainTest tests (_, entries) <- getLeaderboardEntriesByCriterion challengeId condition (\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId)
let (Entity mainTestId _) = mainTestEnt
let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps let naturalRange = getNaturalRange entries
let naturalRange = getNaturalRange auxSubmissions let submissionIds = map leaderboardBestSubmissionId entries
let submissionIds = map (\(Entity k _, _, _) -> k) $ concat $ map (\(_, (_, p)) -> p) auxSubmissions
forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] [] forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] []
return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ zip [0..] auxSubmissions), return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ zip [0..] entries),
"edges" .= map forkToEdge forks ] "edges" .= map forkToEdge forks ]
getNaturalRange :: [(a1, (a2, [(a3, a4, Evaluation)]))] -> Double getNaturalRange :: [LeaderboardEntry] -> Double
getNaturalRange auxSubmissions = (2.0 * (interQuantile $ Data.Maybe.catMaybes $ map getScore auxSubmissions)) getNaturalRange entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (evaluationScore . leaderboardEvaluation) entries)
getScore :: (a1, (a2, [(a3, a4, Evaluation)])) -> Maybe Double auxSubmissionToNode :: Double -> (Int, LeaderboardEntry) -> Maybe Value
getScore (_, (_, [])) = Nothing auxSubmissionToNode naturalRange (n, entry) = case evaluationScore $ leaderboardEvaluation entry of
getScore (_, (_, [(_, _, evaluation)])) = evaluationScore evaluation
auxSubmissionToNode :: Double -> (Int, (Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))) -> Maybe Value
auxSubmissionToNode _ (_, (_, (_, []))) = Nothing
auxSubmissionToNode naturalRange (n, (_, (_, [(Entity submissionId submission, Entity variantId _, evaluation)]))) = case evaluationScore evaluation of
Just score -> Just $ object [ Just score -> Just $ object [
"id" .= nodeId submissionId, "id" .= (nodeId $ leaderboardBestSubmissionId entry),
"x" .= (stampToX $ submissionStamp submission), "x" .= (stampToX $ submissionStamp $ leaderboardBestSubmission entry),
"y" .= (- ((score / naturalRange) * 100.0)), "y" .= (- ((score / naturalRange) * 100.0)),
"size" .= (2 :: Int), "size" .= (2 :: Int),
"label" .= submissionDescription submission ] "label" .= submissionDescription (leaderboardBestSubmission entry) ]
Nothing -> Nothing Nothing -> Nothing
forkToEdge :: Entity Fork -> Value forkToEdge :: Entity Fork -> Value

8
Handler/Tables.hs
View File

@ -127,9 +127,9 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation
Nothing -> [])) Nothing -> []))
getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> (TableEntry -> a) -> Handler (Test, [LeaderboardEntry]) getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> ((Entity Submission) -> Bool) -> (TableEntry -> a) -> Handler (Test, [LeaderboardEntry])
getLeaderboardEntriesByCriterion challengeId selector = do getLeaderboardEntriesByCriterion challengeId condition selector = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
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])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps let auxItems = map (\i -> (selector i, [i])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps
@ -166,7 +166,7 @@ toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do
where submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId)) where submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId))
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry]) getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry])
getLeaderboardEntries challengeId = getLeaderboardEntriesByCriterion challengeId (\(TableEntry _ _ (Entity userId _) _ _ _) -> userId) getLeaderboardEntries challengeId = getLeaderboardEntriesByCriterion challengeId (const True) (\(TableEntry _ _ (Entity userId _) _ _ _) -> userId)
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