forked from filipg/gonito
82 lines
2.8 KiB
Haskell
82 lines
2.8 KiB
Haskell
|
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
|