Add a chart on payments by month by categories

3 files changed, 296 insertions, 0 deletions

diff --git a/src/client/Chart/Api.elm b/src/client/Chart/Api.elm
new file mode 100644
index 0000000..693f362
--- /dev/null
+++ b/src/client/Chart/Api.elm
@@ -0,0 +1,41 @@
+module Chart.Api exposing
+  ( from
+  , withSize
+  , withTitle
+  , withOrdinate
+  , toHtml
+  )
+
+import Html exposing (Html)
+import Svg exposing (..)
+import Svg.Attributes exposing (..)
+
+import Chart.Model as Chart exposing (Chart, Serie, Vec2, View)
+import Chart.View as Chart
+
+from : List String -> List Serie -> Chart
+from keys series =
+  { keys = keys
+  , series = series
+  , size = { x = 600, y = 400 }
+  , title = ""
+  , scaleColor = "#DDDDDD"
+  , formatOrdinate = toString
+  , ordinateLines = 5
+  }
+
+withSize : Vec2 -> Chart -> Chart
+withSize size chart = { chart | size = size }
+
+withTitle : String -> Chart -> Chart
+withTitle title chart = { chart | title = title }
+
+withOrdinate : Int -> (Float -> String) -> Chart -> Chart
+withOrdinate lines format chart =
+  { chart
+  | formatOrdinate = format
+  , ordinateLines = lines
+  }
+
+toHtml : Chart -> Html msg
+toHtml chart = Chart.view chart
diff --git a/src/client/Chart/Model.elm b/src/client/Chart/Model.elm
new file mode 100644
index 0000000..b5c176f
--- /dev/null
+++ b/src/client/Chart/Model.elm
@@ -0,0 +1,73 @@
+module Chart.Model exposing
+  ( Chart
+  , Serie
+  , maxScale
+  , Vec2
+  , View
+  , mkView
+  , bounds
+  )
+
+import List.Extra as List
+
+type alias Chart =
+  { keys : List String
+  , series : List Serie
+  , size : Vec2
+  , title : String
+  , scaleColor : String
+  , formatOrdinate : Float -> String
+  , ordinateLines : Int
+  }
+
+type alias Serie =
+  { values : List Float
+  , color : String
+  , label : String
+  }
+
+maxScale : Chart -> Float
+maxScale { keys, series } =
+  List.range 0 (List.length keys - 1)
+    |> List.map (\i ->
+         series
+           |> List.map (truncate << Maybe.withDefault 0 << List.getAt i << .values)
+           |> List.maximum
+           |> Maybe.withDefault 0
+       )
+    |> List.maximum
+    |> Maybe.withDefault 0
+    |> upperBound
+
+upperBound : Int -> Float
+upperBound n = toFloat (upperBoundInt 0 n)
+
+upperBoundInt : Int -> Int -> Int
+upperBoundInt count n =
+  if n < 10
+    then
+      (n + 1) * (10 ^ count)
+    else
+      upperBoundInt (count + 1) (n // 10)
+
+type alias Vec2 =
+  { x : Float
+  , y : Float
+  }
+
+type alias View =
+  { fx : Float -> Float
+  , fy : Float -> Float
+  }
+
+mkView : Vec2 -> Vec2 -> View
+mkView p1 p2 =
+  { fx = \x -> p1.x + x * (p2.x - p1.x)
+  , fy = \y -> p1.y + y * (p2.y - p1.y)
+  }
+
+bounds : View -> (Vec2, Vec2)
+bounds { fx, fy } =
+  ( { x = fx 0, y = fy 0 }
+  , { x = fx 1, y = fy 1 }
+  )
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 ]
+  ]