Mark target lines with colors on the dashboard

Handler/Dashboard.hs

@@ -5,13 +5,18 @@ import Import
 import Data.Time.LocalTime
 import Handler.Shared
 import Handler.Common (checkIfAdmin)
+import Handler.Tables
+
+import Data.SubmissionConditions (parseCondition, checkCondition, VariantEntry(..))
 
 import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
 import qualified Yesod.Table as Table
 
 import qualified Data.Text as T
+import qualified Data.Map as M
 
 import Handler.Tables (timestampCell)
+import GEval.Core (isBetter)
 
 data IndicatorEntry = IndicatorEntry {
   indicatorEntryIndicator :: Entity Indicator,
@@ -22,6 +27,9 @@ data IndicatorEntry = IndicatorEntry {
   indicatorEntryTargets :: [Entity Target]
 }
 
+data TargetStatus = TargetPassed | TargetFailed | TargetOngoing
+                    deriving (Eq, Show)
+
 getDashboardR :: Handler Html
 getDashboardR = do
   (formWidget, formEnctype) <- generateFormPost targetForm
@@ -192,6 +200,36 @@ prettyIndicatorEntry :: IndicatorEntry -> Text
 prettyIndicatorEntry entry = prettyTestTitle (entityVal $ indicatorEntryTest entry)
                                              (entityVal $ indicatorEntryChallenge entry)
 
+filterEntries :: Maybe Text -> [TableEntry] -> [TableEntry]
+filterEntries Nothing = id
+filterEntries (Just condition) = filter (\entry -> checkCondition conditionParsed (toVariantEntry entry))
+  where conditionParsed = parseCondition condition
+        toVariantEntry :: TableEntry -> VariantEntry
+        toVariantEntry entry = VariantEntry {
+          variantEntryTags = map (entityVal . fst) $ tableEntryTagsInfo entry,
+          variantEntryParams = map entityVal $ tableEntryParams entry
+          }
+
+getTargetStatus :: UTCTime -> [TableEntry] -> IndicatorEntry -> Entity Target -> TargetStatus
+getTargetStatus theNow entries indicator target =
+  if null entries'
+  then
+    if theNow > (targetDeadline $ entityVal target)
+      then TargetFailed
+      else TargetOngoing
+  else TargetPassed
+  where entries' =
+          filter (\v -> isBetter (testMetric $ entityVal $ indicatorEntryTest indicator)
+                                v
+                                (targetValue $ entityVal target))
+          $ catMaybes
+          $ map evaluationScore
+          $ catMaybes
+          $ map (\e -> (tableEntryMapping e) M.!? testId)
+          $ filter (\e -> (submissionStamp $ entityVal $ tableEntrySubmission e) < theNow)
+          $ filterEntries (indicatorEntryTargetCondition indicator) entries
+        testId = entityKey $ indicatorEntryTest indicator
+
 formatTargets :: IndicatorEntry -> Text
 formatTargets entry = T.intercalate ", " $ (map (formatTarget (testPrecision $ entityVal $ indicatorEntryTest entry))) $ indicatorEntryTargets entry
 

Handler/Graph.hs

@@ -3,7 +3,7 @@ module Handler.Graph where
 import Import
 
 import Handler.Tables
-import Handler.Dashboard (indicatorToEntry, prettyIndicatorEntry, formatTarget, IndicatorEntry(..))
+import Handler.Dashboard (indicatorToEntry, prettyIndicatorEntry, formatTarget, IndicatorEntry(..), TargetStatus(..), filterEntries, getTargetStatus)
 import Handler.Shared (formatParameter, formatScore, getMainTest, compareFun)
 import Data.Maybe
 import Data.List ((!!))
@@ -145,6 +145,11 @@ monotonicBy extractor comparator (theFirst:theRest) = (theFirst : (monotonicBy'
                                      else
                                        monotonicBy' theBest t
 
+targetStatusToClass :: TargetStatus -> String
+targetStatusToClass TargetFailed = "target-failed-line"
+targetStatusToClass TargetPassed = "target-passed-line"
+targetStatusToClass TargetOngoing = "target-ongoing-line"
+
 getIndicatorGraphDataR :: IndicatorId -> Handler Value
 getIndicatorGraphDataR indicatorId = do
   indicator <- runDB $ get404 indicatorId
@@ -159,6 +164,8 @@ getIndicatorGraphDataR indicatorId = do
 
   theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line
 
+  let targetStatuses = map (getTargetStatus theNow entries indicatorEntry) (indicatorEntryTargets indicatorEntry)
+
   -- first we apply the "filter condition"
   let filteredEntries =
         filterEntries (indicatorFilterCondition indicator)
@@ -221,7 +228,7 @@ getIndicatorGraphDataR indicatorId = do
             "type" .= ("step-after" :: String)
             ]
         ],
-    "grid" .= targetsToLines theNow indicatorEntry
+    "grid" .= targetsToLines theNow indicatorEntry targetStatuses
     ]
 
 formatTimestamp :: UTCTime -> Text
