feat: graph multiple names
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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
|
||||
]
|
||||
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 $
|
||||
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"
|
||||
, Y_ <<- "880"
|
||||
[ X_ <<- "165"
|
||||
, 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"
|
||||
, Y_ <<- "890"
|
||||
[ 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"
|
||||
]
|
||||
"0"
|
||||
<> text_
|
||||
[ X_ <<- "510"
|
||||
, Y_ <<- "890"
|
||||
, Font_size_ <<- "18"
|
||||
, Fill_ <<- "black"
|
||||
]
|
||||
(toElement $ localize $ showRounded theMaximum)
|
||||
(toElement $ localize $ showRounded $ maximum $ getByArea statistic)
|
||||
)
|
||||
)
|
||||
(zip3 [0 ..] statistics colorPalette)
|
||||
<> style_ [] "path { mix-blend-mode: multiply; }"
|
||||
<> g_ [] areaPaths
|
||||
|
||||
@@ -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"
|
||||
]
|
||||
|
||||
@@ -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)
|
||||
]
|
||||
Map.fromList $
|
||||
map
|
||||
( \area ->
|
||||
( name area
|
||||
, Map.fromList $
|
||||
("population", toJSON $ population area) :
|
||||
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
|
||||
:> 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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user