start showing graphs (no edges yet)

Application.hs

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

Handler/Graph.hs

@@ -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

Handler/Tables.hs

@@ -40,12 +40,22 @@ leaderboardTable = mempty
   ++ Table.string "result" (presentScore . leaderboardEvaluation . 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 challengeId = do
   (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 auxSubmissions = map (processEvaluationMap mainTestId) evaluationMaps
+  let auxSubmissions = getAuxSubmissions mainTestId evaluationMaps
   let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
   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
@@ -57,9 +67,6 @@ getLeaderboardEntries challengeId = do
               leaderboardEvaluation = snd bestOne,
               leaderboardNumberOfSubmissions = length 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 (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y

config/routes

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

gonito.cabal

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

static/js/sigma.parsers.json.min.js

@@ -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);

templates/challenge-all-submissions.hamlet

@@ -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>.)
 
 ^{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">

templates/challenge-all-submissions.julius

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

templates/challenge.lucius

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