@@ -242,19 +249,21 @@ entriesToPoints (Entity testId test) entries = (scores, timePoints)
                              && isJust (evaluationScore ((tableEntryMapping entry) M.! testId))) entries
         comparator = compareFun $ getMetricOrdering $ testMetric test
 
-targetsToLines :: UTCTime -> IndicatorEntry -> Value
+targetsToLines :: UTCTime -> IndicatorEntry -> [TargetStatus] -> Value
-targetsToLines theNow indicator = object [
+targetsToLines theNow indicator statuses = object [
   "y" .= object [
-      "lines" .= map (\target -> object [
+      "lines" .= map (\(target, status) -> object [
                          "value" .= (targetValue $ entityVal target),
-                          "text" .= formatTarget mPrecision target
+                          "text" .= formatTarget mPrecision target,
-                         ]) targets
+                          "class" .= targetStatusToClass status
+                         ]) (zip targets statuses)
       ],
   "x" .= object [
-      "lines" .= ((map (\target -> object [
+      "lines" .= ((map (\(target, status) -> object [
                          "value" .= (formatTimestamp $ targetDeadline $ entityVal target),
-                         "text" .= formatTarget mPrecision target
+                         "text" .= formatTarget mPrecision target,
-                         ]) targets)
+                         "class" .= targetStatusToClass status
+                         ]) $ zip targets statuses)
         ++ [object [
                "value" .= formatTimestamp theNow,
                "text" .= ("now" :: String)
@@ -284,16 +293,6 @@ listIf :: Bool -> [a] -> [a]
 listIf True l = l
 listIf False _ = []
 
-filterEntries :: Maybe Text -> [TableEntry] -> [TableEntry]
-filterEntries Nothing = id
-filterEntries (Just condition) = filter (\entry -> checkCondition conditionParsed (toVariantEntry entry))
-  where conditionParsed = parseCondition condition
-        toVariantEntry :: TableEntry -> VariantEntry
-        toVariantEntry entry = VariantEntry {
-          variantEntryTags = map (entityVal . fst) $ tableEntryTagsInfo entry,
-          variantEntryParams = map entityVal $ tableEntryParams entry
-          }
-
 partitionEntries :: Maybe Text -> [TableEntry] -> ([TableEntry], [TableEntry])
 partitionEntries Nothing entries = (entries, [])
 partitionEntries (Just condition) entries = partition (\entry -> checkCondition conditionParsed (toVariantEntry entry)) entries

gonito.cabal

@@ -126,7 +126,7 @@ library
                  , filemanip
                  , cryptohash
                  , markdown
-                 , geval >= 1.16.1.0 && < 1.17
+                 , geval >= 1.16.2.0 && < 1.17
                  , filepath
                  , yesod-table
                  , regex-tdfa

static/css/extra.css

@@ -11,3 +11,23 @@ body {
     top: 50%;
     transform: translateY(-50%);
 }
+
+.target-failed-line line {
+    stroke: red;
+    fill: red;
+}
+
+.target-failed-line {
+    stroke: red;
+    fill: red;
+}
+
+.target-passed-line line {
+    stroke: green;
+    fill: green;
+}
+
+.target-passed-line {
+    stroke: green;
+    fill: green;
+}