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

Handle properly cases where there is no test

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Handler/Graph.hs
View File

@ -89,7 +89,9 @@ submissionsToJSON condition challengeName = do
(\entry -> [entityKey $ tableEntrySubmission entry]) (\entry -> [entityKey $ tableEntrySubmission entry])
entMainTest <- runDB $ fetchMainTest challengeId mEntMainTest <- runDB $ fetchMainTest challengeId
case mEntMainTest of
Just entMainTest -> do
let mainTestRef = getTestReference entMainTest let mainTestRef = getTestReference entMainTest
let naturalRange = getNaturalRange mainTestRef entries let naturalRange = getNaturalRange mainTestRef entries
@ -101,6 +103,8 @@ submissionsToJSON condition challengeName = do
$ map (auxSubmissionToNode mainTestRef naturalRange) $ map (auxSubmissionToNode mainTestRef naturalRange)
$ entries), $ entries),
"edges" .= map forkToEdge forks ] "edges" .= map forkToEdge forks ]
Nothing -> do
return $ object []
getNaturalRange :: TestReference -> [LeaderboardEntry] -> Double getNaturalRange :: TestReference -> [LeaderboardEntry] -> Double
getNaturalRange testRef entries = 2.0 * (interQuantile getNaturalRange testRef entries = 2.0 * (interQuantile

15
Handler/Shared.hs
View File

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

15
Handler/ShowChallenge.hs
View File

@ -851,11 +851,13 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
relevantIndicators <- getOngoingTargets challengeId relevantIndicators <- getOngoingTargets challengeId
(Entity mainTestId mainTest) <- runDB $ fetchMainTest challengeId
(Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge (Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let submittedMajorVersion = versionMajor currentVersion let submittedMajorVersion = versionMajor currentVersion
mMainEnt <- runDB $ fetchMainTest challengeId
bestScoreSoFar <- case mMainEnt of
Just (Entity _ mainTest) -> do
let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheHigherTheBetter -> E.desc TheHigherTheBetter -> E.desc
TheLowerTheBetter -> E.asc TheLowerTheBetter -> E.asc
@ -878,7 +880,9 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
E.orderBy [orderDirection (evaluation ^. EvaluationScore)] E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
E.limit 1 E.limit 1
return evaluation return evaluation
let bestScoreSoFar = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar)) let bestScoreSoFar' = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar))
return bestScoreSoFar'
Nothing -> return Nothing
case bestScoreSoFar of case bestScoreSoFar of
Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s)) Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s))
@ -930,6 +934,10 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
app <- getYesod app <- getYesod
let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
case mMainEnt of
Just (Entity mainTestId mainTest) -> do
newScores <- mapM (getScoreForOut mainTestId) outs newScores <- mapM (getScoreForOut mainTestId) outs
let newScores' = catMaybes newScores let newScores' = catMaybes newScores
let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
@ -939,8 +947,6 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
TheLowerTheBetter -> (<) TheLowerTheBetter -> (<)
TheHigherTheBetter -> (>) TheHigherTheBetter -> (>)
let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
case bestScoreSoFar of case bestScoreSoFar of
Just b -> case newScores'' of Just b -> case newScores'' of
(s:_) -> if compOp s b (s:_) -> if compOp s b
@ -973,6 +979,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
else return () else return ()
[] -> return () [] -> return ()
Nothing -> return () Nothing -> return ()
Nothing -> return ()
if appAutoOpening $ appSettings app if appAutoOpening $ appSettings app
then then

38
Handler/Tables.hs
View File

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

1
messages/en.msg
View File

@ -105,3 +105,4 @@ YourTeams: your teams
AsTeam: As team AsTeam: As team
InviteToTeam: Invite to team (give the identifier/login of a user) InviteToTeam: Invite to team (give the identifier/login of a user)
Join: Join 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

17
templates/show-challenge.hamlet
View File

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