feat: graph multiple names

onomastics-ng/cli/Main.hs

@@ -14,8 +14,8 @@ import Options.Applicative
 
 data Options = Options
     { mode :: Mode
-    , surname :: Text
+    , surnames :: [Text]
-    , fillColor :: Maybe Text
+    , colorPalette :: [Text]
     , areaMode :: AreaKind
     }
 
@@ -23,8 +23,8 @@ parseOptions :: Parser Options
 parseOptions =
     Options
         <$> flag Absolute Relative (long "relative" <> help "Relative numbers (instead of absolute)")
-        <*> strArgument (metavar "SURNAME" <> help "Surname")
+        <*> some (strArgument (metavar "SURNAME" <> help "Surname"))
-        <*> optional (strOption (long "color" <> metavar "COLOR" <> help "Color of the SVG"))
+        <*> many (strOption (long "color" <> metavar "COLOR" <> help "Color palette for the SVG"))
         <*> flag District State (long "states" <> help "Analyze by state (instead of district)")
 
 opts :: ParserInfo Options
@@ -38,15 +38,16 @@ main = do
             case mode options of
                 Relative -> relativeCount
                 Absolute -> absoluteCount
-        color = fromMaybe "black" $ fillColor options
+        colors = if null $ colorPalette options then defaultColorPalette else colorPalette options
+        svgSettings = SvgSettings{scaleToMaximum = Global}
     res <- runStoepel manager' $ do
-        let theName = Just $ surname options
+        let theNames = map Just (surnames options)
         ds <- case areaMode options of
             State -> states
             District -> districts
         theStats <- case areaMode options of
-            State -> stateStatistics theName
+            State -> mapM stateStatistics theNames
-            District -> districtStatistics theName
+            District -> mapM districtStatistics theNames
-        let stats = computeAreaStatistics computeFunction ds theStats
+        let stats = map (computeAreaStatistics computeFunction ds) theStats
-        return $ renderMap color ds stats
+        return $ renderMap svgSettings colors ds (zip (surnames options) stats)
     Text.putStrLn res

onomastics-ng/lib/Onomap/Svg.hs

@@ -5,78 +5,115 @@ module Onomap.Svg (drawMap, renderMap) where
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import Data.Text.Lazy (toStrict)
 import qualified Data.Text as Text
+import Data.Text.Lazy (toStrict)
 import Graphics.Svg
+import Onomap.Types (Area (..), ByArea (..), ScaleToMaximum (..), SvgSettings (..))
 import Text.Printf (printf)
-import Onomap.Types (Area (..), ByArea (..))
 
-renderMap :: Text -> [Area] -> ByArea Double -> Text
+renderMap :: SvgSettings -> [Text] -> [Area] -> [(Text, ByArea Double)] -> Text
-renderMap fillColor areas statistics = toStrict $ prettyText $ drawMap fillColor areas statistics
+renderMap settings colorPalette areas statistics = toStrict $ prettyText $ drawMap settings colorPalette areas statistics
 
-drawMap :: Text -> [Area] -> ByArea Double -> Element
+drawMap :: SvgSettings -> [Text] -> [Area] -> [(Text, ByArea Double)] -> Element
-drawMap fillColor areas statistics =
+drawMap settings colorPalette areas statistics =
-    doctype <> with (svg11_ content) [Version_ <<- "1.1", Width_ <<- "650", Height_ <<- "900"]
+    doctype <> with (svg11_ content) [Version_ <<- "1.1", Width_ <<- "650", Height_ <<- Text.pack (show (900 + 20 * length statistics))]
   where
-    theMaximum = maximum $ getByArea statistics
+    theMaxima = map maximum $ map (getByArea . snd) statistics
+    globalMaximum = maximum theMaxima
     localize = Text.replace "." "," . Text.dropWhileEnd (== '.') . Text.dropWhileEnd (== '0')
     showRounded = Text.pack . printf "%.2f"
