src/Gargantext/Viz/Phylo/PhyloExport.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.PhyloExport
   3 Description : Exportation module of a Phylo
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 {-# LANGUAGE NoImplicitPrelude #-}
  12 {-# LANGUAGE FlexibleContexts  #-}
  13 {-# LANGUAGE OverloadedStrings #-}
  14 {-# LANGUAGE MultiParamTypeClasses #-}
  15 {-# LANGUAGE TypeSynonymInstances #-}
  16 {-# LANGUAGE FlexibleInstances    #-}
  17
  18 module Gargantext.Viz.Phylo.PhyloExport where
  19
  20 import Data.Map (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault, toList)
  21 import Data.List ((++), sort, nub, concat, sortOn, reverse, groupBy, union, (\\), (!!), init, partition, unwords, nubBy, inits, tail)
  22 import Data.Vector (Vector)
  23
  24 import Prelude (writeFile, replicate)
  25 import Gargantext.Prelude
  26 import Gargantext.Viz.AdaptativePhylo
  27 import Gargantext.Viz.Phylo.PhyloTools
  28
  29 import Control.Lens
  30 import Data.GraphViz hiding (DotGraph, Order)
  31 import Data.GraphViz.Types.Generalised (DotGraph)
  32 import Data.GraphViz.Attributes.Complete hiding (EdgeType, Order)
  33 import Data.GraphViz.Types.Monadic
  34 import Data.Text.Lazy (fromStrict, pack, unpack)
  35 import System.FilePath
  36 import Debug.Trace (trace)
  37
  38 import qualified Data.Text as Text
  39 import qualified Data.Vector as Vector
  40 import qualified Data.Text.Lazy as Lazy
  41 import qualified Data.GraphViz.Attributes.HTML as H
  42
  43 --------------------
  44 -- | Dot export | --
  45 --------------------
  46
  47 dotToFile :: FilePath -> DotGraph DotId -> IO ()
  48 dotToFile filePath dotG = writeFile filePath $ dotToString dotG
  49
  50 dotToString :: DotGraph DotId  -> [Char]
  51 dotToString dotG = unpack (printDotGraph dotG)
  52
  53 dynamicToColor :: Double -> H.Attribute
  54 dynamicToColor d
  55   | d == 0    = H.BGColor (toColor LightCoral)
  56   | d == 1    = H.BGColor (toColor Khaki)
  57   | d == 2    = H.BGColor (toColor SkyBlue)
  58   | otherwise = H.Color   (toColor Black)
  59
  60 pickLabelColor :: [Double] -> H.Attribute
  61 pickLabelColor lst
  62   | elem 0 lst = dynamicToColor 0
  63   | elem 2 lst = dynamicToColor 2
  64   | elem 1 lst = dynamicToColor 1
  65   | otherwise  = dynamicToColor 3
  66
  67 toDotLabel :: Text.Text -> Label
  68 toDotLabel lbl = StrLabel $ fromStrict lbl
  69
  70 toAttr :: AttributeName -> Lazy.Text -> CustomAttribute
  71 toAttr k v = customAttribute k v
  72
  73 metaToAttr :: Map Text.Text [Double] -> [CustomAttribute]
  74 metaToAttr meta = map (\(k,v) -> toAttr (fromStrict k) $ (pack . unwords) $ map show v) $ toList meta
  75
  76 groupIdToDotId :: PhyloGroupId -> DotId
  77 groupIdToDotId (((d,d'),lvl),idx) = (fromStrict . Text.pack) $ ("group" <> (show d) <> (show d') <> (show lvl) <> (show idx))
  78
  79 branchIdToDotId :: PhyloBranchId -> DotId
  80 branchIdToDotId bId = (fromStrict . Text.pack) $ ("branch" <> show (snd bId))
  81
  82 periodIdToDotId :: PhyloPeriodId -> DotId
  83 periodIdToDotId prd = (fromStrict . Text.pack) $ ("period" <> show (fst prd) <> show (snd prd))
  84
  85 groupToTable :: Vector Ngrams -> PhyloGroup -> H.Label
  86 groupToTable fdt g = H.Table H.HTable
  87                     { H.tableFontAttrs = Just [H.PointSize 14, H.Align H.HLeft]
  88                     , H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
  89                     , H.tableRows = [header]
  90                                  <> [H.Cells [H.LabelCell [H.Height 10] $ H.Text [H.Str $ fromStrict ""]]]
  91                                  <> ( map ngramsToRow $ splitEvery 4
  92                                     $ reverse $ sortOn (snd . snd)
  93                                     $ zip (ngramsToText fdt (g ^. phylo_groupNgrams))
  94                                     $ zip ((g ^. phylo_groupMeta) ! "dynamics") ((g ^. phylo_groupMeta) ! "inclusion"))}
  95     where
  96         --------------------------------------
  97         ngramsToRow :: [(Ngrams,(Double,Double))] -> H.Row
  98         ngramsToRow ns = H.Cells $ map (\(n,(d,_)) ->
  99                             H.LabelCell [H.Align H.HLeft,dynamicToColor d] $ H.Text [H.Str $ fromStrict n]) ns
 100         --------------------------------------
 101         header :: H.Row
 102         header =
 103             H.Cells [ H.LabelCell [pickLabelColor ((g ^. phylo_groupMeta) ! "dynamics")]
 104                     $ H.Text [H.Str $ (((fromStrict . Text.toUpper) $ g ^. phylo_groupLabel)
 105                                    <> (fromStrict " ( ")
 106                                    <> (pack $ show (fst $ g ^. phylo_groupPeriod))
 107                                    <> (fromStrict " , ")
 108                                    <> (pack $ show (snd $ g ^. phylo_groupPeriod))
 109                                    <> (fromStrict " ) ")
 110                                    <> (pack $ show (getGroupId g)))]]
 111         --------------------------------------
 112
 113 branchToDotNode :: PhyloBranch -> Dot DotId
 114 branchToDotNode b =
 115     node (branchIdToDotId $ b ^. branch_id)
 116          ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ b ^. branch_label)]
 117          <> (metaToAttr $ b ^. branch_meta)
 118          <> [ toAttr "nodeType" "branch"
 119             , toAttr "branchId" (pack $ unwords (map show $ snd $ b ^. branch_id))
 120             , toAttr "branch_x" (fromStrict $ Text.pack $ (show $ b ^. branch_x))
 121             , toAttr "branch_y" (fromStrict $ Text.pack $ (show $ b ^. branch_y))
 122             , toAttr "label"    (pack $ show $ b ^. branch_label)
 123             ])
 124
 125 periodToDotNode :: (Date,Date) -> Dot DotId
 126 periodToDotNode prd =
 127     node (periodIdToDotId prd)
 128          ([Shape BoxShape, FontSize 50, Label (toDotLabel $ Text.pack (show (fst prd) <> " " <> show (snd prd)))]
 129          <> [ toAttr "nodeType" "period"
 130             , toAttr "from" (fromStrict $ Text.pack $ (show $ fst prd))
 131             , toAttr "to"   (fromStrict $ Text.pack $ (show $ snd prd))])
 132
 133
 134 groupToDotNode :: Vector Ngrams -> PhyloGroup -> Dot DotId
 135 groupToDotNode fdt g =
 136     node (groupIdToDotId $ getGroupId g)
 137                      ([FontName "Arial", Shape Square, penWidth 4,  toLabel (groupToTable fdt g)]
 138                       <> [ toAttr "nodeType" "group"
 139                          , toAttr "from" (pack $ show (fst $ g ^. phylo_groupPeriod))
 140                          , toAttr "to"   (pack $ show (snd $ g ^. phylo_groupPeriod))
 141                          , toAttr "branchId" (pack $ unwords (init $ map show $ snd $ g ^. phylo_groupBranchId))
 142                          , toAttr "support" (pack $ show (g ^. phylo_groupSupport))])
 143
 144
 145 toDotEdge :: DotId -> DotId -> Text.Text -> EdgeType -> Dot DotId
 146 toDotEdge source target lbl edgeType = edge source target
 147     (case edgeType of
 148         GroupToGroup   -> [ Width 3, penWidth 4, Color [toWColor Black], Constraint True
 149                           , Label (StrLabel $ fromStrict lbl)]
 150         BranchToGroup  -> [ Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])
 151                           , Label (StrLabel $ fromStrict lbl)]
 152         BranchToBranch -> [ Width 2, Color [toWColor Black], Style [SItem Dashed []], ArrowHead (AType [(ArrMod FilledArrow BothSides,DotArrow)])
 153                           , Label (StrLabel $ fromStrict lbl)]
 154         PeriodToPeriod -> [ Width 5, Color [toWColor Black]])
 155
 156
 157 mergePointers :: [PhyloGroup] -> Map (PhyloGroupId,PhyloGroupId) Double
 158 mergePointers groups =
 159     let toChilds  = fromList $ concat $ map (\g -> map (\(target,w) -> ((getGroupId g,target),w)) $ g ^. phylo_groupPeriodChilds) groups
 160         toParents = fromList $ concat $ map (\g -> map (\(target,w) -> ((target,getGroupId g),w)) $ g ^. phylo_groupPeriodParents) groups
 161     in  unionWith (\w w' -> max w w') toChilds toParents
 162
 163
 164 exportToDot :: Phylo -> PhyloExport -> DotGraph DotId
 165 exportToDot phylo export =
 166     trace ("\n-- | Convert " <> show(length $ export ^. export_branches) <> " branches and "
 167          <> show(length $ export ^. export_groups) <> " groups "
 168          <> show(length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) $ export ^. export_groups) <> " terms to a dot file\n\n"
 169          <> "##########################") $
 170     digraph ((Str . fromStrict) $ (phyloName $ getConfig phylo)) $ do
 171
 172         -- | 1) init the dot graph
 173         graphAttrs ( [ Label (toDotLabel $ (phyloName $ getConfig phylo))]
 174                   <> [ FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
 175                      , Ratio FillRatio
 176                      , Style [SItem Filled []],Color [toWColor White]]
 177                   -- | home made attributes
 178                   <> [(toAttr (fromStrict "phyloFoundations") $ pack $ show (length $ Vector.toList $ getRoots phylo))
 179                      ,(toAttr (fromStrict "phyloTerms") $ pack $ show (length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) $ export ^. export_groups))
 180                      ,(toAttr (fromStrict "phyloDocs") $ pack $ show (sum $ elems $ phylo ^. phylo_timeDocs))
 181                      ,(toAttr (fromStrict "phyloPeriods") $ pack $ show (length $ elems $ phylo ^. phylo_periods))
 182                      ,(toAttr (fromStrict "phyloBranches") $ pack $ show (length $ export ^. export_branches))
 183                      ,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups))
 184                      ])
 185
 186
 187  -- toAttr (fromStrict k) $ (pack . unwords) $ map show v
 188
 189         -- | 2) create a layer for the branches labels
 190         subgraph (Str "Branches peaks") $ do
 191
 192             graphAttrs [Rank SameRank]
 193
 194             -- | 3) group the branches by hierarchy
 195             -- mapM (\branches ->
 196             --         subgraph (Str "Branches clade") $ do
 197             --             graphAttrs [Rank SameRank]
 198
 199             --             -- | 4) create a node for each branch
 200             --             mapM branchToDotNode branches
 201             --     ) $ elems $ fromListWith (++) $ map (\b -> ((init . snd) $ b ^. branch_id,[b])) $ export ^. export_branches
 202
 203             mapM branchToDotNode $ export ^. export_branches
 204
 205         -- | 5) create a layer for each period
 206         _ <- mapM (\period ->
 207                 subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst period) <> show (snd period))) $ do
 208                     graphAttrs [Rank SameRank]
 209                     periodToDotNode period
 210
 211                     -- | 6) create a node for each group
 212                     mapM (\g -> groupToDotNode (getRoots phylo) g) (filter (\g -> g ^. phylo_groupPeriod == period) $ export ^. export_groups)
 213             ) $ getPeriodIds phylo
 214
 215         -- | 7) create the edges between a branch and its first groups
 216         _ <- mapM (\(bId,groups) ->
 217                 mapM (\g -> toDotEdge (branchIdToDotId bId) (groupIdToDotId $ getGroupId g) "" BranchToGroup) groups
 218              )
 219            $ toList
 220            $ map (\groups -> head' "toDot"
 221                            $ groupBy (\g g' -> g' ^. phylo_groupPeriod == g ^. phylo_groupPeriod)
 222                            $ sortOn (fst . _phylo_groupPeriod) groups)
 223            $ fromListWith (++) $ map (\g -> (g ^. phylo_groupBranchId,[g])) $ export ^. export_groups
 224
 225         -- | 8) create the edges between the groups
 226         _ <- mapM (\((k,k'),_) ->
 227                 toDotEdge (groupIdToDotId k) (groupIdToDotId k') "" GroupToGroup
 228             ) $ (toList . mergePointers) $ export ^. export_groups
 229
 230         -- | 7) create the edges between the periods
 231         _ <- mapM (\(prd,prd') ->
 232                 toDotEdge (periodIdToDotId prd) (periodIdToDotId prd') "" PeriodToPeriod
 233             ) $ nubBy (\combi combi' -> fst combi == fst combi') $ listToCombi' $ getPeriodIds phylo
 234
 235         -- | 8) create the edges between the branches
 236         -- _ <- mapM (\(bId,bId') ->
 237         --         toDotEdge (branchIdToDotId bId) (branchIdToDotId bId')
 238         --         (Text.pack $ show(branchIdsToProximity bId bId'
 239         --                             (getThresholdInit $ phyloProximity $ getConfig phylo)
 240         --                             (getThresholdStep $ phyloProximity $ getConfig phylo))) BranchToBranch
 241         --     ) $ nubBy (\combi combi' -> fst combi == fst combi') $ listToCombi' $ map _branch_id $ export ^. export_branches
 242
 243
 244         graphAttrs [Rank SameRank]
 245
 246
 247
 248
 249
 250 ----------------
 251 -- | Filter | --
 252 ----------------
 253
 254 filterByBranchSize :: Double -> PhyloExport -> PhyloExport
 255 filterByBranchSize thr export =
 256     let branches' = partition (\b -> head' "filter" ((b ^. branch_meta) ! "size") >= thr) $ export ^. export_branches
 257     in  export & export_branches .~ (fst branches')
 258                & export_groups %~ (filter (\g -> not $ elem  (g ^. phylo_groupBranchId) (map _branch_id $ snd branches')))
 259
 260
 261 processFilters :: [Filter] -> Quality -> PhyloExport -> PhyloExport
 262 processFilters filters qua export =
 263     foldl (\export' f -> case f of
 264                 ByBranchSize thr -> if (thr < (fromIntegral $ qua ^. qua_minBranch))
 265                                       then filterByBranchSize (fromIntegral $ qua ^. qua_minBranch) export'
 266                                       else filterByBranchSize thr export'
 267         ) export filters
 268
 269 --------------
 270 -- | Sort | --
 271 --------------
 272
 273 sortByHierarchy :: Int -> [PhyloBranch] -> [PhyloBranch]
 274 sortByHierarchy depth branches =
 275     if (length branches == 1)
 276         then branches
 277         else concat
 278            $ map (\branches' ->
 279                     let partitions = partition (\b -> depth + 1 == ((length . snd) $ b ^. branch_id)) branches'
 280                     in  (sortOn (\b -> (b ^. branch_meta) ! "birth") (fst partitions))
 281                     ++  (sortByHierarchy (depth + 1) (snd partitions)))
 282             $ groupBy (\b b' -> ((take depth . snd) $ b ^. branch_id) == ((take depth . snd) $ b' ^. branch_id) )
 283             $ sortOn (\b -> (take depth . snd) $ b ^. branch_id) branches
 284
 285
 286 sortByBirthDate :: Order -> PhyloExport -> PhyloExport
 287 sortByBirthDate order export =
 288     let branches  = sortOn (\b -> (b ^. branch_meta) ! "birth") $ export ^. export_branches
 289         branches' = case order of
 290                     Asc  -> branches
 291                     Desc -> reverse branches
 292     in  export & export_branches .~ branches'
 293
 294 processSort :: Sort -> PhyloExport -> PhyloExport
 295 processSort sort' export = case sort' of
 296     ByBirthDate o -> sortByBirthDate o export
 297     ByHierarchy   -> export & export_branches .~ sortByHierarchy 0 (export ^. export_branches)
 298
 299
 300 -----------------
 301 -- | Metrics | --
 302 -----------------
 303
 304 -- | Return the conditional probability of i knowing j
 305 conditional :: Ord a => Map (a,a) Double -> a -> a -> Double
 306 conditional m i j = (findWithDefault 0 (i,j) m)
 307                   / (m ! (j,j))
 308
 309
 310 -- | Return the genericity score of a given ngram
 311 genericity :: Map (Int, Int) Double -> [Int] -> Int -> Double
 312 genericity m l i = ( (sum $ map (\j -> conditional m i j) l)
 313                    - (sum $ map (\j -> conditional m j i) l)) / (fromIntegral $ (length l) + 1)
 314
 315
 316 -- | Return the specificity score of a given ngram
 317 specificity :: Map (Int, Int) Double -> [Int] -> Int -> Double
 318 specificity m l i = ( (sum $ map (\j -> conditional m j i) l)
 319                     - (sum $ map (\j -> conditional m i j) l)) / (fromIntegral $ (length l) + 1)
 320
 321
 322 -- | Return the inclusion score of a given ngram
 323 inclusion :: Map (Int, Int) Double -> [Int] -> Int -> Double
 324 inclusion m l i = ( (sum $ map (\j -> conditional m j i) l)
 325                   + (sum $ map (\j -> conditional m i j) l)) / (fromIntegral $ (length l) + 1)
 326
 327
 328 ngramsMetrics :: PhyloExport -> PhyloExport
 329 ngramsMetrics export =
 330     over ( export_groups
 331          .  traverse )
 332     (\g -> g & phylo_groupMeta %~ insert "genericity"
 333                                   (map (\n -> genericity  (g ^. phylo_groupCooc) ((g ^. phylo_groupNgrams) \\ [n]) n) $ g ^. phylo_groupNgrams)
 334              & phylo_groupMeta %~ insert "specificity"
 335                                   (map (\n -> specificity (g ^. phylo_groupCooc) ((g ^. phylo_groupNgrams) \\ [n]) n) $ g ^. phylo_groupNgrams)
 336              & phylo_groupMeta %~ insert "inclusion"
 337                                   (map (\n -> inclusion   (g ^. phylo_groupCooc) ((g ^. phylo_groupNgrams) \\ [n]) n) $ g ^. phylo_groupNgrams)
 338         ) export
 339
 340
 341 branchDating :: PhyloExport -> PhyloExport
 342 branchDating export =
 343     over ( export_branches
 344          .  traverse )
 345     (\b ->
 346         let groups = sortOn fst
 347                    $ foldl' (\acc g -> if (g ^. phylo_groupBranchId == b ^. branch_id)
 348                                       then acc ++ [g ^. phylo_groupPeriod]
 349                                       else acc ) [] $ export ^. export_groups
 350             periods = nub groups
 351             birth = fst $ head' "birth" groups
 352             age   = (snd $ last' "age"  groups) - birth
 353         in b & branch_meta %~ insert "birth" [fromIntegral birth]
 354              & branch_meta %~ insert "age"   [fromIntegral age]
 355              & branch_meta %~ insert "size"  [fromIntegral $ length periods] ) export
 356
 357 processMetrics :: PhyloExport -> PhyloExport
 358 processMetrics export = ngramsMetrics
 359                       $ branchDating export
 360
 361
 362 -----------------
 363 -- | Taggers | --
 364 -----------------
 365
 366 getNthMostMeta :: Int -> [Double] -> [Int] -> [Int]
 367 getNthMostMeta nth meta ns = map (\(idx,_) -> (ns !! idx))
 368                            $ take nth
 369                            $ reverse
 370                            $ sortOn snd $ zip [0..] meta
 371
 372
 373 mostInclusive :: Int -> Vector Ngrams -> PhyloExport -> PhyloExport
 374 mostInclusive nth foundations export =
 375     over ( export_branches
 376          .  traverse )
 377          (\b ->
 378             let groups = filter (\g -> g ^. phylo_groupBranchId == b ^. branch_id) $ export ^. export_groups
 379                 cooc   = foldl (\acc g -> unionWith (+) acc (g ^. phylo_groupCooc)) empty groups
 380                 ngrams = sort $ foldl (\acc g -> union acc (g ^. phylo_groupNgrams)) [] groups
 381                 inc    = map (\n -> inclusion cooc (ngrams \\ [n]) n) ngrams
 382                 lbl    = ngramsToLabel foundations $ getNthMostMeta nth inc ngrams
 383             in b & branch_label .~ lbl ) export
 384
 385
 386 mostEmergentInclusive :: Int -> Vector Ngrams -> PhyloExport -> PhyloExport
 387 mostEmergentInclusive nth foundations export =
 388     over ( export_groups
 389          .  traverse )
 390          (\g ->
 391             let lbl = ngramsToLabel foundations
 392                     $ take nth
 393                     $ map (\(_,(_,idx)) -> idx)
 394                     $ concat
 395                     $ map (\groups -> sortOn (fst . snd) groups)
 396                     $ groupBy ((==) `on` fst) $ reverse $ sortOn fst
 397                     $ zip ((g ^. phylo_groupMeta) ! "inclusion")
 398                     $ zip ((g ^. phylo_groupMeta) ! "dynamics") (g ^. phylo_groupNgrams)
 399             in g & phylo_groupLabel .~ lbl ) export
 400
 401
 402 processLabels :: [PhyloLabel] -> Vector Ngrams -> PhyloExport -> PhyloExport
 403 processLabels labels foundations export =
 404     foldl (\export' label ->
 405                 case label of
 406                     GroupLabel  tagger nth ->
 407                         case tagger of
 408                             MostEmergentInclusive -> mostEmergentInclusive nth foundations export'
 409                             _ -> panic "[ERR][Viz.Phylo.PhyloExport] unknown tagger"
 410                     BranchLabel tagger nth ->
 411                         case tagger of
 412                             MostInclusive -> mostInclusive nth foundations export'
 413                             _ -> panic "[ERR][Viz.Phylo.PhyloExport] unknown tagger" ) export labels
 414
 415
 416 ------------------
 417 -- | Dynamics | --
 418 ------------------
 419
 420
 421 toDynamics :: Int -> [PhyloGroup] -> PhyloGroup -> Map Int (Date,Date) -> Double
 422 toDynamics n parents g m =
 423     let prd = g ^. phylo_groupPeriod
 424         end = last' "dynamics" (sort $ map snd $ elems m)
 425     in  if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
 426             -- | decrease
 427             then 2
 428         else if ((fst prd) == (fst $ m ! n))
 429             -- | recombination
 430             then 0
 431         else if isNew
 432             -- | emergence
 433             then 1
 434         else 3
 435     where
 436         --------------------------------------
 437         isNew :: Bool
 438         isNew = not $ elem n $ concat $ map _phylo_groupNgrams parents
 439
 440
 441 processDynamics :: [PhyloGroup] -> [PhyloGroup]
 442 processDynamics groups =
 443     map (\g ->
 444         let parents = filter (\g' -> (g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
 445                                   && ((fst $ g ^. phylo_groupPeriod) > (fst $ g' ^. phylo_groupPeriod))) groups
 446         in  g & phylo_groupMeta %~ insert "dynamics" (map (\n -> toDynamics n parents g mapNgrams) $ g ^. phylo_groupNgrams) ) groups
 447     where
 448         --------------------------------------
 449         mapNgrams :: Map Int (Date,Date)
 450         mapNgrams = map (\dates ->
 451                         let dates' = sort dates
 452                         in (head' "dynamics" dates', last' "dynamics" dates'))
 453                   $ fromListWith (++)
 454                   $ foldl (\acc g -> acc ++ ( map (\n -> (n,[fst $ g ^. phylo_groupPeriod, snd $ g ^. phylo_groupPeriod]))
 455                                             $ (g ^. phylo_groupNgrams))) [] groups
 456
 457
 458 ---------------------
 459 -- | phyloExport | --
 460 ---------------------
 461
 462
 463 toPhyloExport :: Phylo -> DotGraph DotId
 464 toPhyloExport phylo = exportToDot phylo
 465                     $ processFilters (exportFilter $ getConfig phylo) (phyloQuality $ getConfig phylo)
 466                     $ processSort    (exportSort   $ getConfig phylo)
 467                     $ processLabels  (exportLabel  $ getConfig phylo) (getRoots phylo)
 468                     $ processMetrics  export
 469     where
 470         export :: PhyloExport
 471         export = PhyloExport groups
 472                $ map (\((w,t),b) -> b & branch_w .~ w
 473                                       & branch_t .~ t)
 474                $ zip toScale branches'
 475         --------------------------------------
 476         toScale :: [(Double,Double)]
 477         toScale =
 478           let ws  = map (\b -> 5 * (2 * (b ^. branch_w) - 1)) branches'
 479               ts  = map (/2) ws
 480               ts' = map (\(x,y) -> x + y)
 481                   $ zip ts
 482                   $ map (\(x,y) -> x + y)
 483                   $ zip (map sum $ tail $ inits $ replicate (length ws) 10)
 484                   $ map sum $ init $ inits ws
 485            in zip ws ts'
 486         --------------------------------------
 487         branches' :: [PhyloBranch]
 488         branches' = sortOn _branch_x
 489                   $ map (\(x,b) -> b & branch_x .~ x)
 490                   $ zip branchesGaps branches
 491         --------------------------------------
 492         branchesGaps :: [Double]
 493         branchesGaps = map sum
 494                      $ inits
 495                      $ map (\(b,x) -> b ^. branch_y + 0.05 - x)
 496                      $ zip branches
 497                      $ ([0] ++ (map (\(b,b') ->
 498                                         let idx = length $ commonPrefix (b ^. branch_canonId) (b' ^. branch_canonId) []
 499                                          in (b' ^. branch_seaLevel) !! (idx - 1)
 500                                         ) $ listToSeq branches))
 501         --------------------------------------
 502         toWidth :: [PhyloGroup] -> Double
 503         toWidth gs = fromIntegral
 504                    $ maximum
 505                    $ map length
 506                    $ groupBy (\g g' -> g ^. phylo_groupPeriod == g' ^. phylo_groupPeriod) gs
 507         --------------------------------------
 508         branches :: [PhyloBranch]
 509         branches = map (\(g,w) ->
 510                       let seaLvl = (g ^. phylo_groupMeta) ! "seaLevels"
 511                           breaks = (g ^. phylo_groupMeta) ! "breaks"
 512                           canonId = take (round $ (last' "export" breaks) + 2) (snd $ g ^. phylo_groupBranchId)
 513                        in trace (show(canonId)) $ PhyloBranch (g ^. phylo_groupBranchId)
 514                                       canonId
 515                                       seaLvl
 516                                       0
 517                                       (last' "export" (take (round $ (last' "export" breaks) + 1) seaLvl))
 518                                       w
 519                                       0
 520                                       "" empty)
 521                   $ map (\gs -> (head' "export" gs,toWidth gs))
 522                   $ groupBy (\g g' -> g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
 523                   $ sortOn (\g -> g ^. phylo_groupBranchId) groups
 524         --------------------------------------
 525         groups :: [PhyloGroup]
 526         groups = traceExportGroups
 527                $ processDynamics
 528                $ getGroupsFromLevel (phyloLevel $ getConfig phylo)
 529                $ tracePhyloInfo phylo
 530
 531
 532 traceExportBranches :: [PhyloBranch] -> [PhyloBranch]
 533 traceExportBranches branches = trace ("\n"
 534   <> "-- | Export " <> show(length branches) <> " branches") branches
 535
 536 tracePhyloInfo :: Phylo -> Phylo
 537 tracePhyloInfo phylo = trace ("\n"  <> "##########################" <> "\n\n" <> "-- | Phylo with β = "
 538     <> show(_qua_granularity $ phyloQuality $ getConfig phylo) <> " applied to "
 539     <> show(length $ Vector.toList $ getRoots phylo) <> " foundations"
 540   ) phylo
 541
 542
 543 traceExportGroups :: [PhyloGroup] -> [PhyloGroup]
 544 traceExportGroups groups = trace ("\n" <> "-- | Export "
 545     <> show(length $ nub $ map (\g -> g ^. phylo_groupBranchId) groups) <> " branches, "
 546     <> show(length groups) <> " groups and "
 547     <> show(length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) groups) <> " terms"
 548   ) groups
 549