start showing graphs (no edges yet)

This commit is contained in:
Filip Gralinski 2016-02-11 21:54:22 +01:00
parent bdbc55f450
commit f06e104f3d
10 changed files with 118 additions and 6 deletions

View File

@ -37,6 +37,7 @@ import qualified Data.IntMap as IntMap
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
import Handler.Common import Handler.Common
import Handler.Fay import Handler.Fay
import Handler.Graph
import Handler.Home import Handler.Home
import Handler.CreateChallenge import Handler.CreateChallenge
import Handler.ListChallenges import Handler.ListChallenges

81
Handler/Graph.hs Normal file
View File

@ -0,0 +1,81 @@
module Handler.Graph where
import Import
import Handler.Tables
import Data.Maybe
import Data.List ((!!))
getChallengeGraphDataR :: Text -> Handler Value
getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeName
--getChallengeGraphDataR _ = return $ object [ "nodes" .= [node,node']]
submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
submissionsToJSON condition challengeName = do
challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName challengeName
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
let mainTestEnt = getMainTest tests
let (Entity mainTestId mainTest) = mainTestEnt
let auxSubmissions = getAuxSubmissions mainTestId evaluationMaps
let naturalRange = getNaturalRange auxSubmissions
return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ zip [0..] auxSubmissions)]
getNaturalRange auxSubmissions = (2.0 * (interQuantile $ Data.Maybe.catMaybes $ map getScore auxSubmissions))
getScore (_, (_, [])) = Nothing
getScore (_, (_, [(_, evaluation)])) = evaluationScore evaluation
auxSubmissionToNode :: Double -> (Int, (Key User, (User, [(Submission, Evaluation)]))) -> Maybe Value
auxSubmissionToNode _ (_, (_, (_, []))) = Nothing
auxSubmissionToNode naturalRange (n, (_, (_, [(submission, evaluation)]))) = case evaluationScore evaluation of
Just score -> Just $ object [
"id" .= ("n" ++ (show n)),
"x" .= (stampToX $ submissionStamp submission),
"y" .= (- ((score / naturalRange) * 100.0)),
"size" .= (3 :: Int),
"label" .= submissionDescription submission ]
Nothing -> Nothing
stampToX :: UTCTime -> Integer
stampToX = toModifiedJulianDay . utctDay
node :: Value
node = object [
"id" .= ("n0" :: String),
"x" .= (0 :: Int),
"y" .= (0 :: Int),
"size" .= (3 :: Int),
"label" .= ("test" :: String)
]
node' :: Value
node' = object [
"id" .= ("n1" :: String),
"x" .= (5 :: Int),
"y" .= (3 :: Int),
"size" .= (1 :: Int)
]
-- taken from Math.Statistics
interQuantile :: (Fractional b, Ord b) => [b] -> b
interQuantile [] = 10.0
interQuantile xs = (q' - q)
where q = quantile 0.25 xs
q' = quantile 0.75 xs
quantile :: (Fractional b, Ord b) => Double -> [b] -> b
quantile q = quantileAsc q . sort
quantileAsc :: (Fractional b, Ord b) => Double -> [b] -> b
quantileAsc _ [] = error "x"
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
idx | idx < 0 -> error "Quantile index too small"
| idx >= len -> error "Quantile index too large"
| otherwise -> idx

View File

@ -40,12 +40,22 @@ leaderboardTable = mempty
++ Table.string "result" (presentScore . leaderboardEvaluation . snd) ++ Table.string "result" (presentScore . leaderboardEvaluation . snd)
++ Table.int "×" (leaderboardNumberOfSubmissions . snd) ++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
getMainTest :: [Entity Test] -> Entity Test
getMainTest tests = DL.maximumBy (\(Entity _ a) (Entity _ b) -> ((testName a) `compare` (testName b))) tests
getAuxSubmissions :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [(Submission, Evaluation)]))]
getAuxSubmissions testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
where processEvaluationMap testId ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
Just e -> [(s, e)]
Nothing -> []))
getLeaderboardEntries :: Key Challenge -> Handler [LeaderboardEntry] getLeaderboardEntries :: Key Challenge -> Handler [LeaderboardEntry]
getLeaderboardEntries challengeId = do getLeaderboardEntries challengeId = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId (evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId
let mainTestEnt = DL.maximumBy (\(Entity _ a) (Entity _ b) -> ((testName a) `compare` (testName b))) tests let mainTestEnt = getMainTest tests
let (Entity mainTestId mainTest) = mainTestEnt let (Entity mainTestId mainTest) = mainTestEnt
let auxSubmissions = map (processEvaluationMap mainTestId) evaluationMaps let auxSubmissions = getAuxSubmissions mainTestId evaluationMaps
let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b) let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
let entries = sortBy (flip entryComparator) $ map (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser let entries = sortBy (flip entryComparator) $ map (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
@ -57,9 +67,6 @@ getLeaderboardEntries challengeId = do
leaderboardEvaluation = snd bestOne, leaderboardEvaluation = snd bestOne,
leaderboardNumberOfSubmissions = length ss } leaderboardNumberOfSubmissions = length ss }
where bestOne = DL.maximumBy (submissionComparator mainTest) ss where bestOne = DL.maximumBy (submissionComparator mainTest) ss
processEvaluationMap mainTestId ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup mainTestId m of
Just e -> [(s, e)]
Nothing -> []))
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

