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