-    frameColor = "grey"
+    frameColor = "black"
     areaPaths =
         foldMap
             ( \area ->
-                let count = fromMaybe 0 (Map.lookup (key area) (getByArea statistics))
+                path_ [Stroke_ <<- frameColor, Stroke_width_ <<- "0.3px", Fill_ <<- "none", D_ <<- path area]
-                 in path_
+                    <> foldMap
-                        [ Stroke_ <<- frameColor
+                        ( \((surname, statistic), color, theMaximum) ->
-                        , Fill_ <<- fillColor
+                            let count = fromMaybe 0 (Map.lookup (key area) (getByArea statistic))
-                        , Fill_opacity_ <<- showRounded (if count == 0 then 0 else count / theMaximum)
+                                theTitle =
-                        , D_ <<- path area
-                        ]
                                     ( title_
                                         []
                                         ( toElement $
-                                name area <> ": " <> localize (showRounded count)
+                                            mconcat
+                                                [ name area
+                                                , ": "
+                                                , Text.intercalate
+                                                    ", "
+                                                    (map (\(surname, statistic) -> localize (showRounded count) <> " (" <> Text.toTitle surname <> ")") statistics)
+                                                ]
                                         )
                                     )
+                             in path_
+                                    [ D_ <<- path area
+                                    , Fill_ <<- color
+                                    , Fill_opacity_
+                                        <<- showRounded
+                                            ( if count == 0
+                                                then 0
+                                                else
+                                                    count
+                                                        / fromIntegral (length statistics)
+                                                        / ( case scaleToMaximum settings of
+                                                                Global -> globalMaximum
+                                                                Local -> theMaximum
+                                                          )
+                                            )
+                                    , Stroke_ <<- "none"
+                                    ]
+                                    theTitle
+                        )
+                        (zip3 statistics (cycle colorPalette) theMaxima)
             )
             areas
     content =
