filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

Tests are shown without duplicates in case of challenge updates

Browse Source
This commit is contained in:
Filip Gralinski 2019-08-29 09:39:21 +02:00
parent 32c77b3c74
commit 1255577259
3 changed files with 54 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Handler/Dashboard.hs
View File

@ -237,7 +237,7 @@ getTargetStatus theNow entries indicator target =
$ map (\e -> (tableEntryMapping e) M.!? testId) $ map (\e -> (tableEntryMapping e) M.!? testId)
$ filter (\e -> (submissionStamp $ entityVal $ tableEntrySubmission e) < theNow) $ filter (\e -> (submissionStamp $ entityVal $ tableEntrySubmission e) < theNow)
$ filterEntries (indicatorEntryTargetCondition indicator) entries $ filterEntries (indicatorEntryTargetCondition indicator) entries
testId = entityKey $ indicatorEntryTest indicator testId = getTestReference $ indicatorEntryTest indicator
getOngoingTargets :: ChallengeId -> Handler [IndicatorEntry] getOngoingTargets :: ChallengeId -> Handler [IndicatorEntry]
getOngoingTargets challengeId = do getOngoingTargets challengeId = do

36
Handler/Graph.hs
View File

@ -31,12 +31,13 @@ getChallengeParamGraphDataR :: Text -> (Key Test) -> Text -> Handler Value
getChallengeParamGraphDataR challengeName testId paramName = do getChallengeParamGraphDataR challengeName testId paramName = do
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
test <- runDB $ get404 testId test <- runDB $ get404 testId
let testRef = getTestReference (Entity testId test)
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId
let values = map (findParamValue paramName) entries let values = map (findParamValue paramName) entries
let items = Data.Maybe.catMaybes $ map (toParamGraphItem testId paramName) $ zip entries values let items = Data.Maybe.catMaybes $ map (toParamGraphItem testRef paramName) $ zip entries values
let series = map (\(label, rs) -> ParamGraphSeries label rs) let series = map (\(label, rs) -> ParamGraphSeries label rs)
$ organizeBy $ organizeBy
@ -61,9 +62,9 @@ xSeriesName = (++ "_x")
organizeBy :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])] organizeBy :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
organizeBy pList = M.toList $ M.fromListWith (++) $ map (\(x, y) -> (x, [y])) pList organizeBy pList = M.toList $ M.fromListWith (++) $ map (\(x, y) -> (x, [y])) pList
toParamGraphItem :: TestId -> Text -> (TableEntry, Maybe Text) -> Maybe ParamGraphItem toParamGraphItem :: TestReference -> Text -> (TableEntry, Maybe Text) -> Maybe ParamGraphItem
toParamGraphItem _ _ (_, Nothing) = Nothing toParamGraphItem _ _ (_, Nothing) = Nothing
toParamGraphItem tid paramName (entry, Just val) = (ParamGraphItem entry label val) <$> join y toParamGraphItem testRef paramName (entry, Just val) = (ParamGraphItem entry label val) <$> join y
where label = unwords (tagsFormatted ++ paramsFormatted) where label = unwords (tagsFormatted ++ paramsFormatted)
tagsFormatted = tagsFormatted =
map (tagName . entityVal . fst) map (tagName . entityVal . fst)
@ -72,7 +73,7 @@ toParamGraphItem tid paramName (entry, Just val) = (ParamGraphItem entry label v
map formatParameter map formatParameter
$ filter (\pe -> parameterName pe /= paramName) $ filter (\pe -> parameterName pe /= paramName)
$ map entityVal $ tableEntryParams entry $ map entityVal $ tableEntryParams entry
y = evaluationScore <$> lookup tid (tableEntryMapping entry) y = evaluationScore <$> lookup testRef (tableEntryMapping entry)
findParamValue :: Text -> TableEntry -> Maybe Text findParamValue :: Text -> TableEntry -> Maybe Text
findParamValue paramName entry = findParamValue paramName entry =
@ -88,25 +89,25 @@ submissionsToJSON condition challengeName = do
tests <- runDB $ selectList [TestChallenge ==. challengeId] [] tests <- runDB $ selectList [TestChallenge ==. challengeId] []
let mainTestId = entityKey $ getMainTest tests let mainTestRef = getTestReference $ getMainTest tests
let naturalRange = getNaturalRange mainTestId entries let naturalRange = getNaturalRange mainTestRef entries
let submissionIds = map leaderboardBestSubmissionId entries let submissionIds = map leaderboardBestSubmissionId entries
forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] [] forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] []
return $ object [ "nodes" .= (Data.Maybe.catMaybes return $ object [ "nodes" .= (Data.Maybe.catMaybes
$ map (auxSubmissionToNode mainTestId naturalRange) $ map (auxSubmissionToNode mainTestRef naturalRange)
$ entries), $ entries),
"edges" .= map forkToEdge forks ] "edges" .= map forkToEdge forks ]
getNaturalRange :: TestId -> [LeaderboardEntry] -> Double getNaturalRange :: TestReference -> [LeaderboardEntry] -> Double
getNaturalRange testId entries = 2.0 * (interQuantile getNaturalRange testRef entries = 2.0 * (interQuantile
$ Data.Maybe.catMaybes $ Data.Maybe.catMaybes
$ map (\entry -> evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId)) entries) $ map (\entry -> evaluationScore $ ((leaderboardEvaluationMap entry) M.! testRef)) entries)
auxSubmissionToNode :: TestId -> Double -> LeaderboardEntry -> Maybe Value auxSubmissionToNode :: TestReference -> Double -> LeaderboardEntry -> Maybe Value
auxSubmissionToNode testId naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId) of auxSubmissionToNode testRef naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testRef) of
Just score -> Just $ object [ Just score -> Just $ object [
"id" .= (nodeId $ leaderboardBestSubmissionId entry), "id" .= (nodeId $ leaderboardBestSubmissionId entry),
"x" .= (stampToX $ submissionStamp $ leaderboardBestSubmission entry), "x" .= (stampToX $ submissionStamp $ leaderboardBestSubmission entry),
@ -241,14 +242,15 @@ addNow _ ([], []) = ([], [])
addNow theNow (scores, timepoints) = (scores ++ [last $ impureNonNull scores], timepoints ++ [formatTimestamp theNow]) addNow theNow (scores, timepoints) = (scores ++ [last $ impureNonNull scores], timepoints ++ [formatTimestamp theNow])
entriesToPoints :: Entity Test -> [TableEntry] -> ([Double], [Text]) entriesToPoints :: Entity Test -> [TableEntry] -> ([Double], [Text])
entriesToPoints (Entity testId test) entries = (scores, timePoints) entriesToPoints testEnt@(Entity _ test) entries = (scores, timePoints)
where timePoints = map (formatTimestamp . tableEntryStamp) relevantEntries where timePoints = map (formatTimestamp . tableEntryStamp) relevantEntries
scores = map (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testId) relevantEntries scores = map (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testRef) relevantEntries
relevantEntries = relevantEntries =
monotonicBy (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testId) comparator monotonicBy (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testRef) comparator
$ filter (\entry -> testId `M.member` (tableEntryMapping entry) $ filter (\entry -> testRef `M.member` (tableEntryMapping entry)
&& isJust (evaluationScore ((tableEntryMapping entry) M.! testId))) entries && isJust (evaluationScore ((tableEntryMapping entry) M.! testRef))) entries
comparator = compareFun $ getMetricOrdering $ evaluationSchemeMetric $ testMetric test comparator = compareFun $ getMetricOrdering $ evaluationSchemeMetric $ testMetric test
testRef = getTestReference testEnt
targetsToLines :: UTCTime -> IndicatorEntry -> [TargetStatus] -> Value targetsToLines :: UTCTime -> IndicatorEntry -> [TargetStatus] -> Value
targetsToLines theNow indicator statuses = object [ targetsToLines theNow indicator statuses = object [

51
Handler/Tables.hs
View File

@ -26,6 +26,12 @@ import GEval.EvaluationScheme
import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..)) import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..))
data TestReference = TestReference Text Text
deriving (Show, Eq, Ord)
getTestReference :: Entity Test -> TestReference
getTestReference (Entity _ test) = TestReference (Data.Text.pack $ show $ testMetric test) (testName test)
data LeaderboardEntry = LeaderboardEntry { data LeaderboardEntry = LeaderboardEntry {
leaderboardUser :: User, leaderboardUser :: User,
leaderboardUserId :: UserId, leaderboardUserId :: UserId,
@ -33,7 +39,7 @@ data LeaderboardEntry = LeaderboardEntry {
leaderboardBestSubmissionId :: SubmissionId, leaderboardBestSubmissionId :: SubmissionId,
leaderboardBestVariant :: Variant, leaderboardBestVariant :: Variant,
leaderboardBestVariantId :: VariantId, leaderboardBestVariantId :: VariantId,
leaderboardEvaluationMap :: Map (Key Test) Evaluation, leaderboardEvaluationMap :: Map TestReference Evaluation,
leaderboardNumberOfSubmissions :: Int, leaderboardNumberOfSubmissions :: Int,
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)], leaderboardTags :: [(Entity Tag, Entity SubmissionTag)],
leaderboardParams :: [Parameter] leaderboardParams :: [Parameter]
@ -43,7 +49,7 @@ data TableEntry = TableEntry {
tableEntrySubmission :: Entity Submission, tableEntrySubmission :: Entity Submission,
tableEntryVariant :: Entity Variant, tableEntryVariant :: Entity Variant,
tableEntrySubmitter :: Entity User, tableEntrySubmitter :: Entity User,
tableEntryMapping :: Map (Key Test) Evaluation, tableEntryMapping :: Map TestReference Evaluation,
tableEntryTagsInfo :: [(Entity Tag, Entity SubmissionTag)], tableEntryTagsInfo :: [(Entity Tag, Entity SubmissionTag)],
tableEntryParams :: [Entity Parameter], tableEntryParams :: [Entity Parameter],
tableEntryRank :: Int } tableEntryRank :: Int }
@ -57,7 +63,7 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.text "submitter" (formatSubmitter . entityVal . tableEntrySubmitter) ++ Table.text "submitter" (formatSubmitter . entityVal . tableEntrySubmitter)
++ timestampCell "when" tableEntryStamp ++ timestampCell "when" tableEntryStamp
++ descriptionCell mauthId ++ descriptionCell mauthId
++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests) ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
++ statusCell challengeName repoScheme challengeRepo (\tableEntry -> (entityKey $ tableEntrySubmission tableEntry, ++ statusCell challengeName repoScheme challengeRepo (\tableEntry -> (entityKey $ tableEntrySubmission tableEntry,
entityVal $ tableEntrySubmission tableEntry, entityVal $ tableEntrySubmission tableEntry,
entityKey $ tableEntryVariant tableEntry, entityKey $ tableEntryVariant tableEntry,
@ -69,7 +75,7 @@ paramTable :: [Text] -> [Entity Test] -> Table App TableEntry
paramTable paramNames tests = mempty paramTable paramNames tests = mempty
++ Table.int "#" tableEntryRank ++ Table.int "#" tableEntryRank
++ mconcat (map paramExtractor paramNames) ++ mconcat (map paramExtractor paramNames)
++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests) ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
paramExtractor :: Text -> Table App TableEntry paramExtractor :: Text -> Table App TableEntry
paramExtractor paramName = Table.text paramName (\entry -> paramExtractor paramName = Table.text paramName (\entry ->
@ -98,7 +104,7 @@ descriptionToBeShown s v params = (submissionDescription s) ++ (Data.Text.pack v
" " ++ r " " ++ r
paramsShown = Data.Text.unwords $ map formatParameter params paramsShown = Data.Text.unwords $ map formatParameter params
extractScore :: Key Test -> TableEntry -> Maybe Evaluation extractScore :: TestReference -> TableEntry -> Maybe Evaluation
extractScore k tableEntry = lookup k $ tableEntryMapping tableEntry extractScore k tableEntry = lookup k $ tableEntryMapping tableEntry
leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry) leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry)
@ -107,7 +113,7 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd) ++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd) ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
++ leaderboardDescriptionCell mauthId ++ leaderboardDescriptionCell mauthId
++ mconcat (map (\(Entity k t) -> resultCell t (extractScoreFromLeaderboardEntry k . snd)) tests) ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests)
++ Table.int "×" (leaderboardNumberOfSubmissions . snd) ++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e, ++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
leaderboardBestSubmission e, leaderboardBestSubmission e,
@ -116,7 +122,7 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
leaderboardUserId e, leaderboardUserId e,
mauthId)) mauthId))
extractScoreFromLeaderboardEntry :: Key Test -> LeaderboardEntry -> Maybe Evaluation extractScoreFromLeaderboardEntry :: TestReference -> LeaderboardEntry -> Maybe Evaluation
extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry) extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry)
leaderboardDescriptionCell :: Maybe UserId -> Table App (a, LeaderboardEntry) leaderboardDescriptionCell :: Maybe UserId -> Table App (a, LeaderboardEntry)
@ -170,7 +176,7 @@ checkWhetherVisible submission userId mauthId = isPublic || isOwner
where isPublic = submissionIsPublic submission where isPublic = submissionIsPublic submission
isOwner = (mauthId == Just userId) isOwner = (mauthId == Just userId)
getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))] getAuxSubmissionEnts :: TestReference -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))]
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
where processEvaluationMap (TableEntry s v (Entity ui u) m _ _ _) = (ui, (u, case Map.lookup testId m of where processEvaluationMap (TableEntry s v (Entity ui u) m _ _ _) = (ui, (u, case Map.lookup testId m of
Just e -> [(s, v, e)] Just e -> [(s, v, e)]
@ -185,14 +191,15 @@ getLeaderboardEntriesByCriterion challengeId condition selector = do
(evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition challengeId (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition challengeId
let mainTests = getMainTests tests let mainTests = getMainTests tests
let mainTestEnt = getMainTest tests let mainTestEnt = getMainTest tests
let (Entity mainTestId mainTest) = mainTestEnt let mainTestRef = getTestReference mainTestEnt
let (Entity _ mainTest) = mainTestEnt
let auxItems = concat let auxItems = concat
$ map (\i -> map (\s -> (s, [i])) (selector i)) $ map (\i -> map (\s -> (s, [i])) (selector i))
$ filter (\entry -> member mainTestId $ tableEntryMapping entry) $ filter (\entry -> member mainTestRef $ tableEntryMapping entry)
$ evaluationMaps $ evaluationMaps
let auxItemsMap = Map.fromListWith (++) auxItems let auxItemsMap = Map.fromListWith (++) auxItems
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestId) let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestRef)
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestId) (evaluationScore $ leaderboardEvaluationMap b Map.! mainTestRef)
entries' <- mapM (toLeaderboardEntry challengeId mainTests) entries' <- mapM (toLeaderboardEntry challengeId mainTests)
$ filter (\ll -> not (null ll)) $ filter (\ll -> not (null ll))
$ map snd $ map snd
@ -226,10 +233,11 @@ toLeaderboardEntry challengeId tests ss = do
leaderboardTags = tagEnts, leaderboardTags = tagEnts,
leaderboardParams = map entityVal parameters leaderboardParams = map entityVal parameters
} }
where (Entity mainTestId mainTest) = getMainTest tests where mainTestEnt@(Entity _ mainTest) = getMainTest tests
mainTestRef = getTestReference mainTestEnt
submissionComparator (TableEntry _ _ _ em1 _ _ _) (TableEntry _ _ _ em2 _ _ _) = submissionComparator (TableEntry _ _ _ em1 _ _ _) (TableEntry _ _ _ em2 _ _ _) =
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef))
(evaluationScore (em2 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestRef))
getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries BySubmitter challengeId = getLeaderboardEntries BySubmitter challengeId =
@ -250,7 +258,11 @@ compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ compareResult _ Nothing Nothing = EQ
getChallengeSubmissionInfos condition challengeId = do getChallengeSubmissionInfos condition challengeId = do
tests <- selectList [TestChallenge ==. challengeId, TestActive ==. True] []
challenge <- get404 challengeId
let commit = challengeVersion challenge
tests <- selectList [TestChallenge ==. challengeId, TestActive ==. True, TestCommit ==. commit] []
let mainTest = getMainTest tests let mainTest = getMainTest tests
allSubmissionsVariants <- E.select $ E.from $ \(submission, variant) -> do allSubmissionsVariants <- E.select $ E.from $ \(submission, variant) -> do
@ -291,7 +303,12 @@ getEvaluationMap (rank, (s@(Entity submissionId submission), v@(Entity variantId
user <- get404 $ submissionSubmitter submission user <- get404 $ submissionSubmitter submission
maybeEvaluations <- mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs maybeEvaluations <- mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs
let evaluations = catMaybes maybeEvaluations let evaluations = catMaybes maybeEvaluations
let m = Map.fromList $ map (\(Entity _ e) -> (evaluationTest e, e)) evaluations let pairs = map (\(Entity _ e) -> (evaluationTest e, e)) evaluations
pairs' <- mapM (\(testId, e) -> do
test <- get404 testId
let testRef = getTestReference (Entity testId test)
return (testRef, e)) pairs
let m = Map.fromList pairs'
tagEnts <- getTags submissionId tagEnts <- getTags submissionId
parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName] parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName]