Handle properly cases where there is no test

This commit is contained in:
Filip Gralinski 2021-07-28 21:37:06 +02:00
parent 74440c2587
commit 51e98bee68
6 changed files with 104 additions and 80 deletions

View File

@ -89,18 +89,22 @@ submissionsToJSON condition challengeName = do
(\entry -> [entityKey $ tableEntrySubmission entry])
entMainTest <- runDB $ fetchMainTest challengeId
let mainTestRef = getTestReference entMainTest
mEntMainTest <- runDB $ fetchMainTest challengeId
case mEntMainTest of
Just entMainTest -> do
let mainTestRef = getTestReference entMainTest
let naturalRange = getNaturalRange mainTestRef entries
let submissionIds = map leaderboardBestSubmissionId entries
let naturalRange = getNaturalRange mainTestRef 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
$ map (auxSubmissionToNode mainTestRef naturalRange)
$ entries),
"edges" .= map forkToEdge forks ]
return $ object [ "nodes" .= (Data.Maybe.catMaybes
$ map (auxSubmissionToNode mainTestRef naturalRange)
$ entries),
"edges" .= map forkToEdge forks ]
Nothing -> do
return $ object []
getNaturalRange :: TestReference -> [LeaderboardEntry] -> Double
getNaturalRange testRef entries = 2.0 * (interQuantile

View File

@ -121,7 +121,7 @@ consoleApp jobId = do
case mchan of
Nothing -> do
sendTextData ("CANNOT FIND THE OUTPUT (ALREADY SHOWN??)" :: Text)
sendCloseE ("" :: Text)
_ <- sendCloseE ("" :: Text)
return ()
Just chan -> do
let loop = do
@ -131,7 +131,7 @@ consoleApp jobId = do
Just text -> do
sendTextData text
loop
loop
_ <- loop
return ()
@ -556,7 +556,7 @@ thenCmp :: Ordering -> Ordering -> Ordering
thenCmp EQ o2 = o2
thenCmp o1 _ = o1
fetchMainTest :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Entity Test)
fetchMainTest :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Maybe (Entity Test))
fetchMainTest challengeId = do
challenge <- get404 challengeId
@ -568,9 +568,7 @@ fetchMainTest challengeId = do
fetchTestByName :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Maybe Text -> Key Challenge -> ReaderT backend m (Maybe (Entity Test))
fetchTestByName Nothing challengeId = do
mainTest <- fetchMainTest challengeId
return $ Just mainTest
fetchTestByName Nothing challengeId = fetchMainTest challengeId
fetchTestByName (Just tName) challengeId = do
challenge <- get404 challengeId
@ -583,8 +581,9 @@ fetchTestByName (Just tName) challengeId = do
-- get the test with the highest priority
getMainTest :: [Entity Test] -> Entity Test
getMainTest tests = DL.maximumBy testComparator tests
getMainTest :: [Entity Test] -> Maybe (Entity Test)
getMainTest [] = Nothing
getMainTest tests = Just $ DL.maximumBy testComparator tests
-- get all the non-dev tests starting with the one with the highest priorty
-- (or all the tests if there are no non-dev tests)

View File

@ -851,16 +851,18 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
relevantIndicators <- getOngoingTargets challengeId
(Entity mainTestId mainTest) <- runDB $ fetchMainTest challengeId
(Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let submittedMajorVersion = versionMajor currentVersion
let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheHigherTheBetter -> E.desc
TheLowerTheBetter -> E.asc
mMainEnt <- runDB $ fetchMainTest challengeId
bestScoreSoFar <- case mMainEnt of
Just (Entity _ mainTest) -> do
let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheHigherTheBetter -> E.desc
TheLowerTheBetter -> E.asc
bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, theVersion) -> do
bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, theVersion) -> do
E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId
E.&&. submission ^. SubmissionIsHidden E.==. E.val False
E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
@ -878,7 +880,9 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
E.limit 1
return evaluation
let bestScoreSoFar = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar))
let bestScoreSoFar' = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar))
return bestScoreSoFar'
Nothing -> return Nothing
case bestScoreSoFar of
Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s))
@ -930,19 +934,21 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
app <- getYesod
newScores <- mapM (getScoreForOut mainTestId) outs
let newScores' = catMaybes newScores
let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheHigherTheBetter -> reverse $ sort newScores'
TheLowerTheBetter -> sort newScores'
let compOp = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheLowerTheBetter -> (<)
TheHigherTheBetter -> (>)
let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
case bestScoreSoFar of
Just b -> case newScores'' of
case mMainEnt of
Just (Entity mainTestId mainTest) -> do
newScores <- mapM (getScoreForOut mainTestId) outs
let newScores' = catMaybes newScores
let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheHigherTheBetter -> reverse $ sort newScores'
TheLowerTheBetter -> sort newScores'
let compOp = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheLowerTheBetter -> (<)
TheHigherTheBetter -> (>)
case bestScoreSoFar of
Just b -> case newScores'' of
(s:_) -> if compOp s b
then
do
@ -972,6 +978,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
Nothing -> return ()
else return ()
[] -> return ()
Nothing -> return ()
Nothing -> return ()
if appAutoOpening $ appSettings app