View File

@ -17,5 +17,6 @@
/challenge-my-submissions/#Text ChallengeMySubmissionsR GET /challenge-my-submissions/#Text ChallengeMySubmissionsR GET
/challenge-all-submissions/#Text ChallengeAllSubmissionsR GET /challenge-all-submissions/#Text ChallengeAllSubmissionsR GET
/challenge-how-to/#Text ChallengeHowToR GET /challenge-how-to/#Text ChallengeHowToR GET
/challenge-graph-data/#Text ChallengeGraphDataR GET
/account YourAccountR GET POST /account YourAccountR GET POST

View File

@ -32,6 +32,7 @@ library
Handler.Common Handler.Common
Handler.CreateChallenge Handler.CreateChallenge
Handler.Fay Handler.Fay
Handler.Graph
Handler.Home Handler.Home
Handler.ListChallenges Handler.ListChallenges
Handler.Shared Handler.Shared

4
static/js/sigma.min.js vendored Normal file

File diff suppressed because one or more lines are too long

1
static/js/sigma.parsers.json.min.js vendored Normal file
View File

@ -0,0 +1 @@
(function(){"use strict";if("undefined"==typeof sigma)throw"sigma is not declared";sigma.utils.pkg("sigma.parsers"),sigma.utils.pkg("sigma.utils"),sigma.utils.xhr=function(){if(window.XMLHttpRequest)return new XMLHttpRequest;var a,b;if(window.ActiveXObject){a=["Msxml2.XMLHTTP.6.0","Msxml2.XMLHTTP.3.0","Msxml2.XMLHTTP","Microsoft.XMLHTTP"];for(b in a)try{return new ActiveXObject(a[b])}catch(c){}}return null},sigma.parsers.json=function(a,b,c){var d,e=sigma.utils.xhr();if(!e)throw"XMLHttpRequest not supported, cannot load the file.";e.open("GET",a,!0),e.onreadystatechange=function(){4===e.readyState&&(d=JSON.parse(e.responseText),b instanceof sigma?(b.graph.clear(),b.graph.read(d)):"object"==typeof b?(b.graph=d,b=new sigma(b)):"function"==typeof b&&(c=b,b=null),c&&c(b||d))},e.send()}}).call(this);

View File

@ -1,3 +1,8 @@
<p>(This is a long list of all submissions, if you want to see only the best, click <a href="@{ShowChallengeR (challengeName challenge)}">leaderboard</a>.) <p>(This is a long list of all submissions, if you want to see only the best, click <a href="@{ShowChallengeR (challengeName challenge)}">leaderboard</a>.)
^{Table.buildBootstrap (submissionsTable tests) submissions} ^{Table.buildBootstrap (submissionsTable tests) submissions}
<div id="graph-container">
<script src="/static/js/sigma.min.js">
<script src="/static/js/sigma.parsers.json.min.js">

View File

@ -0,0 +1,6 @@
sigma.parsers.json("@{ChallengeGraphDataR $ challengeName challenge}", {
container: 'graph-container',
settings: {
defaultNodeColor: '#ec5148'
}
});

View File

@ -9,3 +9,8 @@
overflow: hidden; overflow: hidden;
left-margin: 5px; left-margin: 5px;
} }
#graph-container {
height: 400px;
margin: auto;
}