First version of viewing a specific variant
This commit is contained in:
parent
c72cc274d5
commit
c0a06ae112
|
|
@ -19,6 +19,8 @@ import Handler.Tables (timestampCell)
|
|||
import GEval.Core (isBetter)
|
||||
import GEval.EvaluationScheme
|
||||
|
||||
import Text.Blaze
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto ((^.))
|
||||
|
||||
|
|
@ -93,6 +95,7 @@ postEditIndicatorR indicatorId = do
|
|||
|
||||
doEditIndicator mUser indicatorId formWidget formEnctype
|
||||
|
||||
doEditIndicator :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> Key Indicator -> a2 -> a1 -> HandlerT App IO Html
|
||||
doEditIndicator mUser indicatorId formWidget formEnctype = do
|
||||
(addTargetformWidget, addTargetFormEnctype) <- generateFormPost addTargetForm
|
||||
|
||||
|
|
@ -128,6 +131,7 @@ getDeleteTargetR targetId = do
|
|||
doEditIndicator mUser (targetIndicator target) formWidget formEnctype
|
||||
|
||||
|
||||
doDashboard :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> a2 -> a1 -> HandlerFor App Html
|
||||
doDashboard mUser formWidget formEnctype = do
|
||||
indicators <- runDB $ selectList [] [Asc IndicatorId]
|
||||
|
||||
|
|
@ -247,7 +251,7 @@ getOngoingTargets challengeId = do
|
|||
return indicator
|
||||
indicatorEntries <- mapM indicatorToEntry indicators
|
||||
theNow <- liftIO $ getCurrentTime
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId
|
||||
let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries
|
||||
return indicatorEntries'
|
||||
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do
|
|||
test <- runDB $ get404 testId
|
||||
let testRef = getTestReference (Entity testId test)
|
||||
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId
|
||||
|
||||
let values = map (findParamValue paramName) entries
|
||||
|
||||
|
|
@ -162,7 +162,7 @@ getIndicatorGraphDataR indicatorId = do
|
|||
test <- runDB $ get404 testId
|
||||
let mPrecision = testPrecision test
|
||||
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (testChallenge test)
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) (testChallenge test)
|
||||
|
||||
theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line
|
||||
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ getPresentation4RealR = do
|
|||
|
||||
(Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
|
||||
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId))
|
||||
(evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId
|
||||
(evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
|
||||
let evaluationMaps = take 10 evaluationMaps'
|
||||
|
||||
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName
|
||||
|
|
@ -57,7 +57,7 @@ getPresentationPSNC2019R = do
|
|||
|
||||
(Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
|
||||
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId))
|
||||
(evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId
|
||||
(evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
|
||||
let evaluationMaps = take 10 evaluationMaps'
|
||||
|
||||
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName
|
||||
|
|
|
|||
|
|
@ -100,6 +100,10 @@ getViewVariantR variantId = do
|
|||
let theSubmissionId = variantSubmission variant
|
||||
theSubmission <- runDB $ get404 theSubmissionId
|
||||
|
||||
([entry], tests) <- runDB $ getChallengeSubmissionInfos (\e -> entityKey e == theSubmissionId)
|
||||
(\e -> entityKey e == variantId)
|
||||
(submissionChallenge theSubmission)
|
||||
|
||||
if submissionIsPublic theSubmission || Just (submissionSubmitter theSubmission) == (entityKey <$> mauthId)
|
||||
then
|
||||
do
|
||||
|
|
@ -112,7 +116,6 @@ getViewVariantR variantId = do
|
|||
E.orderBy []
|
||||
return (out, test)
|
||||
|
||||
|
||||
let outputs =
|
||||
sortBy (\a b -> ((snd b) `compare` (snd a)))
|
||||
$ nub
|
||||
|
|
@ -124,15 +127,32 @@ getViewVariantR variantId = do
|
|||
else
|
||||
error "Cannot access this submission variant"
|
||||
|
||||
viewOutput :: (SHA1, Text) -> WidgetFor App ()
|
||||
viewOutput (outputHash, test) = do
|
||||
|
||||
outputEvaluationsTable :: TableEntry -> Table.Table App (Entity Test)
|
||||
outputEvaluationsTable tableEntry = mempty
|
||||
++ Table.text "Metric" (formatTestEvaluationScheme . entityVal)
|
||||
++ Table.text "Score" (\test -> (formatTruncatedScore (testPrecision $ entityVal test)
|
||||
$ extractScore (getTestReference test) tableEntry))
|
||||
|
||||
|
||||
paramsTable :: Table.Table App Parameter
|
||||
paramsTable = mempty
|
||||
++ Table.text "Parameter" parameterName
|
||||
++ Table.text "Value" parameterValue
|
||||
|
||||
viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
|
||||
viewOutput entry tests (outputHash, testSet) = do
|
||||
let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests
|
||||
let outputSha1AsText = fromSHA1ToText $ outputHash
|
||||
$(widgetFile "view-output")
|
||||
|
||||
resultTable :: Entity Submission -> WidgetFor App ()
|
||||
resultTable (Entity submissionId submission) = do
|
||||
(tableEntries, tests) <- handlerToWidget $ runDB $ getChallengeSubmissionInfos (\s -> entityKey s == submissionId)
|
||||
(submissionChallenge submission)
|
||||
(tableEntries, tests) <- handlerToWidget
|
||||
$ runDB
|
||||
$ getChallengeSubmissionInfos (\s -> entityKey s == submissionId)
|
||||
(const True)
|
||||
(submissionChallenge submission)
|
||||
let paramNames =
|
||||
nub
|
||||
$ map (parameterName . entityVal)
|
||||
|
|
|
|||
|
|
@ -174,7 +174,7 @@ idToBeShown _ maybeUser =
|
|||
|
||||
defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe (Entity User) -> Text
|
||||
defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge)
|
||||
defaultRepo Branches repoHost _ repo _ = repoUrl repo
|
||||
defaultRepo Branches _ _ repo _ = repoUrl repo
|
||||
|
||||
defaultBranch :: IsString a => RepoScheme -> Maybe a
|
||||
defaultBranch SelfHosted = Just "master"
|
||||
|
|
@ -430,7 +430,7 @@ checkIndicators user challengeId submissionId submissionLink relevantIndicators
|
|||
|
||||
checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
|
||||
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) challengeId
|
||||
(entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) (const True) challengeId
|
||||
mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
|
||||
|
||||
checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
|
||||
|
|
@ -655,7 +655,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name
|
|||
getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
|
||||
getChallengeSubmissions condition name = do
|
||||
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name
|
||||
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition challengeId
|
||||
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
|
||||
let tests = sortBy testComparator tests'
|
||||
mauth <- maybeAuth
|
||||
let muserId = (\(Entity uid _) -> uid) <$> mauth
|
||||
|
|
|
|||
|
|
@ -77,8 +77,8 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
|
|||
entityKey $ tableEntrySubmitter tableEntry,
|
||||
mauthId))
|
||||
|
||||
paramTable :: [Text] -> [Entity Test] -> Table App TableEntry
|
||||
paramTable paramNames tests = mempty
|
||||
variantTable :: [Text] -> [Entity Test] -> Table App TableEntry
|
||||
variantTable paramNames tests = mempty
|
||||
++ Table.int "#" tableEntryRank
|
||||
++ mconcat (map paramExtractor paramNames)
|
||||
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
|
||||
|
|
@ -203,7 +203,7 @@ getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
|
|||
-> (TableEntry -> [a])
|
||||
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
|
||||
getLeaderboardEntriesByCriterion challengeId condition selector = do
|
||||
(evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition challengeId
|
||||
(evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
|
||||
let mainTests = getMainTests tests
|
||||
let mainTestEnt = getMainTest tests
|
||||
let mainTestRef = getTestReference mainTestEnt
|
||||
|
|
@ -290,8 +290,8 @@ compareResult _ (Just _) Nothing = GT
|
|||
compareResult _ Nothing (Just _) = LT
|
||||
compareResult _ Nothing Nothing = EQ
|
||||
|
||||
getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test])
|
||||
getChallengeSubmissionInfos condition challengeId = do
|
||||
getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> (Entity Variant -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test])
|
||||
getChallengeSubmissionInfos condition variantCondition challengeId = do
|
||||
|
||||
challenge <- get404 challengeId
|
||||
let commit = challengeVersion challenge
|
||||
|
|
@ -317,7 +317,8 @@ getChallengeSubmissionInfos condition challengeId = do
|
|||
$ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1)
|
||||
$ zip scores allSubmissionsVariants
|
||||
|
||||
evaluationMaps <- mapM getEvaluationMap allSubmissionsVariantsWithRanks
|
||||
evaluationMaps' <- mapM getEvaluationMap allSubmissionsVariantsWithRanks
|
||||
let evaluationMaps = filter (variantCondition . tableEntryVariant) evaluationMaps'
|
||||
return (evaluationMaps, tests)
|
||||
|
||||
getScore :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => Key Test -> Key Variant -> ReaderT backend m (Maybe Double)
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@
|
|||
$if null tableEntries
|
||||
<p>No results available. The submission is probably broken.
|
||||
$else
|
||||
^{Table.buildBootstrap (paramTable paramNames tests) tableEntries}
|
||||
^{Table.buildBootstrap (variantTable paramNames tests) tableEntries}
|
||||
|
|
|
|||
|
|
@ -4,4 +4,5 @@
|
|||
<span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
|
||||
<div class="media-body">
|
||||
<div class="media-heading">
|
||||
<div .subm-commit>#{test} / #{outputSha1AsText}
|
||||
<div .subm-commit>#{testSet} / #{outputSha1AsText}
|
||||
^{Table.buildBootstrap (outputEvaluationsTable entry) tests'}
|
||||
|
|
|
|||
|
|
@ -4,5 +4,11 @@
|
|||
<span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
|
||||
<div class="media-body">
|
||||
^{submissionHeader fullSubmissionInfo}
|
||||
|
||||
$case tableEntryParams entry
|
||||
$of []
|
||||
$of _
|
||||
^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)}
|
||||
|
||||
$forall output <- outputs
|
||||
^{viewOutput output}
|
||||
^{viewOutput entry tests output}
|
||||
|
|
|
|||
Loading…
Reference in New Issue