Add first version of indicator graphs

This commit is contained in:
Filip Graliński 2018-09-21 17:55:00 +02:00 committed by Filip Gralinski
parent 6db055b219
commit a2ae700158
7 changed files with 206 additions and 10 deletions

View File

@ -1,5 +1,3 @@
module Handler.Dashboard where module Handler.Dashboard where
import Import import Import
@ -116,11 +114,22 @@ doDashboard mUser formWidget formEnctype = do
indicators <- runDB $ selectList [] [Asc IndicatorId] indicators <- runDB $ selectList [] [Asc IndicatorId]
indicatorEntries <- mapM indicatorToEntry indicators indicatorEntries <- mapM indicatorToEntry indicators
let indicatorJSs = getIndicatorChartJss indicatorEntries
defaultLayout $ do defaultLayout $ do
setTitle "Dashboard" setTitle "Dashboard"
$(widgetFile "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 :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site) => Entity Indicator -> HandlerFor site IndicatorEntry
indicatorToEntry indicatorEnt@(Entity indicatorId indicator) = runDB $ do indicatorToEntry indicatorEnt@(Entity indicatorId indicator) = runDB $ do
let theTestId = indicatorTest indicator let theTestId = indicatorTest indicator
@ -183,7 +192,7 @@ formatTargets :: IndicatorEntry -> Text
formatTargets = T.intercalate ", " . (map formatTarget) . indicatorEntryTargets formatTargets = T.intercalate ", " . (map formatTarget) . indicatorEntryTargets
formatTarget :: Entity Target -> Text 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 :: Maybe (Entity User) -> Table.Table App IndicatorEntry
indicatorStatusCell mUser = Table.widget "" (indicatorStatusCellWidget mUser) indicatorStatusCell mUser = Table.widget "" (indicatorStatusCellWidget mUser)

View File

@ -3,13 +3,20 @@ module Handler.Graph where
import Import import Import
import Handler.Tables 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.Maybe
import Data.List ((!!)) import Data.List ((!!))
import Database.Persist.Sql import Database.Persist.Sql
import GEval.Core (MetricValue) import GEval.Core (MetricValue, getMetricOrdering)
import qualified Data.Map as M 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 :: Text -> Handler Value
getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeName getChallengeGraphDataR challengeName = submissionsToJSON (\_ -> True) challengeName
@ -37,6 +44,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do
"xs" .= object (map (\(ParamGraphSeries seriesName _) -> (seriesName .= (xSeriesName seriesName))) series), "xs" .= object (map (\(ParamGraphSeries seriesName _) -> (seriesName .= (xSeriesName seriesName))) series),
"columns" .= ((map (toYColumn $ testPrecision test) series) ++ (map toXColumn series)) "columns" .= ((map (toYColumn $ testPrecision test) series) ++ (map toXColumn series))
] ]
toYColumn :: Maybe Int -> ParamGraphSeries -> [Text] toYColumn :: Maybe Int -> ParamGraphSeries -> [Text]
toYColumn mPrecision (ParamGraphSeries seriesName items) = toYColumn mPrecision (ParamGraphSeries seriesName items) =
seriesName : (map (\(_,_,v) -> formatScore mPrecision v) items) seriesName : (map (\(_,_,v) -> formatScore mPrecision v) items)
@ -122,7 +130,172 @@ edgeId = ("e" ++) . show . fromSqlKey
stampToX :: UTCTime -> Integer stampToX :: UTCTime -> Integer
stampToX = toModifiedJulianDay . utctDay 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 :: (Fractional b, Ord b) => [b] -> b
interQuantile [] = 10.0 interQuantile [] = 10.0

View File

@ -401,3 +401,7 @@ getIsHigherTheBetterArray = Array
. testMetric) . testMetric)
where convertIsHigherTheBetter TheHigherTheBetter = Bool True where convertIsHigherTheBetter TheHigherTheBetter = Bool True
convertIsHigherTheBetter _ = Bool False convertIsHigherTheBetter _ = Bool False
compareFun :: MetricOrdering -> Double -> Double -> Ordering
compareFun TheLowerTheBetter = flip compare
compareFun TheHigherTheBetter = compare

View File

@ -47,6 +47,9 @@ tableEntryParams (TableEntry _ _ _ _ _ paramEnts) = paramEnts
tableEntryMapping (TableEntry _ _ _ mapping _ _) = mapping tableEntryMapping (TableEntry _ _ _ mapping _ _) = mapping
tableEntryTagsInfo (TableEntry _ _ _ _ tagsInfo _) = tagsInfo 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 :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App TableEntry
submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.text "submitter" (formatSubmitter . (\(TableEntry _ _ (Entity _ submitter) _ _ _) -> submitter)) ++ Table.text "submitter" (formatSubmitter . (\(TableEntry _ _ (Entity _ submitter) _ _ _) -> submitter))
@ -209,10 +212,6 @@ compareResult _ (Just _) Nothing = GT
compareResult _ Nothing (Just _) = LT compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ compareResult _ Nothing Nothing = EQ
compareFun :: MetricOrdering -> Double -> Double -> Ordering
compareFun TheLowerTheBetter = flip compare
compareFun TheHigherTheBetter = compare
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) getChallengeSubmissionInfos :: ((Entity Submission) -> Bool)
-> Key Challenge -> Key Challenge
-> Handler ([TableEntry], [Entity Test]) -> Handler ([TableEntry], [Entity Test])

View File

@ -25,6 +25,8 @@
/trigger-remotely TriggerRemotelyR POST /trigger-remotely TriggerRemotelyR POST
/trigger-locally TriggerLocallyR POST /trigger-locally TriggerLocallyR POST
/indicator-graph-data/#IndicatorId IndicatorGraphDataR GET
/q QueryFormR GET POST /q QueryFormR GET POST
/q/#Text QueryResultsR GET /q/#Text QueryResultsR GET

View File

@ -1,5 +1,13 @@
<h1>Dashboard <h1>Dashboard
$forall indicatorEntry <- indicatorEntries
<div style="height:800px" id="indicator-chart-#{toPathPiece $ entityKey $ indicatorEntryIndicator indicatorEntry}">
<script src="/static/js/d3.min.js" charset="utf-8"></script>
<script src="/static/js/c3.min.js"></script>
<hr>
^{Table.buildBootstrap (indicatorTable mUser) indicatorEntries} ^{Table.buildBootstrap (indicatorTable mUser) indicatorEntries}
<hr> <hr>

View File

@ -0,0 +1 @@
^{indicatorJSs}