Tests are shown without duplicates in case of challenge updates
This commit is contained in:
parent
32c77b3c74
commit
1255577259
@ -237,7 +237,7 @@ getTargetStatus theNow entries indicator target =
|
||||
$ map (\e -> (tableEntryMapping e) M.!? testId)
|
||||
$ filter (\e -> (submissionStamp $ entityVal $ tableEntrySubmission e) < theNow)
|
||||
$ filterEntries (indicatorEntryTargetCondition indicator) entries
|
||||
testId = entityKey $ indicatorEntryTest indicator
|
||||
testId = getTestReference $ indicatorEntryTest indicator
|
||||
|
||||
getOngoingTargets :: ChallengeId -> Handler [IndicatorEntry]
|
||||
getOngoingTargets challengeId = do
|
||||
|
||||
@ -31,12 +31,13 @@ getChallengeParamGraphDataR :: Text -> (Key Test) -> Text -> Handler Value
|
||||
getChallengeParamGraphDataR challengeName testId paramName = do
|
||||
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
|
||||
test <- runDB $ get404 testId
|
||||
let testRef = getTestReference (Entity testId test)
|
||||
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId
|
||||
|
||||
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)
|
||||
$ organizeBy
|
||||
@ -61,9 +62,9 @@ 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 :: TestReference -> Text -> (TableEntry, Maybe Text) -> Maybe ParamGraphItem
|
||||
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)
|
||||
tagsFormatted =
|
||||
map (tagName . entityVal . fst)
|
||||
@ -72,7 +73,7 @@ toParamGraphItem tid paramName (entry, Just val) = (ParamGraphItem entry label v
|
||||
map formatParameter
|
||||
$ filter (\pe -> parameterName pe /= paramName)
|
||||
$ map entityVal $ tableEntryParams entry
|
||||
y = evaluationScore <$> lookup tid (tableEntryMapping entry)
|
||||
y = evaluationScore <$> lookup testRef (tableEntryMapping entry)
|
||||
|
||||
findParamValue :: Text -> TableEntry -> Maybe Text
|
||||
findParamValue paramName entry =
|
||||
@ -88,25 +89,25 @@ submissionsToJSON condition challengeName = do
|
||||
|
||||
|
||||
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
|
||||
|
||||
forks <- runDB $ selectList [ForkSource <-. submissionIds, ForkTarget <-. submissionIds] []
|
||||
|
||||
return $ object [ "nodes" .= (Data.Maybe.catMaybes
|
||||
$ map (auxSubmissionToNode mainTestId naturalRange)
|
||||
$ map (auxSubmissionToNode mainTestRef naturalRange)
|
||||
$ entries),
|
||||
"edges" .= map forkToEdge forks ]
|
||||
|
||||
getNaturalRange :: TestId -> [LeaderboardEntry] -> Double
|
||||
getNaturalRange testId entries = 2.0 * (interQuantile
|
||||
getNaturalRange :: TestReference -> [LeaderboardEntry] -> Double
|
||||
getNaturalRange testRef entries = 2.0 * (interQuantile
|
||||
$ 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 testId naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testId) of
|
||||
auxSubmissionToNode :: TestReference -> Double -> LeaderboardEntry -> Maybe Value
|
||||
auxSubmissionToNode testRef naturalRange entry = case evaluationScore $ ((leaderboardEvaluationMap entry) M.! testRef) of
|
||||
Just score -> Just $ object [
|
||||
"id" .= (nodeId $ leaderboardBestSubmissionId entry),
|
||||
"x" .= (stampToX $ submissionStamp $ leaderboardBestSubmission entry),
|
||||
@ -241,14 +242,15 @@ addNow _ ([], []) = ([], [])
|
||||
addNow theNow (scores, timepoints) = (scores ++ [last $ impureNonNull scores], timepoints ++ [formatTimestamp theNow])
|
||||
|
||||
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
|
||||
scores = map (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testId) relevantEntries
|
||||
scores = map (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testRef) relevantEntries
|
||||
relevantEntries =
|
||||
monotonicBy (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testId) comparator
|
||||
$ filter (\entry -> testId `M.member` (tableEntryMapping entry)
|
||||
&& isJust (evaluationScore ((tableEntryMapping entry) M.! testId))) entries
|
||||
monotonicBy (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testRef) comparator
|
||||
$ filter (\entry -> testRef `M.member` (tableEntryMapping entry)
|
||||
&& isJust (evaluationScore ((tableEntryMapping entry) M.! testRef))) entries
|
||||
comparator = compareFun $ getMetricOrdering $ evaluationSchemeMetric $ testMetric test
|
||||
testRef = getTestReference testEnt
|
||||
|
||||
targetsToLines :: UTCTime -> IndicatorEntry -> [TargetStatus] -> Value
|
||||
targetsToLines theNow indicator statuses = object [
|
||||
|
||||
@ -26,6 +26,12 @@ import GEval.EvaluationScheme
|
||||
|
||||
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 {
|
||||
leaderboardUser :: User,
|
||||
leaderboardUserId :: UserId,
|
||||
@ -33,7 +39,7 @@ data LeaderboardEntry = LeaderboardEntry {
|
||||
leaderboardBestSubmissionId :: SubmissionId,
|
||||
leaderboardBestVariant :: Variant,
|
||||
leaderboardBestVariantId :: VariantId,
|
||||
leaderboardEvaluationMap :: Map (Key Test) Evaluation,
|
||||
leaderboardEvaluationMap :: Map TestReference Evaluation,
|
||||
leaderboardNumberOfSubmissions :: Int,
|
||||
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)],
|
||||
leaderboardParams :: [Parameter]
|
||||
@ -43,7 +49,7 @@ data TableEntry = TableEntry {
|
||||
tableEntrySubmission :: Entity Submission,
|
||||
tableEntryVariant :: Entity Variant,
|
||||
tableEntrySubmitter :: Entity User,
|
||||
tableEntryMapping :: Map (Key Test) Evaluation,
|
||||
tableEntryMapping :: Map TestReference Evaluation,
|
||||
tableEntryTagsInfo :: [(Entity Tag, Entity SubmissionTag)],
|
||||
tableEntryParams :: [Entity Parameter],
|
||||
tableEntryRank :: Int }
|
||||
@ -57,7 +63,7 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
|
||||
++ Table.text "submitter" (formatSubmitter . entityVal . tableEntrySubmitter)
|
||||
++ timestampCell "when" tableEntryStamp
|
||||
++ 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,
|
||||
entityVal $ tableEntrySubmission tableEntry,
|
||||
entityKey $ tableEntryVariant tableEntry,
|
||||
@ -69,7 +75,7 @@ paramTable :: [Text] -> [Entity Test] -> Table App TableEntry
|
||||
paramTable paramNames tests = mempty
|
||||
++ Table.int "#" tableEntryRank
|
||||
++ 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 paramName = Table.text paramName (\entry ->
|
||||
@ -98,7 +104,7 @@ descriptionToBeShown s v params = (submissionDescription s) ++ (Data.Text.pack v
|
||||
" " ++ r
|
||||
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
|
||||
|
||||
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)
|
||||
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
|
||||
++ 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)
|
||||
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
|
||||
leaderboardBestSubmission e,
|
||||
@ -116,7 +122,7 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
|
||||
leaderboardUserId e,
|
||||
mauthId))
|
||||
|
||||
extractScoreFromLeaderboardEntry :: Key Test -> LeaderboardEntry -> Maybe Evaluation
|
||||
extractScoreFromLeaderboardEntry :: TestReference -> LeaderboardEntry -> Maybe Evaluation
|
||||
extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry)
|
||||
|
||||
leaderboardDescriptionCell :: Maybe UserId -> Table App (a, LeaderboardEntry)
|
||||
@ -170,7 +176,7 @@ checkWhetherVisible submission userId mauthId = isPublic || isOwner
|
||||
where isPublic = submissionIsPublic submission
|
||||
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
|
||||
where processEvaluationMap (TableEntry s v (Entity ui u) m _ _ _) = (ui, (u, case Map.lookup testId m of
|
||||
Just e -> [(s, v, e)]
|
||||
@ -185,14 +191,15 @@ getLeaderboardEntriesByCriterion challengeId condition selector = do
|
||||
(evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition challengeId
|
||||
let mainTests = getMainTests tests
|
||||
let mainTestEnt = getMainTest tests
|
||||
let (Entity mainTestId mainTest) = mainTestEnt
|
||||
let mainTestRef = getTestReference mainTestEnt
|
||||
let (Entity _ mainTest) = mainTestEnt
|
||||
let auxItems = concat
|
||||
$ map (\i -> map (\s -> (s, [i])) (selector i))
|
||||
$ filter (\entry -> member mainTestId $ tableEntryMapping entry)
|
||||
$ filter (\entry -> member mainTestRef $ tableEntryMapping entry)
|
||||
$ evaluationMaps
|
||||
let auxItemsMap = Map.fromListWith (++) auxItems
|
||||
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestId)
|
||||
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestId)
|
||||
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestRef)
|
||||
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestRef)
|
||||
entries' <- mapM (toLeaderboardEntry challengeId mainTests)
|
||||
$ filter (\ll -> not (null ll))
|
||||
$ map snd
|
||||
@ -226,10 +233,11 @@ toLeaderboardEntry challengeId tests ss = do
|
||||
leaderboardTags = tagEnts,
|
||||
leaderboardParams = map entityVal parameters
|
||||
}
|
||||
where (Entity mainTestId mainTest) = getMainTest tests
|
||||
where mainTestEnt@(Entity _ mainTest) = getMainTest tests
|
||||
mainTestRef = getTestReference mainTestEnt
|
||||
submissionComparator (TableEntry _ _ _ em1 _ _ _) (TableEntry _ _ _ em2 _ _ _) =
|
||||
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestId))
|
||||
(evaluationScore (em2 Map.! mainTestId))
|
||||
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef))
|
||||
(evaluationScore (em2 Map.! mainTestRef))
|
||||
|
||||
getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
|
||||
getLeaderboardEntries BySubmitter challengeId =
|
||||
@ -250,7 +258,11 @@ compareResult _ Nothing (Just _) = LT
|
||||
compareResult _ Nothing Nothing = EQ
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
maybeEvaluations <- mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs
|
||||
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
|
||||
|
||||
parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user