From 924cc7ca219a2ea7cb126a9b9546e04d3267bbf5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Fri, 7 Oct 2022 02:21:34 +0200 Subject: [PATCH] feat: graph multiple names --- onomastics-ng/cli/Main.hs | 21 +++-- onomastics-ng/lib/Onomap/Svg.hs | 151 +++++++++++++++++++----------- onomastics-ng/lib/Onomap/Types.hs | 25 ++++- onomastics-ng/web/Main.hs | 58 +++++++----- 4 files changed, 165 insertions(+), 90 deletions(-) diff --git a/onomastics-ng/cli/Main.hs b/onomastics-ng/cli/Main.hs index 91d7191..b8576dc 100644 --- a/onomastics-ng/cli/Main.hs +++ b/onomastics-ng/cli/Main.hs @@ -14,8 +14,8 @@ import Options.Applicative data Options = Options { mode :: Mode - , surname :: Text - , fillColor :: Maybe Text + , surnames :: [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") - <*> optional (strOption (long "color" <> metavar "COLOR" <> help "Color of the SVG")) + <*> some (strArgument (metavar "SURNAME" <> help "Surname")) + <*> 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 - District -> districtStatistics theName - let stats = computeAreaStatistics computeFunction ds theStats - return $ renderMap color ds stats + State -> mapM stateStatistics theNames + District -> mapM districtStatistics theNames + let stats = map (computeAreaStatistics computeFunction ds) theStats + return $ renderMap svgSettings colors ds (zip (surnames options) stats) Text.putStrLn res diff --git a/onomastics-ng/lib/Onomap/Svg.hs b/onomastics-ng/lib/Onomap/Svg.hs index 9792a0c..1c2e4da 100644 --- a/onomastics-ng/lib/Onomap/Svg.hs +++ b/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 fillColor areas statistics = toStrict $ prettyText $ drawMap fillColor areas statistics +renderMap :: SvgSettings -> [Text] -> [Area] -> [(Text, ByArea Double)] -> Text +renderMap settings colorPalette areas statistics = toStrict $ prettyText $ drawMap settings colorPalette areas statistics -drawMap :: Text -> [Area] -> ByArea Double -> Element -drawMap fillColor areas statistics = - doctype <> with (svg11_ content) [Version_ <<- "1.1", Width_ <<- "650", Height_ <<- "900"] +drawMap :: SvgSettings -> [Text] -> [Area] -> [(Text, ByArea Double)] -> Element +drawMap settings colorPalette areas statistics = + 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)) - in path_ - [ Stroke_ <<- frameColor - , Fill_ <<- fillColor - , Fill_opacity_ <<- showRounded (if count == 0 then 0 else count / theMaximum) - , D_ <<- path area - ] - ( title_ - [] - ( toElement $ - name area <> ": " <> localize (showRounded count) - ) + path_ [Stroke_ <<- frameColor, Stroke_width_ <<- "0.3px", Fill_ <<- "none", D_ <<- path area] + <> foldMap + ( \((surname, statistic), color, theMaximum) -> + let count = fromMaybe 0 (Map.lookup (key area) (getByArea statistic)) + theTitle = + ( title_ + [] + ( toElement $ + 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 = - defs_ - [] - ( linearGradient_ - [ Id_ <<- "legend" - , X1_ <<- "0" - , X2_ <<- "1" - , Y1_ <<- "0" - , Y2_ <<- "0" - ] - ( stop_ [Offset_ <<- "0%", Stop_color_ <<- "white"] - <> stop_ [Offset_ <<- "100%", Stop_color_ <<- fillColor] - ) + foldMap + ( \(index, color, theMaximum) -> + defs_ + [] + ( linearGradient_ + [ Id_ <<- "legend" <> Text.pack (show index) + , X1_ <<- "0" + , 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_ <<- color] + ) + ) ) - <> g_ - [] - ( rect_ - [ X_ <<- "150" - , Y_ <<- "880" - , Stroke_ <<- frameColor - , Width_ <<- "350" - , Height_ <<- "10" - , Fill_ <<- "url(#legend)" - ] - <> text_ - [ X_ <<- "135" - , Y_ <<- "890" - , Font_size_ <<- "18" - , Fill_ <<- "black" - ] - "0" - <> text_ - [ X_ <<- "510" - , Y_ <<- "890" - , Font_size_ <<- "18" - , Fill_ <<- "black" - ] - (toElement $ localize $ showRounded theMaximum) + (zip3 [0 ..] colorPalette theMaxima) + <> foldMap + ( \(index, (name, statistic), color) -> + g_ + [] + ( rect_ + [ X_ <<- "165" + , Y_ <<- Text.pack (show (880 + 20 * index)) + , Stroke_ <<- frameColor + , Width_ <<- "350" + , Height_ <<- "10" + , Fill_ <<- "url(#legend" <> Text.pack (show index) <> ")" + ] + <> text_ + [ X_ <<- "155" + , 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" + ] + (toElement $ localize $ showRounded $ maximum $ getByArea statistic) + ) ) + (zip3 [0 ..] statistics colorPalette) + <> style_ [] "path { mix-blend-mode: multiply; }" <> g_ [] areaPaths diff --git a/onomastics-ng/lib/Onomap/Types.hs b/onomastics-ng/lib/Onomap/Types.hs index 00736f1..70b7741 100644 --- a/onomastics-ng/lib/Onomap/Types.hs +++ b/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" + ] diff --git a/onomastics-ng/web/Main.hs b/onomastics-ng/web/Main.hs index b1d3303..8dd7f6c 100644 --- a/onomastics-ng/web/Main.hs +++ b/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, mapWithKey) +import qualified Data.Map as Map (fromList, lookup) 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 - ( \k double -> - let maybeArea = find ((== k) . key) (areas response) - in Map.fromList - [ ("value" :: Text, toJSON double) - , ("population", toJSON $ fmap population maybeArea) - , ("name", toJSON $ fmap name maybeArea) - ] - ) - (getByArea $ statistics response) + Map.fromList $ + map + ( \area -> + ( name area + , Map.fromList $ + ("population", toJSON $ population area) : + map + ( \(surname, stats) -> + ( surname + , toJSON $ Map.lookup (key area) (getByArea stats) + ) + ) + (statistics response) + ) + ) + (areas response) type OnomapApi = Capture "mode" Mode - :> Capture "name" Text + :> QueryParams "name" Text :> QueryParam "by" AreaKind - :> QueryParam "color" Text - :> Get '[JSON, HTML] Response + :> QueryParams "color" Text + :> 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 <- - computeAreaStatistics computeFunction theAreas <$> case areaMode of - State -> stateStatistics (Just surname) - District -> districtStatistics (Just surname) - return Response{color = fromMaybe "black" maybeColor, areas = theAreas, statistics = theStatistics} + theNames = map Just surnames + theStats <- case areaMode of + State -> mapM stateStatistics theNames + District -> mapM districtStatistics theNames + 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