diff --git a/Handler/Dashboard.hs b/Handler/Dashboard.hs index d1cac4a..1476799 100644 --- a/Handler/Dashboard.hs +++ b/Handler/Dashboard.hs @@ -1,5 +1,3 @@ - - module Handler.Dashboard where import Import @@ -116,11 +114,22 @@ doDashboard mUser formWidget formEnctype = do indicators <- runDB $ selectList [] [Asc IndicatorId] indicatorEntries <- mapM indicatorToEntry indicators + let indicatorJSs = getIndicatorChartJss indicatorEntries defaultLayout $ do setTitle "Dashboard" $(widgetFile "dashboard") +getIndicatorChartJss :: [IndicatorEntry] -> JavascriptUrl (Route App) +getIndicatorChartJss entries = + mconcat $ map (getIndicatorChartJs . entityKey . indicatorEntryIndicator) entries + +getIndicatorChartJs :: IndicatorId -> JavascriptUrl (Route App) +getIndicatorChartJs indicatorId = [julius| +$.getJSON("@{IndicatorGraphDataR indicatorId}", function(data) { + c3.generate(data) }); +|] + indicatorToEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site) => Entity Indicator -> HandlerFor site IndicatorEntry indicatorToEntry indicatorEnt@(Entity indicatorId indicator) = runDB $ do let theTestId = indicatorTest indicator @@ -183,7 +192,7 @@ formatTargets :: IndicatorEntry -> Text formatTargets = T.intercalate ", " . (map formatTarget) . indicatorEntryTargets formatTarget :: Entity Target -> Text -formatTarget (Entity _ target) = (T.pack $ show $ targetValue target) <> " (" <> (T.pack $ show $ targetDeadline target) ++ ")" +formatTarget (Entity _ target) = (T.pack $ show $ targetValue target) <> " (" <> (T.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M" $ targetDeadline target) ++ ")" indicatorStatusCell :: Maybe (Entity User) -> Table.Table App IndicatorEntry indicatorStatusCell mUser = Table.widget "" (indicatorStatusCellWidget mUser) diff --git a/Handler/Graph.hs b/Handler/Graph.hs index d62d2dc..75efd52 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -3,13 +3,20 @@ module Handler.Graph where import Import import Handler.Tables -import Handler.Shared (formatParameter, formatScore, getMainTest) +import Handler.Dashboard (indicatorToEntry, prettyIndicatorEntry, formatTarget, IndicatorEntry(..)) +import Handler.Shared (formatParameter, formatScore, getMainTest, compareFun) import Data.Maybe import Data.List ((!!)) import Database.Persist.Sql -import GEval.Core (MetricValue) +import GEval.Core (MetricValue, getMetricOrdering) import qualified Data.Map as M +import qualified Data.Text as T +import Data.Aeson (KeyValue) + +import Data.SubmissionConditions (parseCondition, checkCondition, VariantEntry(..)) + +-- graphs for parameters getChallengeGraphDataR :: Text -> Handler Value getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeName @@ -37,6 +44,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do "xs" .= object (map (\(ParamGraphSeries seriesName _) -> (seriesName .= (xSeriesName seriesName))) series), "columns" .= ((map (toYColumn $ testPrecision test) series) ++ (map toXColumn series)) ] + toYColumn :: Maybe Int -> ParamGraphSeries -> [Text] toYColumn mPrecision (ParamGraphSeries seriesName items) = seriesName : (map (\(_,_,v) -> formatScore mPrecision v) items) @@ -122,7 +130,172 @@ edgeId = ("e" ++) . show . fromSqlKey stampToX :: UTCTime -> Integer stampToX = toModifiedJulianDay . utctDay --- taken from Math.Statistics +-- Indicator graph + +-- Reduce a list to item which are larger than the largest item encountered so far. +-- (Needed to plot a step graph.) +monotonicBy :: (a -> b) -> (b -> b -> Ordering) -> [a] -> [a] +monotonicBy _ _ [] = [] +monotonicBy extractor comparator (theFirst:theRest) = (theFirst : (monotonicBy' theFirst theRest)) + where monotonicBy' _ [] = [] + monotonicBy' theBest (h:t) = if extractor h `comparator` extractor theBest == GT + then + (h:(monotonicBy' h t)) + else + monotonicBy' theBest t + +getIndicatorGraphDataR :: IndicatorId -> Handler Value +getIndicatorGraphDataR indicatorId = do + indicator <- runDB $ get404 indicatorId + indicatorEntry <- indicatorToEntry (Entity indicatorId indicator) + let label = prettyIndicatorEntry indicatorEntry + + let testId = indicatorTest indicator + test <- runDB $ get404 testId + let mPrecision = testPrecision test + + (entries, _) <- getChallengeSubmissionInfos (const True) (testChallenge test) + + theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line + + -- first we apply the "filter condition" + let filteredEntries = + filterEntries (indicatorFilterCondition indicator) + $ sortBy (\a b -> (tableEntryStamp a) `compare` (tableEntryStamp b)) entries + + -- ... all the entires that passed the "filter condition" are split according + -- to whether the main "target condition" is fulfilled or not, + -- "other..." will mean items for which "target condition" is not fulfilled + -- (but the "filter condition" was), they are also going to be used to draw + -- an auxilliary graph + let (targetEntries, otherEntries) = + partitionEntries (indicatorTargetCondition indicator) filteredEntries + let (scores, timePoints) = addNow theNow $ entriesToPoints (Entity testId test) targetEntries + let (otherScores, otherTimePoints) = addNow theNow $ entriesToPoints (Entity testId test) otherEntries + let otherLabel = label <> " (other filtered)" + + -- grid lines for targets would not be taken into account when determining y range, + -- that's why we need to enforce y range manually if needed + -- (x range are not modified this way) + let targetValues = map (targetValue . entityVal) $ indicatorEntryTargets indicatorEntry + let maxRange = getBound compare scores targetValues + let minRange = getBound (flip compare) scores targetValues + + -- we return a JSON object required by the C3 library + return $ object [ + "bindto" .= ("#indicator-chart-" ++ (show $ unSqlBackendKey $ unIndicatorKey indicatorId)), + "data" .= object [ + "xs" .= object ([ + label .= ("xt" :: String) + ] ++ (listIf (not $ null otherScores) [otherLabel .= ("xo" :: String)])), + "columns" .= ([ + ("xt" : timePoints), + (label : (map (formatScore mPrecision) scores))] + ++ (listIf (not $ null otherScores) [ + ("xo" : otherTimePoints), + (otherLabel : (map (formatScore mPrecision) otherScores))])), + "types" .= object [ + label .= ("area-step" :: String), + otherLabel .= ("step" :: String) + ] + ], + "axis" .= object [ + "x" .= object [ + "type" .= ("timeseries" :: String), + "tick" .= object [ + "format" .= ("%Y-%m-%d" :: String) + ] + ], + "y" .= object ((getBoundAttr "max" maxRange) ++ (getBoundAttr "min" minRange)) + ], + "line" .= object [ + "step" .= object [ + "type" .= ("step-after" :: String) + ] + ], + "grid" .= targetsToLines theNow indicatorEntry + ] + +formatTimestamp :: UTCTime -> Text +formatTimestamp = T.pack . formatTime defaultTimeLocale "%Y-%m-%d" + +-- add fake entry for the current time +addNow :: UTCTime -> ([Double], [Text]) -> ([Double], [Text]) +addNow _ ([], []) = ([], []) +addNow theNow (scores, timepoints) = (scores ++ [last $ impureNonNull scores], timepoints ++ [formatTimestamp theNow]) + +entriesToPoints :: Entity Test -> [TableEntry] -> ([Double], [Text]) +entriesToPoints (Entity testId test) entries = (scores, timePoints) + where timePoints = map (formatTimestamp . tableEntryStamp) relevantEntries + scores = map (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testId) relevantEntries + relevantEntries = + monotonicBy (\entry -> fromJust $ evaluationScore $ (tableEntryMapping entry) M.! testId) comparator + $ filter (\entry -> testId `M.member` (tableEntryMapping entry) + && isJust (evaluationScore ((tableEntryMapping entry) M.! testId))) entries + comparator = compareFun $ getMetricOrdering $ testMetric test + +targetsToLines :: UTCTime -> IndicatorEntry -> Value +targetsToLines theNow indicator = object [ + "y" .= object [ + "lines" .= map (\target -> object [ + "value" .= (targetValue $ entityVal target), + "text" .= formatTarget target + ]) targets + ], + "x" .= object [ + "lines" .= ((map (\target -> object [ + "value" .= (formatTimestamp $ targetDeadline $ entityVal target), + "text" .= formatTarget target + ]) targets) + ++ [object [ + "value" .= formatTimestamp theNow, + "text" .= ("now" :: String) + ]]) + ] + ] + where targets = indicatorEntryTargets indicator + +getBound :: (a -> a -> Ordering) -> [a] -> [a] -> Maybe a +getBound _ [] _ = Nothing +getBound _ _ [] = Nothing +getBound comparator mainList extraList = + let mainMax = maximumBy comparator (impureNonNull mainList) + extraMax = maximumBy comparator (impureNonNull extraList) + in case extraMax `comparator` mainMax of + GT -> Just extraMax + _ -> Nothing + +getBoundAttr :: KeyValue p => Text -> Maybe Double -> [p] +getBoundAttr _ Nothing = [] +getBoundAttr label (Just s) = [ + label .= s + ] + +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 + where conditionParsed = parseCondition condition + toVariantEntry :: TableEntry -> VariantEntry + toVariantEntry entry = VariantEntry { + variantEntryTags = map (entityVal . fst) $ tableEntryTagsInfo entry, + variantEntryParams = map entityVal $ tableEntryParams entry + } + +-- auxiliary functions taken from Math.Statistics interQuantile :: (Fractional b, Ord b) => [b] -> b interQuantile [] = 10.0 diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 7321e2c..9425027 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -401,3 +401,7 @@ getIsHigherTheBetterArray = Array . testMetric) where convertIsHigherTheBetter TheHigherTheBetter = Bool True convertIsHigherTheBetter _ = Bool False + +compareFun :: MetricOrdering -> Double -> Double -> Ordering +compareFun TheLowerTheBetter = flip compare +compareFun TheHigherTheBetter = compare diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 9e982b8..b0c3971 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -47,6 +47,9 @@ tableEntryParams (TableEntry _ _ _ _ _ paramEnts) = paramEnts tableEntryMapping (TableEntry _ _ _ mapping _ _) = mapping tableEntryTagsInfo (TableEntry _ _ _ _ tagsInfo _) = tagsInfo +tableEntryStamp :: TableEntry -> UTCTime +tableEntryStamp (TableEntry submission _ _ _ _ _) = submissionStamp $ entityVal submission + 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)) @@ -209,10 +212,6 @@ compareResult _ (Just _) Nothing = GT compareResult _ Nothing (Just _) = LT compareResult _ Nothing Nothing = EQ -compareFun :: MetricOrdering -> Double -> Double -> Ordering -compareFun TheLowerTheBetter = flip compare -compareFun TheHigherTheBetter = compare - getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([TableEntry], [Entity Test]) diff --git a/config/routes b/config/routes index 51e8f23..de38217 100644 --- a/config/routes +++ b/config/routes @@ -25,6 +25,8 @@ /trigger-remotely TriggerRemotelyR POST /trigger-locally TriggerLocallyR POST +/indicator-graph-data/#IndicatorId IndicatorGraphDataR GET + /q QueryFormR GET POST /q/#Text QueryResultsR GET diff --git a/templates/dashboard.hamlet b/templates/dashboard.hamlet index 1065d4b..4366564 100644 --- a/templates/dashboard.hamlet +++ b/templates/dashboard.hamlet @@ -1,5 +1,13 @@

Dashboard +$forall indicatorEntry <- indicatorEntries +
+ + + + +
+ ^{Table.buildBootstrap (indicatorTable mUser) indicatorEntries}
diff --git a/templates/dashboard.julius b/templates/dashboard.julius new file mode 100644 index 0000000..c92923c --- /dev/null +++ b/templates/dashboard.julius @@ -0,0 +1 @@ +^{indicatorJSs}