Format variant results as cross tables

This commit is contained in:
Filip Gralinski 2020-01-04 22:34:03 +01:00
parent 67f67d195f
commit 2fd5ee15a2
4 changed files with 23 additions and 10 deletions

View File

@ -18,8 +18,9 @@ import Database.Esqueleto ((^.))
import qualified Data.Text as T import qualified Data.Text as T
import Data.List (nub) import Data.List (nub, (!!))
import Data.List.Extra (groupOn) import Data.List.Extra (groupOn)
import qualified Data.Map.Lazy as LM
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
@ -29,6 +30,8 @@ import GEval.LineByLine (runLineByLineGeneralized, LineRecord(..))
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import System.FilePath (takeFileName) import System.FilePath (takeFileName)
import Data.SplitIntoCrossTabs
rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a] rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
rawCommitQuery sha1Prefix = rawCommitQuery sha1Prefix =
rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"] rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
@ -216,12 +219,14 @@ getViewVariantR variantId = do
error "Cannot access this submission variant" error "Cannot access this submission variant"
outputEvaluationsTable :: TableEntry -> Table.Table App (Entity Test) crossTableDefinition :: TableWithValues Text -> Table.Table App (Text, [Text])
outputEvaluationsTable tableEntry = mempty crossTableDefinition (TableWithValues (headerH : headerR) _) = mempty
++ Table.text "Metric" (formatTestEvaluationScheme . entityVal) ++ Table.text headerH fst
++ Table.text "Score" (\test -> (formatTruncatedScore (testPrecision $ entityVal test) ++ mconcat (map (\(ix, h) -> Table.text h ((!! ix) . snd)) $ zip [0..] headerR)
$ extractScore (getTestReference test) tableEntry)) crossTableDefinition _ = error $ "cross-tab of an unexpected size"
crossTableBody :: TableWithValues Text -> [(Text, [Text])]
crossTableBody (TableWithValues _ rows) = rows
paramsTable :: Table.Table App Parameter paramsTable :: Table.Table App Parameter
paramsTable = mempty paramsTable = mempty
@ -233,7 +238,6 @@ viewOutput entry tests (outputHash, testSet) = do
let tests'@(mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests let tests'@(mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests
let outputSha1AsText = fromSHA1ToText $ outputHash let outputSha1AsText = fromSHA1ToText $ outputHash
mRepoDir <- handlerToWidget $ justGetSubmissionRepoDir (entityKey $ tableEntrySubmission entry)
let variant = variantName $ entityVal $ tableEntryVariant entry let variant = variantName $ entityVal $ tableEntryVariant entry
let theStamp = submissionStamp $ entityVal $ tableEntrySubmission entry let theStamp = submissionStamp $ entityVal $ tableEntrySubmission entry
@ -245,9 +249,17 @@ viewOutput entry tests (outputHash, testSet) = do
let mainMetric = testMetric $ entityVal mainTest let mainMetric = testMetric $ entityVal mainTest
let testLabels = map (formatTestEvaluationScheme . entityVal) tests'
let mapping = LM.fromList $ map (\test -> (formatTestEvaluationScheme $ entityVal test,
(formatTruncatedScore (testPrecision $ entityVal test)
$ extractScore (getTestReference test) entry))) tests'
let crossTables = splitIntoTablesWithValues "Metric" "Score" mapping testLabels
mResult <- mResult <-
if shouldBeShown if shouldBeShown
then then
do
mRepoDir <- handlerToWidget $ justGetSubmissionRepoDir (entityKey $ tableEntrySubmission entry)
case mRepoDir of case mRepoDir of
Just repoDir -> do Just repoDir -> do
outFile' <- liftIO $ lookForCompressedFiles (repoDir </> (T.unpack variant) <.> "tsv") outFile' <- liftIO $ lookForCompressedFiles (repoDir </> (T.unpack variant) <.> "tsv")

View File

@ -128,7 +128,7 @@ library
, filemanip , filemanip
, cryptohash , cryptohash
, markdown , markdown
, geval >= 1.24 && < 1.27 , geval >= 1.27 && < 1.28
, filepath , filepath
, yesod-table , yesod-table
, regex-tdfa , regex-tdfa

View File

@ -4,5 +4,5 @@ flags:
dev: false dev: false
packages: packages:
- '.' - '.'
extra-deps: [../geval,wai-handler-fastcgi-3.0.0.2,murmur3-1.0.3,random-strings-0.1.1.0,naturalcomp-0.0.3,Munkres-0.1,Chart-1.9.1,Chart-cairo-1.9.1,multiset-0.3.4.1,pwstore-fast-2.4.4,yesod-table-2.0.3,esqueleto-3.0.0] extra-deps: [../geval,wai-handler-fastcgi-3.0.0.2,murmur3-1.0.3,random-strings-0.1.1.0,naturalcomp-0.0.3,Munkres-0.1,Chart-1.9.1,Chart-cairo-1.9.1,multiset-0.3.4.1,pwstore-fast-2.4.4,yesod-table-2.0.3,esqueleto-3.0.0,'ordered-containers-0.2.2@sha256:ebf2be3f592d9cf148ea6b8375f8af97148d44f82d8d04476899285e965afdbf,810']
resolver: lts-12.26 resolver: lts-12.26

View File

@ -5,7 +5,8 @@
<div class="media-body"> <div class="media-body">
<div class="media-heading"> <div class="media-heading">
<div .subm-commit>#{testSet} / #{outputSha1AsText} <div .subm-commit>#{testSet} / #{outputSha1AsText}
^{Table.buildBootstrap (outputEvaluationsTable entry) tests'} $forall crossTable <- crossTables
^{Table.buildBootstrap (crossTableDefinition crossTable) (crossTableBody crossTable)}
$maybe result <- mResult $maybe result <- mResult
<h4>worst items <h4>worst items
^{Table.buildBootstrap (lineByLineTable mainTest theStamp) result} ^{Table.buildBootstrap (lineByLineTable mainTest theStamp) result}