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, elemIndex)
  22 import Data.Vector (Vector)
  23
  24 import Prelude (writeFile)
  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 -> Int -> Dot DotId
 114 branchToDotNode b bId =
 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 "bId"      (pack $ show bId)
 120             , toAttr "branchId" (pack $ unwords (map show $ snd $ b ^. branch_id))
 121             , toAttr "branch_x" (fromStrict $ Text.pack $ (show $ b ^. branch_x))
 122             , toAttr "branch_y" (fromStrict $ Text.pack $ (show $ b ^. branch_y))
 123             , toAttr "label"    (pack $ show $ b ^. branch_label)
 124             ])
 125
 126 periodToDotNode :: (Date,Date) -> Dot DotId
 127 periodToDotNode prd =
 128     node (periodIdToDotId prd)
 129          ([Shape BoxShape, FontSize 50, Label (toDotLabel $ Text.pack (show (fst prd) <> " " <> show (snd prd)))]
 130          <> [ toAttr "nodeType" "period"
 131             , toAttr "from" (fromStrict $ Text.pack $ (show $ fst prd))
 132             , toAttr "to"   (fromStrict $ Text.pack $ (show $ snd prd))])
 133
 134
 135 groupToDotNode :: Vector Ngrams -> PhyloGroup -> Int -> Dot DotId
 136 groupToDotNode fdt g bId =
 137     node (groupIdToDotId $ getGroupId g)
 138                      ([FontName "Arial", Shape Square, penWidth 4,  toLabel (groupToTable fdt g)]
 139                       <> [ toAttr "nodeType" "group"
 140                          , toAttr "from" (pack $ show (fst $ g ^. phylo_groupPeriod))
 141                          , toAttr "to"   (pack $ show (snd $ g ^. phylo_groupPeriod))
 142                          , toAttr "branchId" (pack $ unwords (init $ map show $ snd $ g ^. phylo_groupBranchId))
 143                          , toAttr "bId" (pack $ show bId)
 144                          , toAttr "support" (pack $ show (g ^. phylo_groupSupport))])
 145
 146
 147 toDotEdge :: DotId -> DotId -> Text.Text -> EdgeType -> Dot DotId
 148 toDotEdge source target lbl edgeType = edge source target
 149     (case edgeType of
 150         GroupToGroup   -> [ Width 3, penWidth 4, Color [toWColor Black], Constraint True
 151                           , Label (StrLabel $ fromStrict lbl)] <> [toAttr "edgeType" "link" ]
 152         BranchToGroup  -> [ Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])
 153                           , Label (StrLabel $ fromStrict lbl)] <> [toAttr "edgeType" "branchLink" ]
 154         BranchToBranch -> [ Width 2, Color [toWColor Black], Style [SItem Dashed []], ArrowHead (AType [(ArrMod FilledArrow BothSides,DotArrow)])
 155                           , Label (StrLabel $ fromStrict lbl)]
 156         PeriodToPeriod -> [ Width 5, Color [toWColor Black]])
 157
 158
 159 mergePointers :: [PhyloGroup] -> Map (PhyloGroupId,PhyloGroupId) Double
 160 mergePointers groups =
 161     let toChilds  = fromList $ concat $ map (\g -> map (\(target,w) -> ((getGroupId g,target),w)) $ g ^. phylo_groupPeriodChilds) groups
 162         toParents = fromList $ concat $ map (\g -> map (\(target,w) -> ((target,getGroupId g),w)) $ g ^. phylo_groupPeriodParents) groups
 163     in  unionWith (\w w' -> max w w') toChilds toParents
 164
 165
 166 toBid :: PhyloGroup -> [PhyloBranch] -> Int
 167 toBid g bs =
 168   let b' = head' "toBid" (filter (\b -> b ^. branch_id == g ^. phylo_groupBranchId) bs)
 169    in fromJust $ elemIndex b' bs
 170
 171 exportToDot :: Phylo -> PhyloExport -> DotGraph DotId
 172 exportToDot phylo export =
 173     trace ("\n-- | Convert " <> show(length $ export ^. export_branches) <> " branches and "
 174          <> show(length $ export ^. export_groups) <> " groups "
 175          <> show(length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) $ export ^. export_groups) <> " terms to a dot file\n\n"
 176          <> "##########################") $
 177     digraph ((Str . fromStrict) $ (phyloName $ getConfig phylo)) $ do
 178
 179         -- | 1) init the dot graph
 180         graphAttrs ( [ Label (toDotLabel $ (phyloName $ getConfig phylo))]
 181                   <> [ FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
 182                      , Ratio FillRatio
 183                      , Style [SItem Filled []],Color [toWColor White]]
 184                   -- | home made attributes
 185                   <> [(toAttr (fromStrict "phyloFoundations") $ pack $ show (length $ Vector.toList $ getRoots phylo))
 186                      ,(toAttr (fromStrict "phyloTerms") $ pack $ show (length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) $ export ^. export_groups))
 187                      ,(toAttr (fromStrict "phyloDocs") $ pack $ show (sum $ elems $ phylo ^. phylo_timeDocs))
 188                      ,(toAttr (fromStrict "phyloPeriods") $ pack $ show (length $ elems $ phylo ^. phylo_periods))
 189                      ,(toAttr (fromStrict "phyloBranches") $ pack $ show (length $ export ^. export_branches))
 190                      ,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups))
 191                      ])
 192
 193
 194  -- toAttr (fromStrict k) $ (pack . unwords) $ map show v
 195
 196         -- | 2) create a layer for the branches labels
 197         subgraph (Str "Branches peaks") $ do
 198
 199             graphAttrs [Rank SameRank]
 200
 201             -- | 3) group the branches by hierarchy
 202             -- mapM (\branches ->
 203             --         subgraph (Str "Branches clade") $ do
 204             --             graphAttrs [Rank SameRank]
 205
 206             --             -- | 4) create a node for each branch
 207             --             mapM branchToDotNode branches
 208             --     ) $ elems $ fromListWith (++) $ map (\b -> ((init . snd) $ b ^. branch_id,[b])) $ export ^. export_branches
 209
 210             mapM (\b -> branchToDotNode b (fromJust $ elemIndex b (export ^. export_branches))) $ export ^. export_branches
 211
 212         -- | 5) create a layer for each period
 213         _ <- mapM (\period ->
 214                 subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst period) <> show (snd period))) $ do
 215                     graphAttrs [Rank SameRank]
 216                     periodToDotNode period
 217
 218                     -- | 6) create a node for each group
 219                     mapM (\g -> groupToDotNode (getRoots phylo) g (toBid g (export ^. export_branches))) (filter (\g -> g ^. phylo_groupPeriod == period) $ export ^. export_groups)
 220             ) $ getPeriodIds phylo
 221
 222         -- | 7) create the edges between a branch and its first groups
 223         _ <- mapM (\(bId,groups) ->
 224                 mapM (\g -> toDotEdge (branchIdToDotId bId) (groupIdToDotId $ getGroupId g) "" BranchToGroup) groups
 225              )
 226            $ toList
 227            $ map (\groups -> head' "toDot"
 228                            $ groupBy (\g g' -> g' ^. phylo_groupPeriod == g ^. phylo_groupPeriod)
 229                            $ sortOn (fst . _phylo_groupPeriod) groups)
 230            $ fromListWith (++) $ map (\g -> (g ^. phylo_groupBranchId,[g])) $ export ^. export_groups
 231
 232         -- | 8) create the edges between the groups
 233         _ <- mapM (\((k,k'),_) ->
 234                 toDotEdge (groupIdToDotId k) (groupIdToDotId k') "" GroupToGroup
 235             ) $ (toList . mergePointers) $ export ^. export_groups
 236
 237         -- | 7) create the edges between the periods
 238         _ <- mapM (\(prd,prd') ->
 239                 toDotEdge (periodIdToDotId prd) (periodIdToDotId prd') "" PeriodToPeriod
 240             ) $ nubBy (\combi combi' -> fst combi == fst combi') $ listToCombi' $ getPeriodIds phylo
 241
 242         -- | 8) create the edges between the branches
 243         -- _ <- mapM (\(bId,bId') ->
 244         --         toDotEdge (branchIdToDotId bId) (branchIdToDotId bId')
 245         --         (Text.pack $ show(branchIdsToProximity bId bId'
 246         --                             (getThresholdInit $ phyloProximity $ getConfig phylo)
 247         --                             (getThresholdStep $ phyloProximity $ getConfig phylo))) BranchToBranch
 248         --     ) $ nubBy (\combi combi' -> fst combi == fst combi') $ listToCombi' $ map _branch_id $ export ^. export_branches
 249
 250
 251         graphAttrs [Rank SameRank]
 252
 253
 254
 255
 256
 257 ----------------
 258 -- | Filter | --
 259 ----------------
 260
 261 filterByBranchSize :: Double -> PhyloExport -> PhyloExport
 262 filterByBranchSize thr export =
 263     let branches' = partition (\b -> head' "filter" ((b ^. branch_meta) ! "size") >= thr) $ export ^. export_branches
 264     in  export & export_branches .~ (fst branches')
 265                & export_groups %~ (filter (\g -> not $ elem  (g ^. phylo_groupBranchId) (map _branch_id $ snd branches')))
 266
 267
 268 processFilters :: [Filter] -> Quality -> PhyloExport -> PhyloExport
 269 processFilters filters qua export =
 270     foldl (\export' f -> case f of
 271                 ByBranchSize thr -> if (thr < (fromIntegral $ qua ^. qua_minBranch))
 272                                       then filterByBranchSize (fromIntegral $ qua ^. qua_minBranch) export'
 273                                       else filterByBranchSize thr export'
 274         ) export filters
 275
 276 --------------
 277 -- | Sort | --
 278 --------------
 279
 280 branchToIso :: [PhyloBranch] -> [PhyloBranch]
 281 branchToIso branches =
 282     let steps = map sum
 283               $ inits
 284               $ map (\(b,x) -> b ^. branch_y + 0.05 - x)
 285               $ zip branches
 286               $ ([0] ++ (map (\(b,b') ->
 287                                  let idx = length $ commonPrefix (b ^. branch_canonId) (b' ^. branch_canonId) []
 288                                   in (b' ^. branch_seaLevel) !! (idx - 1)
 289                                  ) $ listToSeq branches))
 290      in map (\(x,b) -> b & branch_x .~ x)
 291       $ zip steps branches
 292
 293
 294 sortByHierarchy :: Int -> [PhyloBranch] -> [PhyloBranch]
 295 sortByHierarchy depth branches =
 296     if (length branches == 1)
 297         then branchToIso branches
 298         else branchToIso $ concat
 299            $ map (\branches' ->
 300                     let partitions = partition (\b -> depth + 1 == ((length . snd) $ b ^. branch_id)) branches'
 301                     in  (sortOn (\b -> (b ^. branch_meta) ! "birth") (fst partitions))
 302                     ++  (sortByHierarchy (depth + 1) (snd partitions)))
 303             $ groupBy (\b b' -> ((take depth . snd) $ b ^. branch_id) == ((take depth . snd) $ b' ^. branch_id) )
 304             $ sortOn (\b -> (take depth . snd) $ b ^. branch_id) branches
 305
 306
 307 sortByBirthDate :: Order -> PhyloExport -> PhyloExport
 308 sortByBirthDate order export =
 309     let branches  = sortOn (\b -> (b ^. branch_meta) ! "birth") $ export ^. export_branches
 310         branches' = case order of
 311                     Asc  -> branches
 312                     Desc -> reverse branches
 313     in  export & export_branches .~ branches'
 314
 315 processSort :: Sort -> PhyloExport -> PhyloExport
 316 processSort sort' export = case sort' of
 317     ByBirthDate o -> sortByBirthDate o export
 318     ByHierarchy   -> export & export_branches .~ sortByHierarchy 0 (export ^. export_branches)
 319
 320
 321 -----------------
 322 -- | Metrics | --
 323 -----------------
 324
 325 -- | Return the conditional probability of i knowing j
 326 conditional :: Ord a => Map (a,a) Double -> a -> a -> Double
 327 conditional m i j = (findWithDefault 0 (i,j) m)
 328                   / (m ! (j,j))
 329
 330
 331 -- | Return the genericity score of a given ngram
 332 genericity :: Map (Int, Int) Double -> [Int] -> Int -> Double
 333 genericity m l i = ( (sum $ map (\j -> conditional m i j) l)
 334                    - (sum $ map (\j -> conditional m j i) l)) / (fromIntegral $ (length l) + 1)
 335
 336
 337 -- | Return the specificity score of a given ngram
 338 specificity :: Map (Int, Int) Double -> [Int] -> Int -> Double
 339 specificity m l i = ( (sum $ map (\j -> conditional m j i) l)
 340                     - (sum $ map (\j -> conditional m i j) l)) / (fromIntegral $ (length l) + 1)
 341
 342
 343 -- | Return the inclusion score of a given ngram
 344 inclusion :: Map (Int, Int) Double -> [Int] -> Int -> Double
 345 inclusion m l i = ( (sum $ map (\j -> conditional m j i) l)
 346                   + (sum $ map (\j -> conditional m i j) l)) / (fromIntegral $ (length l) + 1)
 347
 348
 349 ngramsMetrics :: PhyloExport -> PhyloExport
 350 ngramsMetrics export =
 351     over ( export_groups
 352          .  traverse )
 353     (\g -> g & phylo_groupMeta %~ insert "genericity"
 354                                   (map (\n -> genericity  (g ^. phylo_groupCooc) ((g ^. phylo_groupNgrams) \\ [n]) n) $ g ^. phylo_groupNgrams)
 355              & phylo_groupMeta %~ insert "specificity"
 356                                   (map (\n -> specificity (g ^. phylo_groupCooc) ((g ^. phylo_groupNgrams) \\ [n]) n) $ g ^. phylo_groupNgrams)
 357              & phylo_groupMeta %~ insert "inclusion"
 358                                   (map (\n -> inclusion   (g ^. phylo_groupCooc) ((g ^. phylo_groupNgrams) \\ [n]) n) $ g ^. phylo_groupNgrams)
 359         ) export
 360
 361
 362 branchDating :: PhyloExport -> PhyloExport
 363 branchDating export =
 364     over ( export_branches
 365          .  traverse )
 366     (\b ->
 367         let groups = sortOn fst
 368                    $ foldl' (\acc g -> if (g ^. phylo_groupBranchId == b ^. branch_id)
 369                                       then acc ++ [g ^. phylo_groupPeriod]
 370                                       else acc ) [] $ export ^. export_groups
 371             periods = nub groups
 372             birth = fst $ head' "birth" groups
 373             age   = (snd $ last' "age"  groups) - birth
 374         in b & branch_meta %~ insert "birth" [fromIntegral birth]
 375              & branch_meta %~ insert "age"   [fromIntegral age]
 376              & branch_meta %~ insert "size"  [fromIntegral $ length periods] ) export
 377
 378 processMetrics :: PhyloExport -> PhyloExport
 379 processMetrics export = ngramsMetrics
 380                       $ branchDating export
 381
 382
 383 -----------------
 384 -- | Taggers | --
 385 -----------------
 386
 387 getNthMostMeta :: Int -> [Double] -> [Int] -> [Int]
 388 getNthMostMeta nth meta ns = map (\(idx,_) -> (ns !! idx))
 389                            $ take nth
 390                            $ reverse
 391                            $ sortOn snd $ zip [0..] meta
 392
 393
 394 mostInclusive :: Int -> Vector Ngrams -> PhyloExport -> PhyloExport
 395 mostInclusive nth foundations export =
 396     over ( export_branches
 397          .  traverse )
 398          (\b ->
 399             let groups = filter (\g -> g ^. phylo_groupBranchId == b ^. branch_id) $ export ^. export_groups
 400                 cooc   = foldl (\acc g -> unionWith (+) acc (g ^. phylo_groupCooc)) empty groups
 401                 ngrams = sort $ foldl (\acc g -> union acc (g ^. phylo_groupNgrams)) [] groups
 402                 inc    = map (\n -> inclusion cooc (ngrams \\ [n]) n) ngrams
 403                 lbl    = ngramsToLabel foundations $ getNthMostMeta nth inc ngrams
 404             in b & branch_label .~ lbl ) export
 405
 406
 407 mostEmergentInclusive :: Int -> Vector Ngrams -> PhyloExport -> PhyloExport
 408 mostEmergentInclusive nth foundations export =
 409     over ( export_groups
 410          .  traverse )
 411          (\g ->
 412             let lbl = ngramsToLabel foundations
 413                     $ take nth
 414                     $ map (\(_,(_,idx)) -> idx)
 415                     $ concat
 416                     $ map (\groups -> sortOn (fst . snd) groups)
 417                     $ groupBy ((==) `on` fst) $ reverse $ sortOn fst
 418                     $ zip ((g ^. phylo_groupMeta) ! "inclusion")
 419                     $ zip ((g ^. phylo_groupMeta) ! "dynamics") (g ^. phylo_groupNgrams)
 420             in g & phylo_groupLabel .~ lbl ) export
 421
 422
 423 processLabels :: [PhyloLabel] -> Vector Ngrams -> PhyloExport -> PhyloExport
 424 processLabels labels foundations export =
 425     foldl (\export' label ->
 426                 case label of
 427                     GroupLabel  tagger nth ->
 428                         case tagger of
 429                             MostEmergentInclusive -> mostEmergentInclusive nth foundations export'
 430                             _ -> panic "[ERR][Viz.Phylo.PhyloExport] unknown tagger"
 431                     BranchLabel tagger nth ->
 432                         case tagger of
 433                             MostInclusive -> mostInclusive nth foundations export'
 434                             _ -> panic "[ERR][Viz.Phylo.PhyloExport] unknown tagger" ) export labels
 435
 436
 437 ------------------
 438 -- | Dynamics | --
 439 ------------------
 440
 441
 442 toDynamics :: Int -> [PhyloGroup] -> PhyloGroup -> Map Int (Date,Date) -> Double
 443 toDynamics n parents g m =
 444     let prd = g ^. phylo_groupPeriod
 445         end = last' "dynamics" (sort $ map snd $ elems m)
 446     in  if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
 447             -- | decrease
 448             then 2
 449         else if ((fst prd) == (fst $ m ! n))
 450             -- | recombination
 451             then 0
 452         else if isNew
 453             -- | emergence
 454             then 1
 455         else 3
 456     where
 457         --------------------------------------
 458         isNew :: Bool
 459         isNew = not $ elem n $ concat $ map _phylo_groupNgrams parents
 460
 461
 462 processDynamics :: [PhyloGroup] -> [PhyloGroup]
 463 processDynamics groups =
 464     map (\g ->
 465         let parents = filter (\g' -> (g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
 466                                   && ((fst $ g ^. phylo_groupPeriod) > (fst $ g' ^. phylo_groupPeriod))) groups
 467         in  g & phylo_groupMeta %~ insert "dynamics" (map (\n -> toDynamics n parents g mapNgrams) $ g ^. phylo_groupNgrams) ) groups
 468     where
 469         --------------------------------------
 470         mapNgrams :: Map Int (Date,Date)
 471         mapNgrams = map (\dates ->
 472                         let dates' = sort dates
 473                         in (head' "dynamics" dates', last' "dynamics" dates'))
 474                   $ fromListWith (++)
 475                   $ foldl (\acc g -> acc ++ ( map (\n -> (n,[fst $ g ^. phylo_groupPeriod, snd $ g ^. phylo_groupPeriod]))
 476                                             $ (g ^. phylo_groupNgrams))) [] groups
 477
 478
 479 ---------------------
 480 -- | phyloExport | --
 481 ---------------------
 482
 483 toPhyloExport :: Phylo -> DotGraph DotId
 484 toPhyloExport phylo = exportToDot phylo
 485                     $ processFilters (exportFilter $ getConfig phylo) (phyloQuality $ getConfig phylo)
 486                     $ processSort    (exportSort   $ getConfig phylo)
 487                     $ processLabels  (exportLabel  $ getConfig phylo) (getRoots phylo)
 488                     $ processMetrics  export
 489     where
 490         export :: PhyloExport
 491         export = PhyloExport groups branches
 492         --------------------------------------
 493         branches :: [PhyloBranch]
 494         branches = map (\g ->
 495                       let seaLvl = (g ^. phylo_groupMeta) ! "seaLevels"
 496                           breaks = (g ^. phylo_groupMeta) ! "breaks"
 497                           canonId = take (round $ (last' "export" breaks) + 2) (snd $ g ^. phylo_groupBranchId)
 498                        in PhyloBranch (g ^. phylo_groupBranchId)
 499                                       canonId
 500                                       seaLvl
 501                                       0
 502                                       (last' "export" (take (round $ (last' "export" breaks) + 1) seaLvl))
 503                                       0
 504                                       0
 505                                       "" empty)
 506                   $ map (\gs -> head' "export" gs)
 507                   $ groupBy (\g g' -> g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
 508                   $ sortOn (\g -> g ^. phylo_groupBranchId) groups
 509         --------------------------------------
 510         groups :: [PhyloGroup]
 511         groups = traceExportGroups
 512                $ processDynamics
 513                $ getGroupsFromLevel (phyloLevel $ getConfig phylo)
 514                $ tracePhyloInfo phylo
 515
 516
 517 traceExportBranches :: [PhyloBranch] -> [PhyloBranch]
 518 traceExportBranches branches = trace ("\n"
 519   <> "-- | Export " <> show(length branches) <> " branches") branches
 520
 521 tracePhyloInfo :: Phylo -> Phylo
 522 tracePhyloInfo phylo = trace ("\n"  <> "##########################" <> "\n\n" <> "-- | Phylo with β = "
 523     <> show(_qua_granularity $ phyloQuality $ getConfig phylo) <> " applied to "
 524     <> show(length $ Vector.toList $ getRoots phylo) <> " foundations"
 525   ) phylo
 526
 527
 528 traceExportGroups :: [PhyloGroup] -> [PhyloGroup]
 529 traceExportGroups groups = trace ("\n" <> "-- | Export "
 530     <> show(length $ nub $ map (\g -> g ^. phylo_groupBranchId) groups) <> " branches, "
 531     <> show(length groups) <> " groups and "
 532     <> show(length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) groups) <> " terms"
 533   ) groups
 534