gonito/Handler/Graph.hs

135 lines
5.3 KiB
Haskell
Raw Normal View History

2016-02-11 21:54:22 +01:00
module Handler.Graph where
import Import
import Handler.Tables
2018-07-28 17:04:27 +02:00
import Handler.Shared (getMainTest, formatParameter)
2016-02-11 21:54:22 +01:00
import Data.Maybe
import Data.List ((!!))
2016-02-12 23:21:26 +01:00
import Database.Persist.Sql
2018-07-28 17:04:27 +02:00
import GEval.Core (MetricValue)
import qualified Data.Map as M
2016-02-11 21:54:22 +01:00
getChallengeGraphDataR :: Text -> Handler Value
getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeName
2018-07-28 17:04:27 +02:00
data ParamGraphItem = ParamGraphItem TableEntry Text Text MetricValue
data ParamGraphSeries = ParamGraphSeries Text [(TableEntry, Text, MetricValue)]
getChallengeParamGraphDataR :: Text -> (Key Test) -> Text -> Handler Value
getChallengeParamGraphDataR challengeName testId paramName = do
2018-07-28 17:04:27 +02:00
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
(entries, tests) <- getChallengeSubmissionInfos (const True) challengeId
let values = map (findParamValue paramName) entries
let items = Data.Maybe.catMaybes $ map (toParamGraphItem testId paramName) $ zip entries values
2018-07-28 17:04:27 +02:00
let series = map (\(label, rs) -> ParamGraphSeries label rs)
$ organizeBy
$ map (\(ParamGraphItem entry label x y) -> (label, (entry, x, y))) items
return $ object [
"xs" .= object (map (\(ParamGraphSeries seriesName _) -> (seriesName .= (xSeriesName seriesName))) series),
"columns" .= ((map toYColumn series) ++ (map toXColumn series))
]
toYColumn :: ParamGraphSeries -> [Text]
toYColumn (ParamGraphSeries seriesName items) =
seriesName : (map (\(_,_,v) -> pack $ show v) items)
toXColumn :: ParamGraphSeries -> [Text]
toXColumn (ParamGraphSeries seriesName items) =
(xSeriesName seriesName) : (map (\(_,x,_) -> x) items)
xSeriesName :: Text -> Text
xSeriesName = (++ "_x")
organizeBy :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
organizeBy pList = M.toList $ M.fromListWith (++) $ map (\(x, y) -> (x, [y])) pList
toParamGraphItem :: TestId -> Text -> (TableEntry, Maybe Text) -> Maybe ParamGraphItem
toParamGraphItem _ _ (_, Nothing) = Nothing
toParamGraphItem tid paramName (entry, Just val) = (ParamGraphItem entry label val) <$> join y
where label = unwords (tagsFormatted ++ paramsFormatted)
tagsFormatted =
map (tagName . entityVal . fst)
$ tableEntryTagsInfo entry
paramsFormatted =
map formatParameter
$ filter (\pe -> parameterName pe /= paramName)
$ map entityVal $ tableEntryParams entry
y = evaluationScore <$> lookup tid (tableEntryMapping entry)
findParamValue :: Text -> TableEntry -> Maybe Text
findParamValue paramName entry =
(parameterValue . entityVal) <$> (find (\e -> parameterName (entityVal e) == paramName) $ tableEntryParams entry)
2018-07-26 22:01:21 +02:00
2016-02-11 21:54:22 +01:00
submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
submissionsToJSON condition challengeName = do
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
(_, entries) <- getLeaderboardEntriesByCriterion challengeId condition (\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId)
let naturalRange = getNaturalRange entries
let submissionIds = map leaderboardBestSubmissionId entries
2016-02-12 23:21:26 +01:00
forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] []
2018-07-24 15:36:24 +02:00
return $ object [ "nodes" .= (Data.Maybe.catMaybes $ map (auxSubmissionToNode naturalRange) $ entries),
2016-02-12 23:21:26 +01:00
"edges" .= map forkToEdge forks ]
2016-02-11 21:54:22 +01:00
getNaturalRange :: [LeaderboardEntry] -> Double
getNaturalRange entries = 2.0 * (interQuantile $ Data.Maybe.catMaybes $ map (evaluationScore . leaderboardEvaluation) entries)
2016-02-11 21:54:22 +01:00
2018-07-24 15:36:24 +02:00
auxSubmissionToNode :: Double -> LeaderboardEntry -> Maybe Value
auxSubmissionToNode naturalRange entry = case evaluationScore $ leaderboardEvaluation entry of
2016-02-11 21:54:22 +01:00
Just score -> Just $ object [
"id" .= (nodeId $ leaderboardBestSubmissionId entry),
"x" .= (stampToX $ submissionStamp $ leaderboardBestSubmission entry),
2016-02-11 21:54:22 +01:00
"y" .= (- ((score / naturalRange) * 100.0)),
2016-02-12 23:21:26 +01:00
"size" .= (2 :: Int),
2018-07-24 15:36:24 +02:00
"label" .= descriptionToBeShown (leaderboardBestSubmission entry) (leaderboardBestVariant entry) (leaderboardParams entry) ]
2016-02-11 21:54:22 +01:00
Nothing -> Nothing
2016-02-12 23:21:26 +01:00
forkToEdge :: Entity Fork -> Value
forkToEdge (Entity forkId fork) = object [
"source" .= nodeId (forkSource fork),
"target" .= nodeId (forkTarget fork),
"id" .= edgeId forkId,
"type" .= ["arrow" :: String]
2016-02-11 21:54:22 +01:00
]
2016-02-12 23:21:26 +01:00
nodeId :: Key Submission -> String
nodeId = ("n" ++) . show . fromSqlKey
2016-02-11 21:54:22 +01:00
2016-02-12 23:21:26 +01:00
edgeId :: Key Fork -> String
edgeId = ("e" ++) . show . fromSqlKey
2016-02-11 21:54:22 +01:00
2016-02-12 23:21:26 +01:00
stampToX :: UTCTime -> Integer
stampToX = toModifiedJulianDay . utctDay
2016-02-11 21:54:22 +01:00
-- 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