visualize forks

This commit is contained in:
Filip Gralinski 2016-02-12 23:21:26 +01:00
parent 8d3f6a01bb
commit 35904ff04f
3 changed files with 40 additions and 26 deletions

View File

@ -5,10 +5,10 @@ import Import
import Handler.Tables
import Data.Maybe
import Data.List ((!!))
import Database.Persist.Sql
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
@ -16,48 +16,48 @@ submissionsToJSON condition challengeName = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
let mainTestEnt = getMainTest tests
let (Entity mainTestId mainTest) = mainTestEnt
let auxSubmissions = getAuxSubmissions mainTestId evaluationMaps
let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps
let naturalRange = getNaturalRange auxSubmissions
return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ zip [0..] auxSubmissions)]
let submissionIds = map (\(Entity k _, _) -> k) $ concat $ map (\(_, (_, p)) -> p) auxSubmissions
forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] []
return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ zip [0..] auxSubmissions),
"edges" .= map forkToEdge forks ]
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 :: Double -> (Int, (Key User, (User, [(Entity Submission, Evaluation)]))) -> Maybe Value
auxSubmissionToNode _ (_, (_, (_, []))) = Nothing
auxSubmissionToNode naturalRange (n, (_, (_, [(submission, evaluation)]))) = case evaluationScore evaluation of
auxSubmissionToNode naturalRange (n, (_, (_, [(Entity submissionId submission, evaluation)]))) = case evaluationScore evaluation of
Just score -> Just $ object [
"id" .= ("n" ++ (show n)),
"id" .= nodeId submissionId,
"x" .= (stampToX $ submissionStamp submission),
"y" .= (- ((score / naturalRange) * 100.0)),
"size" .= (3 :: Int),
"size" .= (2 :: Int),
"label" .= submissionDescription submission ]
Nothing -> Nothing
forkToEdge :: Entity Fork -> Value
forkToEdge (Entity forkId fork) = object [
"source" .= nodeId (forkSource fork),
"target" .= nodeId (forkTarget fork),
"id" .= edgeId forkId,
"type" .= ["arrow" :: String]
]
nodeId :: Key Submission -> String
nodeId = ("n" ++) . show . fromSqlKey
edgeId :: Key Fork -> String
edgeId = ("e" ++) . show . fromSqlKey
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

View File

@ -50,6 +50,16 @@ getAuxSubmissions testId evaluationMaps = map (processEvaluationMap testId) eval
Just e -> [(s, e)]
Nothing -> []))
getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
where processEvaluationMap testId (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

View File

@ -47,6 +47,10 @@ Submission
stamp UTCTime default=now()
submitter UserId
UniqueSubmissionRepoCommitChallenge repo commit challenge
Fork
source SubmissionId
target SubmissionId
UniqueSourceTarget source target
Evaluation
test TestId
checksum SHA1