View File

@ -276,6 +276,9 @@ theLimitedDiffTextCell h textFun = Table.widget h (
OneThing u -> limitedWidget textCellSoftLimit textCellHardLimit u
d@(TwoThings _ _) -> [whamlet|#{d}|])
extractInt :: [PersistValue] -> Int64
extractInt ((PersistInt64 x):_) = x
statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, Maybe UserId) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, mauthId) = do
isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId
@ -351,28 +354,31 @@ getLeaderboardEntriesByCriterion :: (Ord a) => Int
getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector selector = do
(evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos maxPriority condition (const True) preselector challengeId
let mainTests = getMainTests tests
let mainTestEnt = getMainTest tests
let mainTestRef = getTestReference mainTestEnt
let (Entity _ mainTest) = mainTestEnt
let auxItems = concat
$ map (\i -> map (\s -> (s, [i])) (selector i))
$ filter (\entry -> member mainTestRef $ tableEntryMapping entry)
$ evaluationMaps
let auxItemsMap = Map.fromListWith (++) auxItems
let entryComparator a b =
(compareMajorVersions (leaderboardVersion a) (leaderboardVersion b))
<>
((compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestRef)
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestRef))
<>
(compareVersions (leaderboardVersion a) (leaderboardVersion b))
entries' <- mapM (toLeaderboardEntry challengeId mainTests)
$ filter (\ll -> not (null ll))
$ map snd
$ Map.toList auxItemsMap
let entries = DL.nubBy (\a b -> leaderboardBestVariantId a == leaderboardBestVariantId b)
$ sortBy (flip entryComparator) entries'
return (entries, (evaluationMaps, mainTests))
let mMainTestEnt = getMainTest tests
case mMainTestEnt of
Nothing -> return ([], ([], []))
Just mainTestEnt -> do
let mainTestRef = getTestReference mainTestEnt
let (Entity _ mainTest) = mainTestEnt
let auxItems = concat
$ map (\i -> map (\s -> (s, [i])) (selector i))
$ filter (\entry -> member mainTestRef $ tableEntryMapping entry)
$ evaluationMaps
let auxItemsMap = Map.fromListWith (++) auxItems
let entryComparator a b =
(compareMajorVersions (leaderboardVersion a) (leaderboardVersion b))
<>
((compareResult $ Just mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestRef)
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestRef))
<>
(compareVersions (leaderboardVersion a) (leaderboardVersion b))
entries' <- mapM (toLeaderboardEntry challengeId mainTests)
$ filter (\ll -> not (null ll))
$ map snd
$ Map.toList auxItemsMap
let entries = DL.nubBy (\a b -> leaderboardBestVariantId a == leaderboardBestVariantId b)
$ sortBy (flip entryComparator) entries'
return (entries, (evaluationMaps, mainTests))
toLeaderboardEntry :: Foldable t => Key Challenge -> [Entity Test] -> t TableEntry -> Handler LeaderboardEntry
@ -423,15 +429,17 @@ toLeaderboardEntry challengeId tests ss = do
leaderboardIsVisible = isVisible,
leaderboardTeam = mTeam
}
where mainTestEnt@(Entity _ mainTest) = getMainTest tests
mainTestRef = getTestReference mainTestEnt
submissionComparator (TableEntry _ _ _ em1 _ _ _ v1 _) (TableEntry _ _ _ em2 _ _ _ v2 _) =
(compareMajorVersions v1 v2)
<>
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestRef))
(evaluationScore (em2 Map.! mainTestRef))
<>
(compareVersions v1 v2)
where submissionComparator (TableEntry _ _ _ em1 _ _ _ v1 _) (TableEntry _ _ _ em2 _ _ _ v2 _) =
case getMainTest tests of
Just mainTestEnt@(Entity _ mainTest) ->
let mainTestRef = getTestReference mainTestEnt
in (compareMajorVersions v1 v2)
<>
(compareResult (Just $ mainTest) (evaluationScore (em1 Map.! mainTestRef))
(evaluationScore (em2 Map.! mainTestRef)))
<>
(compareVersions v1 v2)
Nothing -> EQ
getLeaderboardEntries :: Int -> LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries maxPriority BySubmitter challengeId =
@ -449,8 +457,9 @@ getLeaderboardEntries maxPriority ByTag challengeId =
where noEmptyList [] = [Nothing]
noEmptyList l = map Just l
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ evaluationSchemeMetric $ testMetric test) x y
compareResult :: Maybe Test -> Maybe Double -> Maybe Double -> Ordering
compareResult Nothing _ _ = EQ
compareResult (Just test) (Just x) (Just y) = (compareFun $ getMetricOrdering $ evaluationSchemeMetric $ testMetric test) x y
compareResult _ (Just _) Nothing = GT
compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ
@ -485,7 +494,7 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition presele
E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId)
return (submission, variant)
scores <- mapM (getScore (entityKey mainTest)) $ map (entityKey . snd) allSubmissionsVariants
scores <- mapM (getScore (entityKey <$> mainTest)) $ map (entityKey . snd) allSubmissionsVariants
let allSubmissionsVariantsWithRanks =
sortBy (\(r1, (s1, _)) (r2, (s2, _)) -> (submissionStamp (entityVal s2) `compare` submissionStamp (entityVal s1))
@ -495,7 +504,7 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition presele
$ filter (\(_, (s, _)) -> condition s)
$ map (\(rank, (_, sv)) -> (rank, sv))
$ zip [1..]
$ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1)
$ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal <$> mainTest) s2 s1)
$ zip scores allSubmissionsVariants
allTests <- selectList [] [Asc TestName]
@ -512,8 +521,9 @@ getChallengeSubmissionInfos maxMetricPriority condition variantCondition presele
getScore :: (MonadIO m, BackendCompatible SqlBackend backend,
PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
=> Key Test -> Key Variant -> ReaderT backend m (Maybe Double)
getScore testId variantId = do
=> Maybe (Key Test) -> Key Variant -> ReaderT backend m (Maybe Double)
getScore Nothing _ = return Nothing
getScore (Just testId) variantId = do
evaluations <- E.select $ E.from $ \(out, evaluation, variant, submission) -> do
E.where_ (out ^. OutVariant E.==. E.val variantId
E.&&. variant ^. VariantId E.==. E.val variantId

View File

@ -105,3 +105,4 @@ YourTeams: your teams
AsTeam: As team
InviteToTeam: Invite to team (give the identifier/login of a user)
Join: Join
NoTests: SOMETHING IS WRONG WITH THE CHALLENGE, THERE ARE NO TESTS DEFINED. MAYBE TEST DIRECTORY ARE MISSING OR THE CHALLENGE WAS CREATED/UPDATE IN THE INVALID MANNER

View File

@ -25,17 +25,20 @@ $if (checkIfAdmin mUserEnt)
<h2>Leaderboard
^{Table.buildBootstrap (leaderboardTable mUserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks}
$if null tests
<p>_{MsgNoTests}
$else
^{Table.buildBootstrap (leaderboardTable mUserId (challengeName challenge) scheme challengeRepo tests) leaderboardWithRanks}
$maybe altLeaderboardWithRanks <- mAltLeaderboardWithRanks
$maybe altTests <- mAltTests
^{Table.buildBootstrap (altLeaderboardTable mUserId (challengeName challenge) scheme challengeRepo altTests) altLeaderboardWithRanks}
$maybe altLeaderboardWithRanks <- mAltLeaderboardWithRanks
$maybe altTests <- mAltTests
^{Table.buildBootstrap (altLeaderboardTable mUserId (challengeName challenge) scheme challengeRepo altTests) altLeaderboardWithRanks}
$nothing
$nothing
$nothing
<div id="graph-container">
<div id="graph-container">
<script src="/static/js/sigma.min.js">
<script src="/static/js/sigma.parsers.json.min.js">
<script src="/static/js/sigma.min.js">
<script src="/static/js/sigma.parsers.json.min.js">
^{paramGraphsWidget challenge tests params}
^{paramGraphsWidget challenge tests params}