+        foldMap
+            ( \(index, color, theMaximum) ->
                 defs_
                     []
                     ( linearGradient_
-                [ Id_ <<- "legend"
+                        [ Id_ <<- "legend" <> Text.pack (show index)
                         , X1_ <<- "0"
-                , X2_ <<- "1"
+                        , X2_ <<- case scaleToMaximum settings of
+                            Global -> Text.pack (show (recip $ theMaximum / globalMaximum))
+                            Local -> "1"
                         , Y1_ <<- "0"
                         , Y2_ <<- "0"
                         ]
                         ( stop_ [Offset_ <<- "0%", Stop_color_ <<- "white"]
-                    <> stop_ [Offset_ <<- "100%", Stop_color_ <<- fillColor]
+                            <> stop_ [Offset_ <<- "100%", Stop_color_ <<- color]
                         )
                     )
-            <> g_
+            )
+            (zip3 [0 ..] colorPalette theMaxima)
+            <> foldMap
+                ( \(index, (name, statistic), color) ->
+                    g_
                         []
                         ( rect_
-                    [ X_ <<- "150"
+                            [ X_ <<- "165"
-                    , Y_ <<- "880"
+                            , Y_ <<- Text.pack (show (880 + 20 * index))
                             , Stroke_ <<- frameColor
                             , Width_ <<- "350"
                             , Height_ <<- "10"
-                    , Fill_ <<- "url(#legend)"
+                            , Fill_ <<- "url(#legend" <> Text.pack (show index) <> ")"
                             ]
                             <> text_
-                        [ X_ <<- "135"
+                                [ X_ <<- "155"
-                        , Y_ <<- "890"
+                                , Y_ <<- Text.pack (show (890 + 20 * index))
+                                , Font_size_ <<- "18"
+                                , Fill_ <<- "black"
+                                , Text_anchor_ <<- "end"
+                                ]
+                                (toElement $ Text.toTitle name)
+                            <> text_
+                                [ X_ <<- "525"
+                                , Y_ <<- Text.pack (show (890 + 20 * index))
                                 , Font_size_ <<- "18"
                                 , Fill_ <<- "black"
                                 ]
-                        "0"
+                                (toElement $ localize $ showRounded $ maximum $ getByArea statistic)
-                    <> text_
-                        [ X_ <<- "510"
-                        , Y_ <<- "890"
-                        , Font_size_ <<- "18"
-                        , Fill_ <<- "black"
-                        ]
-                        (toElement $ localize $ showRounded theMaximum)
                         )
+                )
+                (zip3 [0 ..] statistics colorPalette)
+            <> style_ [] "path { mix-blend-mode: multiply; }"
             <> g_ [] areaPaths

onomastics-ng/lib/Onomap/Types.hs

@@ -6,7 +6,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 
-module Onomap.Types (Area (..), AreaKind (..), ByArea (..), relativeCount, absoluteCount, computeAreaStatistics, Mode(..)) where
+module Onomap.Types (Area (..), AreaKind (..), ByArea (..), relativeCount, absoluteCount, computeAreaStatistics, Mode(..), SvgSettings(..), ScaleToMaximum(..), defaultSvgSettings, defaultColorPalette) where
 
 import Control.Arrow ((&&&))
 import Data.Aeson
@@ -20,6 +20,14 @@ import Data.Vector ((!))
 import GHC.Generics
 import Servant.API
 
+data SvgSettings = SvgSettings
+  { scaleToMaximum :: ScaleToMaximum }
+
+defaultSvgSettings :: SvgSettings
+defaultSvgSettings = SvgSettings { scaleToMaximum = Global }
+
+data ScaleToMaximum = Global | Local
+
 data Mode = Relative | Absolute
 
 instance FromHttpApiData Mode where
@@ -95,3 +103,18 @@ absoluteCount _ count = fromIntegral count
 relativeCount area count = million * (fromIntegral count / fromIntegral (population area))
   where
     million = 10 ** 6
+
+
+--  https://matplotlib.org/stable/tutorials/colors/colormaps.html
+defaultColorPalette :: [Text]
+defaultColorPalette =
+    [ "#e41a1c"
+    , "#377eb8"
+    , "#4daf4a"
+    , "#984ea3"
+    , "#ff7f00"
+    , "#ffff33"
+    , "#a65628"
+    , "#f781bf"
+    , "#999999"
+    ]

onomastics-ng/web/Main.hs

@@ -13,8 +13,7 @@ module Main where
 import Control.Monad (liftM2)
 import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (ToJSON (..))
-import Data.List (find)
+import qualified Data.Map as Map (fromList, lookup)
-import qualified Data.Map as Map (fromList, mapWithKey)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import GHC.Generics (Generic)
@@ -28,13 +27,14 @@ import Servant
 import Servant.HTML.Blaze (HTML)
 import Text.Blaze (ToMarkup (..))
 
-data Response = Response {color :: Text, areas :: [Area], statistics :: ByArea Double}
+data Response = Response {color :: [Text], areas :: [Area], statistics :: [(Text, ByArea Double)]}
     deriving (Generic)
 
 instance ToMarkup Response where
     toMarkup response =
         preEscapedToMarkup $
             renderMap
+                (SvgSettings{scaleToMaximum = Global})
                 (color response)
                 (areas response)
                 (statistics response)
@@ -42,29 +42,35 @@ instance ToMarkup Response where
 instance ToJSON Response where
     toJSON response =
         toJSON $
-            Map.mapWithKey
+            Map.fromList $
-                ( \k double ->
+                map
-                    let maybeArea = find ((== k) . key) (areas response)
+                    ( \area ->
-                     in Map.fromList
+                        ( name area
-                            [ ("value" :: Text, toJSON double)
+                        , Map.fromList $
-                            , ("population", toJSON $ fmap population maybeArea)
+                            ("population", toJSON $ population area) :
-                            , ("name", toJSON $ fmap name maybeArea)
+                            map
-                            ]
+                                ( \(surname, stats) ->
+                                    ( surname
+                                    , toJSON $ Map.lookup (key area) (getByArea stats)
                                     )
-                (getByArea $ statistics response)
+                                )
+                                (statistics response)
+                        )
+                    )
+                    (areas response)
 
 type OnomapApi =
     Capture "mode" Mode
-        :> Capture "name" Text
+        :> QueryParams "name" Text
         :> QueryParam "by" AreaKind
-        :> QueryParam "color" Text
+        :> QueryParams "color" Text
-        :> Get '[JSON, HTML] Response
+        :> Get '[HTML] Response
 
 app :: Manager -> ([Area], [Area]) -> Application
 app manager' (theDistricts, theStates) = serve onomapApi server
   where
     server :: Server OnomapApi
-    server = \mode surname maybeAreaKind maybeColor ->
+    server = \mode (surnames :: [Text]) maybeAreaKind colors ->
         liftIO $
             runStoepel manager' $ do
                 let areaMode = fromMaybe District maybeAreaKind
@@ -75,11 +81,19 @@ app manager' (theDistricts, theStates) = serve onomapApi server
                     theAreas = case areaMode of
                         State -> theStates
                         District -> theDistricts
-                theStatistics <-
+                    theNames = map Just surnames
-                    computeAreaStatistics computeFunction theAreas <$> case areaMode of
+                theStats <- case areaMode of
-                        State -> stateStatistics (Just surname)
+                    State -> mapM stateStatistics theNames
-                        District -> districtStatistics (Just surname)
+                    District -> mapM districtStatistics theNames
-                return Response{color = fromMaybe "black" maybeColor, areas = theAreas, statistics = theStatistics}
+                let stats = map (computeAreaStatistics computeFunction theAreas) theStats
+                return
+                    Response
+                        { color = case colors of
+                            [] -> defaultColorPalette
+                            x -> x
+                        , areas = theAreas
+                        , statistics = zip surnames stats
+                        }
     onomapApi :: Proxy OnomapApi
     onomapApi = Proxy