show graphs for params

Handler/Graph.hs

@@ -3,21 +3,71 @@ module Handler.Graph where
 import Import
 
 import Handler.Tables
+import Handler.Shared (getMainTest, formatParameter)
 import Data.Maybe
 import Data.List ((!!))
 import Database.Persist.Sql
+import GEval.Core (MetricValue)
+import qualified Data.Map as M
+
 
 getChallengeGraphDataR :: Text -> Handler Value
 getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeName
 
+data ParamGraphItem = ParamGraphItem TableEntry Text Text MetricValue
+
+data ParamGraphSeries = ParamGraphSeries Text [(TableEntry, Text, MetricValue)]
+
 getChallengeParamGraphDataR :: Text -> Text -> Handler Value
 getChallengeParamGraphDataR challengeName paramName = do
-  return $ object [ "xs" .= object [
-                        "data1" .= ("x1" :: Text),
-                        "data2" .= ("x2" :: Text)],
-                    "columns" .= [
-                      ["x1"::Text, "10", "30", "40"],
-                      ["x2", "10", "20", "50"] ]]
+  (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
+
+  (entries, tests) <- getChallengeSubmissionInfos (const True) challengeId
+
+  let mainTestId = entityKey $ getMainTest tests
+
+  let values = map (findParamValue paramName) entries
+
+  let items = Data.Maybe.catMaybes $ map (toParamGraphItem mainTestId paramName) $ zip entries values
+
+  let series = map (\(label, rs) -> ParamGraphSeries label rs)
+               $ organizeBy
+               $ map (\(ParamGraphItem entry label x y) -> (label, (entry, x, y))) items
+
+  return $ object [
+    "xs" .= object (map (\(ParamGraphSeries seriesName _) -> (seriesName .= (xSeriesName seriesName))) series),
+    "columns" .= ((map toYColumn series) ++ (map toXColumn series))
+                  ]
+toYColumn :: ParamGraphSeries -> [Text]
+toYColumn (ParamGraphSeries seriesName items) =
+  seriesName : (map (\(_,_,v) -> pack $ show v) items)
+
+toXColumn :: ParamGraphSeries -> [Text]
+toXColumn (ParamGraphSeries seriesName items) =
+  (xSeriesName seriesName) : (map (\(_,x,_) -> x) items)
+
+xSeriesName :: Text -> Text
+xSeriesName = (++ "_x")
+
+organizeBy :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
+organizeBy pList = M.toList $ M.fromListWith (++) $ map (\(x, y) -> (x, [y])) pList
+
+toParamGraphItem :: TestId -> Text -> (TableEntry, Maybe Text) -> Maybe ParamGraphItem
+toParamGraphItem _ _ (_, Nothing) = Nothing
+toParamGraphItem tid paramName (entry, Just val) = (ParamGraphItem entry label val) <$> join y
+  where label = unwords (tagsFormatted ++ paramsFormatted)
+        tagsFormatted =
+                map (tagName . entityVal . fst)
+                $ tableEntryTagsInfo entry
+        paramsFormatted =
+                map formatParameter
+                $ filter (\pe -> parameterName pe /= paramName)
+                $ map entityVal $ tableEntryParams entry
+        y = evaluationScore <$> lookup tid (tableEntryMapping entry)
+
+findParamValue :: Text -> TableEntry -> Maybe Text
+findParamValue paramName entry =
+  (parameterValue . entityVal) <$> (find (\e -> parameterName (entityVal e) == paramName) $ tableEntryParams entry)
 
 submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
 submissionsToJSON condition challengeName = do

Handler/Shared.hs

@@ -332,6 +332,12 @@ formatTruncatedScore (Just precision) (Just evaluation) = case evaluationScore e
   Just score -> T.pack $ printf "%0.*f" precision score
   Nothing -> formatFullScore Nothing
 
+formatParameter :: Parameter -> Text
+formatParameter param = parameterName param ++ "=" ++ parameterValue param
+
+formatTest :: Test -> Text
+formatTest test = (testName test) ++ "/" ++ (T.pack $ show $ testMetric test)
+
 findFilePossiblyCompressed :: FilePath -> IO (Maybe FilePath)
 findFilePossiblyCompressed baseFilePath = do
   let possibleFiles = [baseFilePath] ++ (map (baseFilePath <.>)  ["gz", "bz2", "xz"])

Handler/ShowChallenge.hs

@@ -38,6 +38,8 @@ import Data.Text (pack, unpack)
 
 import Data.Conduit.SmartSource
 
+import Data.List (nub)
+
 getShowChallengeR :: Text -> Handler Html
 getShowChallengeR name = do
   (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
@@ -114,7 +116,7 @@ getChallengeHowToR name = do
   challengeLayout False challenge (challengeHowTo challenge settings repo (idToBeShown challenge maybeUser) isIDSet isSSHUploaded mToken)
 
 idToBeShown :: p -> Maybe (Entity User) -> Text
-idToBeShown challenge maybeUser =
+idToBeShown _ maybeUser =
   case maybeUser of
    Just user ->  case userLocalId $ entityVal user of
                  Just localId -> localId
@@ -495,10 +497,37 @@ getChallengeSubmissions condition name = do
 
   challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
 
-  challengeLayout True challenge (challengeAllSubmissionsWidget muserId challenge scheme challengeRepo evaluationMaps tests)
+  let params = sort
+               $ nub
+               $ concat
+               $ map (\entry -> map (parameterName . entityVal) (tableEntryParams entry)) evaluationMaps
+
+  challengeLayout True challenge (challengeAllSubmissionsWidget muserId challenge scheme challengeRepo evaluationMaps tests params)
+
+challengeAllSubmissionsWidget :: Maybe UserId -> Challenge -> RepoScheme -> Repo -> [TableEntry] -> [Entity Test] -> [Text] -> WidgetFor App ()
+challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests params =
+  $(widgetFile "challenge-all-submissions")
+  where chartJSs = mconcat $ map (getChartJs challenge mainTest) params
+        mainTest = entityVal $ getMainTest tests
+
+getChartJs :: Challenge -> Test -> Text -> JavascriptUrl (Route App)
+getChartJs challenge test param = [julius|
+$.getJSON("@{ChallengeParamGraphDataR (challengeName challenge) param}", function(data) {
+        c3.generate({
+                bindto: '#chart-' + #{toJSON param},
+                data: data,
+                axis: {
+                   x: {
+                     label: #{toJSON param},
+                   },
+                   y: {
+                     label: #{toJSON testFormatted},
+                   }
+                }
+    }) });
+|]
+   where testFormatted = formatTest test
 
-challengeAllSubmissionsWidget :: Maybe UserId -> Challenge -> RepoScheme -> Repo -> [TableEntry] -> [Entity Test] -> WidgetFor App ()
-challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests = $(widgetFile "challenge-all-submissions")
 
 challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html
 challengeLayout withHeader challenge widget = do

Handler/Tables.hs

@@ -42,6 +42,11 @@ data TableEntry = TableEntry (Entity Submission)
                              [(Entity Tag, Entity SubmissionTag)]
                              [Entity Parameter]
 
+-- TODO change into a record
+tableEntryParams (TableEntry _ _ _ _ _ paramEnts) = paramEnts
+tableEntryMapping (TableEntry _ _ _ mapping _ _) = mapping
+tableEntryTagsInfo (TableEntry _ _ _ _ tagsInfo _) = tagsInfo
+
 submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App TableEntry
 submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
   ++ Table.text "submitter" (formatSubmitter . (\(TableEntry _  _ (Entity _ submitter) _ _ _) -> submitter))
@@ -65,7 +70,7 @@ descriptionToBeShown s v params = (submissionDescription s) ++ (Data.Text.pack v
                            ""
                          else
                            " " ++ r
-        paramsShown = Data.Text.unwords $ map (\p -> parameterName p ++ "=" ++ parameterValue p) params
+        paramsShown = Data.Text.unwords $ map formatParameter params
 
 extractScore :: Key Test -> TableEntry -> Maybe Evaluation
 extractScore k (TableEntry _  _  _ m _ _) = lookup k m
@@ -105,7 +110,7 @@ statusCell :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, Use
 statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusCellWidget challengeName repoScheme challengeRepo . fun)
 
 resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
-resultCell test fun = hoverTextCell ((testName test) ++ "/" ++ (Data.Text.pack $ show $ testMetric test)) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
+resultCell test fun = hoverTextCell (formatTest test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
 
 statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, a, Maybe a) -> WidgetFor App ()
 statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")

static/css/c3.min.css

@@ -0,0 +1 @@
+.c3 svg{font:10px sans-serif;-webkit-tap-highlight-color:transparent}.c3 line,.c3 path{fill:none;stroke:#000}.c3 text{-webkit-user-select:none;-moz-user-select:none;user-select:none}.c3-bars path,.c3-event-rect,.c3-legend-item-tile,.c3-xgrid-focus,.c3-ygrid{shape-rendering:crispEdges}.c3-chart-arc path{stroke:#fff}.c3-chart-arc rect{stroke:#fff;stroke-width:1}.c3-chart-arc text{fill:#fff;font-size:13px}.c3-grid line{stroke:#aaa}.c3-grid text{fill:#aaa}.c3-xgrid,.c3-ygrid{stroke-dasharray:3 3}.c3-text.c3-empty{fill:grey;font-size:2em}.c3-line{stroke-width:1px}.c3-circle._expanded_{stroke-width:1px;stroke:#fff}.c3-selected-circle{fill:#fff;stroke-width:2px}.c3-bar{stroke-width:0}.c3-bar._expanded_{fill-opacity:1;fill-opacity:.75}.c3-target.c3-focused{opacity:1}.c3-target.c3-focused path.c3-line,.c3-target.c3-focused path.c3-step{stroke-width:2px}.c3-target.c3-defocused{opacity:.3!important}.c3-region{fill:#4682b4;fill-opacity:.1}.c3-brush .extent{fill-opacity:.1}.c3-legend-item{font-size:12px}.c3-legend-item-hidden{opacity:.15}.c3-legend-background{opacity:.75;fill:#fff;stroke:#d3d3d3;stroke-width:1}.c3-title{font:14px sans-serif}.c3-tooltip-container{z-index:10}.c3-tooltip{border-collapse:collapse;border-spacing:0;background-color:#fff;empty-cells:show;-webkit-box-shadow:7px 7px 12px -9px #777;-moz-box-shadow:7px 7px 12px -9px #777;box-shadow:7px 7px 12px -9px #777;opacity:.9}.c3-tooltip tr{border:1px solid #ccc}.c3-tooltip th{background-color:#aaa;font-size:14px;padding:2px 5px;text-align:left;color:#fff}.c3-tooltip td{font-size:13px;padding:3px 6px;background-color:#fff;border-left:1px dotted #999}.c3-tooltip td>span{display:inline-block;width:10px;height:10px;margin-right:6px}.c3-tooltip td.value{text-align:right}.c3-area{stroke-width:0;opacity:.2}.c3-chart-arcs-title{dominant-baseline:middle;font-size:1.3em}.c3-chart-arcs .c3-chart-arcs-background{fill:#e0e0e0;stroke:#fff}.c3-chart-arcs .c3-chart-arcs-gauge-unit{fill:#000;font-size:16px}.c3-chart-arcs .c3-chart-arcs-gauge-max{fill:#777}.c3-chart-arcs .c3-chart-arcs-gauge-min{fill:#777}.c3-chart-arc .c3-gauge-value{fill:#000}.c3-chart-arc.c3-target g path{opacity:1}.c3-chart-arc.c3-target.c3-focused g path{opacity:1}

templates/challenge-all-submissions.hamlet

@@ -3,7 +3,19 @@
 
 ^{Table.buildBootstrap (submissionsTable muserId (challengeName challenge) scheme challengeRepo tests) submissions}
 
+$if not (null params)
+   <h3>Submission graph
+
 <div id="graph-container">
 
 <script src="/static/js/sigma.min.js">
 <script src="/static/js/sigma.parsers.json.min.js">
+
+$if not (null params)
+  <h3>Graphs by parameters
+
+  $forall param <- params
+    <div id="chart-#{param}"></div>
+
+  <script src="/static/js/d3.min.js" charset="utf-8"></script>
+  <script src="/static/js/c3.min.js"></script>

templates/challenge-all-submissions.julius

@@ -10,3 +10,5 @@
        'pageLength': 50,
        'order': [[1, 'desc']]});
   } );
+
+^{chartJSs}

templates/default-layout-wrapper.hamlet

@@ -14,6 +14,7 @@ $newline never
 
     <!--datatables, including JQuery-->
     <link rel="stylesheet" type="text/css" href="/static/css/datatables.min.css"/>
+    <link rel="stylesheet" type="text/css" href="/static/css/c3.min.css"/>
     <script type="text/javascript" src="/static/js/datatables.min.js">
 
     <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/bootstrap.min.css"