Handle properly cases where there is no test
This commit is contained in:
parent
74440c2587
commit
51e98bee68
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
Loading…
Reference in New Issue
Block a user