diff --git a/Handler/Dashboard.hs b/Handler/Dashboard.hs index 0fda26d..da4cab9 100644 --- a/Handler/Dashboard.hs +++ b/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 diff --git a/Handler/Graph.hs b/Handler/Graph.hs index d8d9d1a..91079b4 100644 --- a/Handler/Graph.hs +++ b/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 theNow indicator = object [ +targetsToLines :: UTCTime -> IndicatorEntry -> [TargetStatus] -> Value +targetsToLines theNow indicator statuses = object [ "y" .= object [ - "lines" .= map (\target -> object [ + "lines" .= map (\(target, status) -> object [ "value" .= (targetValue $ entityVal target), - "text" .= formatTarget mPrecision target - ]) targets + "text" .= formatTarget mPrecision target, + "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 - ]) targets) + "text" .= formatTarget mPrecision target, + "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 diff --git a/gonito.cabal b/gonito.cabal index 58081eb..e0ab7fd 100644 --- a/gonito.cabal +++ b/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 diff --git a/static/css/extra.css b/static/css/extra.css index fd75144..c2025d5 100644 --- a/static/css/extra.css +++ b/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; +}