kfm/to-hen
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: graph multiple names

Browse Source
This commit is contained in:
Kierán Meinhardt
2022-10-07 02:21:34 +02:00
parent 78037cf36a
commit 924cc7ca21
4 changed files with 165 additions and 90 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
onomastics-ng/cli/Main.hs
View File

@@ -14,8 +14,8 @@ import Options.Applicative
data Options = Options data Options = Options
{ mode :: Mode { mode :: Mode
, surname :: Text , surnames :: [Text]
, fillColor :: Maybe Text , colorPalette :: [Text]
, areaMode :: AreaKind , areaMode :: AreaKind
} }
@@ -23,8 +23,8 @@ parseOptions :: Parser Options
parseOptions = parseOptions =
Options Options
<$> flag Absolute Relative (long "relative" <> help "Relative numbers (instead of absolute)") <$> 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)") <*> flag District State (long "states" <> help "Analyze by state (instead of district)")
opts :: ParserInfo Options opts :: ParserInfo Options
@@ -38,15 +38,16 @@ main = do
case mode options of case mode options of
Relative -> relativeCount Relative -> relativeCount
Absolute -> absoluteCount 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 res <- runStoepel manager' $ do
let theName = Just $ surname options let theNames = map Just (surnames options)
ds <- case areaMode options of ds <- case areaMode options of
State -> states State -> states
District -> districts District -> districts
theStats <- case areaMode options of 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 Text.putStrLn res

151
onomastics-ng/lib/Onomap/Svg.hs
View File

@@ -5,78 +5,115 @@ module Onomap.Svg (drawMap, renderMap) where
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text.Lazy (toStrict)
import Graphics.Svg import Graphics.Svg
import Onomap.Types (Area (..), ByArea (..), ScaleToMaximum (..), SvgSettings (..))
import Text.Printf (printf) 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 where
theMaximum = maximum $ getByArea statistics theMaxima = map maximum $ map (getByArea . snd) statistics
globalMaximum = maximum theMaxima
localize = Text.replace "." "," . Text.dropWhileEnd (== '.') . Text.dropWhileEnd (== '0') localize = Text.replace "." "," . Text.dropWhileEnd (== '.') . Text.dropWhileEnd (== '0')
showRounded = Text.pack . printf "%.2f" showRounded = Text.pack . printf "%.2f"
frameColor = "grey" frameColor = "black"
areaPaths = areaPaths =
foldMap foldMap
( \area -> ( \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_
] []
( title_ ( toElement $
[] mconcat
( toElement $ [ name area
name area <> ": " <> localize (showRounded count) , ": "
) , 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 areas
content = content =
defs_ foldMap
[] ( \(index, color, theMaximum) ->
( linearGradient_ defs_
[ Id_ <<- "legend" []
, X1_ <<- "0" ( linearGradient_
, X2_ <<- "1" [ Id_ <<- "legend" <> Text.pack (show index)
, Y1_ <<- "0" , X1_ <<- "0"
, Y2_ <<- "0" , X2_ <<- case scaleToMaximum settings of
] Global -> Text.pack (show (recip $ theMaximum / globalMaximum))
( stop_ [Offset_ <<- "0%", Stop_color_ <<- "white"] Local -> "1"
<> stop_ [Offset_ <<- "100%", Stop_color_ <<- fillColor] , Y1_ <<- "0"
) , Y2_ <<- "0"
]
( stop_ [Offset_ <<- "0%", Stop_color_ <<- "white"]
<> stop_ [Offset_ <<- "100%", Stop_color_ <<- color]
)
)
) )
<> g_ (zip3 [0 ..] colorPalette theMaxima)
[] <> foldMap
( rect_ ( \(index, (name, statistic), color) ->
[ X_ <<- "150" g_
, Y_ <<- "880" []
, Stroke_ <<- frameColor ( rect_
, Width_ <<- "350" [ X_ <<- "165"
, Height_ <<- "10" , Y_ <<- Text.pack (show (880 + 20 * index))
, Fill_ <<- "url(#legend)" , Stroke_ <<- frameColor
] , Width_ <<- "350"
<> text_ , Height_ <<- "10"
[ X_ <<- "135" , Fill_ <<- "url(#legend" <> Text.pack (show index) <> ")"
, Y_ <<- "890" ]
, Font_size_ <<- "18" <> text_
, Fill_ <<- "black" [ X_ <<- "155"
] , Y_ <<- Text.pack (show (890 + 20 * index))
"0" , Font_size_ <<- "18"
<> text_ , Fill_ <<- "black"
[ X_ <<- "510" , Text_anchor_ <<- "end"
, Y_ <<- "890" ]
, Font_size_ <<- "18" (toElement $ Text.toTitle name)
, Fill_ <<- "black" <> text_
] [ X_ <<- "525"
(toElement $ localize $ showRounded theMaximum) , 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 <> g_ [] areaPaths

25
onomastics-ng/lib/Onomap/Types.hs
View File

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

58
onomastics-ng/web/Main.hs
View File

@@ -13,8 +13,7 @@ module Main where
import Control.Monad (liftM2) import Control.Monad (liftM2)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Aeson (ToJSON (..)) 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.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics (Generic) import GHC.Generics (Generic)
@@ -28,13 +27,14 @@ import Servant
import Servant.HTML.Blaze (HTML) import Servant.HTML.Blaze (HTML)
import Text.Blaze (ToMarkup (..)) 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) deriving (Generic)
instance ToMarkup Response where instance ToMarkup Response where
toMarkup response = toMarkup response =
preEscapedToMarkup $ preEscapedToMarkup $
renderMap renderMap
(SvgSettings{scaleToMaximum = Global})
(color response) (color response)
(areas response) (areas response)
(statistics response) (statistics response)
@@ -42,29 +42,35 @@ instance ToMarkup Response where
instance ToJSON Response where instance ToJSON Response where
toJSON response = toJSON response =
toJSON $ 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
(getByArea $ statistics response) , toJSON $ Map.lookup (key area) (getByArea stats)
)
)
(statistics response)
)
)
(areas response)
type OnomapApi = type OnomapApi =
Capture "mode" Mode Capture "mode" Mode
:> Capture "name" Text :> QueryParams "name" Text
:> QueryParam "by" AreaKind :> QueryParam "by" AreaKind
:> QueryParam "color" Text :> QueryParams "color" Text
:> Get '[JSON, HTML] Response :> Get '[HTML] Response
app :: Manager -> ([Area], [Area]) -> Application app :: Manager -> ([Area], [Area]) -> Application
app manager' (theDistricts, theStates) = serve onomapApi server app manager' (theDistricts, theStates) = serve onomapApi server
where where
server :: Server OnomapApi server :: Server OnomapApi
server = \mode surname maybeAreaKind maybeColor -> server = \mode (surnames :: [Text]) maybeAreaKind colors ->
liftIO $ liftIO $
runStoepel manager' $ do runStoepel manager' $ do
let areaMode = fromMaybe District maybeAreaKind let areaMode = fromMaybe District maybeAreaKind
@@ -75,11 +81,19 @@ app manager' (theDistricts, theStates) = serve onomapApi server
theAreas = case areaMode of theAreas = case areaMode of
State -> theStates State -> theStates
District -> theDistricts 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 OnomapApi
onomapApi = Proxy onomapApi = Proxy