From 5c110716cfda6e616a795edd12f2012b132dca9f Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 2 Apr 2017 17:51:12 +0200 Subject: Add a chart on payments by month by categories --- src/client/Chart/View.elm | 182 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 src/client/Chart/View.elm (limited to 'src/client/Chart/View.elm') diff --git a/src/client/Chart/View.elm b/src/client/Chart/View.elm new file mode 100644 index 0000000..af8b4b7 --- /dev/null +++ b/src/client/Chart/View.elm @@ -0,0 +1,182 @@ +module Chart.View exposing + ( view + ) + +import Html exposing (Html) +import List.Extra as List +import Svg exposing (..) +import Svg.Attributes exposing (..) + +import Chart.Model as Chart exposing (Chart, Serie, Vec2, View) +import Utils.List as List + +view : Chart -> Html msg +view chart = + let { size, title, series } = chart + titleHeight = 100 + captionHeight = 50 + in svg + [ width << toString <| size.x + , height << toString <| size.y + , viewBox ("0 0 " ++ (toString size.x) ++ " " ++ (toString size.y)) + ] + ( [ renderTitle (Chart.mkView { x = 0, y = 0 } { x = size.x, y = titleHeight }) title ] + ++ renderSeriesAndScales (Chart.mkView { x = 50, y = titleHeight } { x = size.x, y = size.y - captionHeight }) chart + ++ renderCaptions (Chart.mkView { x = 0, y = size.y - captionHeight } { x = size.x, y = size.y }) series + ) + +renderTitle : View -> String -> Svg msg +renderTitle view title = + text_ + [ x << toString <| view.fx 0.5 + , y << toString <| view.fy 0.5 + , textAnchor "middle" + , dominantBaseline "middle" + , fontSize "20" + ] + [ text title ] + +renderSeriesAndScales : View -> Chart -> List (Svg msg) +renderSeriesAndScales view chart = + let { keys, series, scaleColor, formatOrdinate } = chart + (p1, p2) = Chart.bounds view + ordinateWidth = 100 + abscissaHeight = 60 + maxScale = Chart.maxScale chart + in ( renderOrdinates (Chart.mkView { x = p1.x, y = p1.y } { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight }) formatOrdinate maxScale + ++ renderAbscissas (Chart.mkView { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight } { x = p2.x, y = p2.y }) keys scaleColor + ++ renderSeries (Chart.mkView { x = p1.x + ordinateWidth, y = p1.y } { x = p2.x, y = p2.y - abscissaHeight }) series maxScale scaleColor + ) + +renderOrdinates : View -> (Float -> String) -> Float -> List (Svg msg) +renderOrdinates view formatOrdinate maxScale = + ordinates + |> List.map (\l -> + text_ + [ x << toString <| view.fx 0.5 + , y << toString <| view.fy l + , textAnchor "middle" + , dominantBaseline "middle" + ] + [ text << formatOrdinate <| (1 - l) * maxScale ] + ) + + +renderAbscissas : View -> List String -> String -> List (Svg msg) +renderAbscissas view keys scaleColor = + let count = List.length keys + in ( abscissasXPositions keys + |> List.map (\(xPos, key) -> + [ text_ + [ x << toString <| view.fx xPos + , y << toString <| view.fy 0.5 + , textAnchor "middle" + , dominantBaseline "middle" + ] + [ text key ] + , line + [ x1 << toString <| view.fx xPos + , y1 << toString <| view.fy 0 + , x2 << toString <| view.fx xPos + , y2 << toString <| view.fy 0.2 + , stroke scaleColor + ] + [] + ] + ) + |> List.concat + ) + +renderSeries : View -> List Serie -> Float -> String -> List (Svg msg) +renderSeries view series maxScale scaleColor = + ( renderHorizontalLines view series scaleColor + ++ renderPoints view series maxScale + ) + +renderHorizontalLines : View -> List Serie -> String -> List (Svg msg) +renderHorizontalLines view series scaleColor = + ordinates + |> List.map (\l -> + line + [ x1 << toString <| view.fx 0 + , y1 << toString <| view.fy l + , x2 << toString <| view.fx 1 + , y2 << toString <| view.fy l + , stroke scaleColor + ] + [] + ) + +renderPoints : View -> List Serie -> Float -> List (Svg msg) +renderPoints view series maxScale = + series + |> List.map (\serie -> + let points = + abscissasXPositions serie.values + |> List.map (\(xPos, value) -> { x = xPos, y = 1 - value / maxScale }) + in [ renderLines view serie.color points + , List.map (renderPoint view serie.color) points + ] + |> List.concat + ) + |> List.concat + +renderLines : View -> String -> List Vec2 -> List (Svg msg) +renderLines view color points = + List.links points + |> List.map (\(p1, p2) -> + line + [ x1 << toString <| view.fx p1.x + , y1 << toString <| view.fy p1.y + , x2 << toString <| view.fx p2.x + , y2 << toString <| view.fy p2.y + , stroke color + ] + [] + ) + +renderPoint : View -> String -> Vec2 -> Svg msg +renderPoint view color pos = + circle + [ cx << toString <| view.fx pos.x + , cy << toString <| view.fy pos.y + , r "4" + , fill color + ] + [] + +abscissasXPositions : List a -> List (Float, a) +abscissasXPositions xs = + let count = List.length xs + in xs + |> List.zip (List.range 1 (count + 1)) + |> List.map (\(i, x) -> (toFloat i / (toFloat count + 1), x)) + +ordinates : List Float +ordinates = + let count = 10 + in List.range 0 (count - 1) + |> List.map (\l -> toFloat l / (toFloat count - 1)) + +renderCaptions : View -> List Serie -> List (Svg msg) +renderCaptions view series = + let count = List.length series + in series + |> List.zip (List.range 1 (List.length series)) + |> List.map (\(i, serie) -> + renderCaption { x = view.fx (toFloat i / (toFloat count + 1)), y = view.fy 0.5 } serie + ) + |> List.concat + +renderCaption : Vec2 -> Serie -> List (Svg msg) +renderCaption point { label, color } = + [ text_ + [ x << toString <| point.x + , y << toString <| point.y + , textAnchor "middle" + , dominantBaseline "middle" + , fill color + , fontSize "18" + ] + [ text label ] + ] -- cgit v1.2.3