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!
import Handler.Common
import Handler.Fay
import Handler.Graph
import Handler.Home
import Handler.CreateChallenge
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.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

View File

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

View File

@ -32,6 +32,7 @@ library
Handler.Common
Handler.CreateChallenge
Handler.Fay
Handler.Graph
Handler.Home
Handler.ListChallenges
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>.)
^{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

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