src/Gargantext/Core/Viz/Phylo/PhyloTools.hs

   1 {-|
   2 Module      : Gargantext.Core.Viz.Phylo.PhyloTools
   3 Description : Module dedicated to all the tools needed for making 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 ViewPatterns      #-}
  12
  13 module Gargantext.Core.Viz.Phylo.PhyloTools where
  14
  15 import Data.Vector (Vector, elemIndex)
  16 import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy, group)
  17 import Data.Set (Set, disjoint)
  18 import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
  19 import Data.String (String)
  20 import Data.Text (Text,unpack)
  21
  22 import Prelude (floor,read)
  23
  24 import Gargantext.Prelude
  25 import Gargantext.Core.Viz.AdaptativePhylo
  26 import Text.Printf
  27
  28
  29 import Debug.Trace (trace)
  30 import Control.Lens hiding (Level)
  31
  32 import qualified Data.Vector as Vector
  33 import qualified Data.List as List
  34 import qualified Data.Set as Set
  35 import qualified Data.Map as Map
  36 import qualified Data.Text as Text
  37
  38 ------------
  39 -- | Io | --
  40 ------------
  41
  42 -- | To print an important message as an IO()
  43 printIOMsg :: String -> IO ()
  44 printIOMsg msg =
  45     putStrLn ( "\n"
  46             <> "------------"
  47             <> "\n"
  48             <> "-- | " <> msg <> "\n" )
  49
  50
  51 -- | To print a comment as an IO()
  52 printIOComment :: String -> IO ()
  53 printIOComment cmt =
  54     putStrLn ( "\n" <> cmt <> "\n" )
  55
  56
  57 --------------
  58 -- | Misc | --
  59 --------------
  60
  61 -- truncate' :: Double -> Int -> Double
  62 -- truncate' x n = (fromIntegral (floor (x * t))) / t
  63 --     where t = 10^n
  64
  65 truncate' :: Double -> Int -> Double
  66 truncate' x n = (fromIntegral $ (floor (x * t) :: Int)) / t
  67     where
  68         --------------
  69         t :: Double
  70         t = 10 ^n
  71
  72 getInMap :: Int -> Map Int Double -> Double
  73 getInMap k m =
  74     if (member k m)
  75         then m ! k
  76         else 0
  77
  78 roundToStr :: (PrintfArg a, Floating a) => Int -> a -> String
  79 roundToStr = printf "%0.*f"
  80
  81
  82 countSup :: Double -> [Double] -> Int
  83 countSup s l = length $ filter (>s) l
  84
  85
  86 dropByIdx :: Int -> [a] -> [a]
  87 dropByIdx k l = take k l ++ drop (k+1) l
  88
  89
  90 elemIndex' :: Eq a => a -> [a] -> Int
  91 elemIndex' e l = case (List.elemIndex e l) of
  92     Nothing -> panic ("[ERR][Viz.Phylo.PhyloTools] element not in list")
  93     Just i  -> i
  94
  95
  96 commonPrefix :: Eq a => [a] -> [a] -> [a] -> [a]
  97 commonPrefix lst lst' acc =
  98     if (null lst || null lst')
  99         then acc
 100         else if (head' "commonPrefix" lst == head' "commonPrefix" lst')
 101                 then commonPrefix (tail lst) (tail lst') (acc ++ [head' "commonPrefix" lst])
 102                 else acc
 103
 104
 105 ---------------------
 106 -- | Foundations | --
 107 ---------------------
 108
 109
 110 -- | Is this Ngrams a Foundations Root ?
 111 isRoots :: Ngrams -> Vector Ngrams -> Bool
 112 isRoots n ns = Vector.elem n ns
 113
 114 -- | To transform a list of nrams into a list of foundation's index
 115 ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
 116 ngramsToIdx ns fdt = map (\n -> fromJust $ elemIndex n fdt) ns
 117
 118 -- | To transform a list of sources into a list of sources' index
 119 sourcesToIdx :: [Text] -> Vector Text -> [Int]
 120 sourcesToIdx ss ps = nub $ map (\s -> fromJust $ elemIndex s ps) ss
 121
 122 -- | To transform a list of Ngrams Indexes into a Label
 123 ngramsToLabel :: Vector Ngrams -> [Int] -> Text
 124 ngramsToLabel ngrams l = Text.unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
 125
 126 idxToLabel :: [Int] -> String
 127 idxToLabel l = List.unwords $ tail' "idxToLabel" $ concat $ map (\n -> ["|",show n]) l
 128
 129 idxToLabel' :: [Double] -> String
 130 idxToLabel' l = List.unwords $ tail' "idxToLabel" $ concat $ map (\n -> ["|",show n]) l
 131
 132 -- | To transform a list of Ngrams Indexes into a list of Text
 133 ngramsToText :: Vector Ngrams -> [Int] -> [Text]
 134 ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
 135
 136
 137 --------------
 138 -- | Time | --
 139 --------------
 140
 141 -- | To transform a list of periods into a set of Dates
 142 periodsToYears :: [(Date,Date)] -> Set Date
 143 periodsToYears periods = (Set.fromList . sort . concat)
 144                        $ map (\(d,d') -> [d..d']) periods
 145
 146
 147 findBounds :: [Date] -> (Date,Date)
 148 findBounds dates =
 149     let dates' = sort dates
 150     in  (head' "findBounds" dates', last' "findBounds" dates')
 151
 152
 153 toPeriods :: [Date] -> Int -> Int -> [(Date,Date)]
 154 toPeriods dates p s =
 155     let (start,end) = findBounds dates
 156     in map (\dates' -> (head' "toPeriods" dates', last' "toPeriods" dates'))
 157      $ chunkAlong p s [start .. end]
 158
 159
 160 toFstDate :: [Text] -> Text
 161 toFstDate ds = snd
 162              $ head' "firstDate"
 163              $ sortOn fst
 164              $ map (\d ->
 165                       let d' = read (filter (\c -> c /= '-') $ unpack d)::Int
 166                        in (d',d)) ds
 167
 168 toLstDate :: [Text] -> Text
 169 toLstDate ds = snd
 170              $ head' "firstDate"
 171              $ reverse
 172              $ sortOn fst
 173              $ map (\d ->
 174                       let d' = read (filter (\c -> c /= '-') $ unpack d)::Int
 175                        in (d',d)) ds
 176
 177
 178 getTimeScale :: Phylo -> [Char]
 179 getTimeScale p = case (timeUnit $ getConfig p) of
 180     Year  _ _ _ -> "year"
 181     Month _ _ _ -> "month"
 182     Week  _ _ _ -> "week"
 183     Day   _ _ _ -> "day"
 184
 185
 186 -- | Get a regular & ascendante timeScale from a given list of dates
 187 toTimeScale :: [Date] -> Int -> [Date]
 188 toTimeScale dates step =
 189     let (start,end) = findBounds dates
 190     in  [start, (start + step) .. end]
 191
 192
 193 getTimeStep :: TimeUnit -> Int
 194 getTimeStep time = case time of
 195     Year  _ s _ -> s
 196     Month _ s _ -> s
 197     Week  _ s _ -> s
 198     Day   _ s _ -> s
 199
 200 getTimePeriod :: TimeUnit -> Int
 201 getTimePeriod time = case time of
 202     Year  p _ _ -> p
 203     Month p _ _ -> p
 204     Week  p _ _ -> p
 205     Day   p _ _ -> p
 206
 207 getTimeFrame :: TimeUnit -> Int
 208 getTimeFrame time = case time of
 209     Year  _ _ f -> f
 210     Month _ _ f -> f
 211     Week  _ _ f -> f
 212     Day   _ _ f -> f
 213
 214 -------------
 215 -- | Fis | --
 216 -------------
 217
 218
 219 -- | To find if l' is nested in l
 220 isNested :: Eq a => [a] -> [a] -> Bool
 221 isNested l l'
 222   | null l'               = True
 223   | length l' > length l  = False
 224   | (union  l l') == l    = True
 225   | otherwise             = False
 226
 227
 228 -- | To filter Fis with small Support but by keeping non empty Periods
 229 keepFilled :: (Int -> [a] -> [a]) -> Int -> [a] -> [a]
 230 keepFilled f thr l = if (null $ f thr l) && (not $ null l)
 231                      then keepFilled f (thr - 1) l
 232                      else f thr l
 233
 234
 235 traceClique :: Map (Date, Date) [PhyloClique] -> String
 236 traceClique mFis = foldl (\msg cpt -> msg <> show (countSup cpt cliques) <> " (>" <> show (cpt) <> ") "  ) "" [1..6]
 237     where
 238         --------------------------------------
 239         cliques :: [Double]
 240         cliques = sort $ map (fromIntegral . length . _phyloClique_nodes) $ concat $ elems mFis
 241         --------------------------------------
 242
 243
 244 traceSupport :: Map (Date, Date) [PhyloClique] -> String
 245 traceSupport mFis = foldl (\msg cpt -> msg <> show (countSup cpt supports) <> " (>" <> show (cpt) <> ") "  ) "" [1..6]
 246     where
 247         --------------------------------------
 248         supports :: [Double]
 249         supports = sort $ map (fromIntegral . _phyloClique_support) $ concat $ elems mFis
 250         --------------------------------------
 251
 252
 253 traceFis :: [Char] -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
 254 traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map length $ elems mFis) <> "\n"
 255                          <> "Support : " <> (traceSupport mFis) <> "\n"
 256                          <> "Nb Ngrams : "  <> (traceClique mFis)  <> "\n" ) mFis
 257
 258
 259 ---------------
 260 -- | Clique| --
 261 ---------------
 262
 263
 264 getCliqueSupport :: Clique -> Int
 265 getCliqueSupport unit = case unit of
 266     Fis s _ -> s
 267     MaxClique _ _ _ -> 0
 268
 269 getCliqueSize :: Clique -> Int
 270 getCliqueSize unit = case unit of
 271     Fis _ s -> s
 272     MaxClique s _ _ -> s
 273
 274
 275 --------------
 276 -- | Cooc | --
 277 --------------
 278
 279 listToCombi' :: [a] -> [(a,a)]
 280 listToCombi' l = [(x,y) | (x:rest) <- tails l,  y <- rest]
 281
 282 listToEqual' :: Eq a => [a] -> [(a,a)]
 283 listToEqual' l = [(x,y) | x <- l, y <- l, x == y]
 284
 285 listToKeys :: Eq a =>  [a] -> [(a,a)]
 286 listToKeys lst = (listToCombi' lst) ++ (listToEqual' lst)
 287
 288 listToMatrix :: [Int] -> Map (Int,Int) Double
 289 listToMatrix lst = fromList $ map (\k -> (k,1)) $ listToKeys $ sort lst
 290
 291 listToMatrix' :: [Ngrams] -> Map (Ngrams,Ngrams) Int
 292 listToMatrix' lst = fromList $ map (\k -> (k,1)) $ listToKeys $ sort lst
 293
 294 listToSeq :: Eq a =>  [a] -> [(a,a)]
 295 listToSeq l = nubBy (\x y -> fst x == fst y) $ [ (x,y) | (x:rest) <- tails l,  y <- rest ]
 296
 297 sumCooc :: Cooc -> Cooc -> Cooc
 298 sumCooc cooc cooc' = unionWith (+) cooc cooc'
 299
 300 getTrace :: Cooc -> Double
 301 getTrace cooc = sum $ elems $ filterWithKey (\(k,k') _ -> k == k') cooc
 302
 303 coocToDiago :: Cooc -> Cooc
 304 coocToDiago cooc = filterWithKey (\(k,k') _ -> k == k') cooc
 305
 306 -- | To build the local cooc matrix of each phylogroup
 307 ngramsToCooc :: [Int] -> [Cooc] -> Cooc
 308 ngramsToCooc ngrams coocs =
 309     let cooc  = foldl (\acc cooc' -> sumCooc acc cooc') empty coocs
 310         pairs = listToKeys ngrams
 311     in  filterWithKey (\k _ -> elem k pairs) cooc
 312
 313
 314 --------------------
 315 -- | PhyloGroup | --
 316 --------------------
 317
 318 getGroupId :: PhyloGroup -> PhyloGroupId
 319 getGroupId g = ((g ^. phylo_groupPeriod, g ^. phylo_groupLevel), g ^. phylo_groupIndex)
 320
 321 idToPrd :: PhyloGroupId -> PhyloPeriodId
 322 idToPrd id = (fst . fst) id
 323
 324 groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] ->  Map a [PhyloGroup]
 325 groupByField toField groups = fromListWith (++) $ map (\g -> (toField g, [g])) groups
 326
 327 getPeriodPointers :: Filiation -> PhyloGroup -> [Pointer]
 328 getPeriodPointers fil g =
 329     case fil of
 330         ToChilds  -> g ^. phylo_groupPeriodChilds
 331         ToParents -> g ^. phylo_groupPeriodParents
 332
 333 filterProximity :: Proximity -> Double -> Double -> Bool
 334 filterProximity proximity thr local =
 335     case proximity of
 336         WeightedLogJaccard _ -> local >= thr
 337         WeightedLogSim _ -> local >= thr
 338         Hamming -> undefined
 339
 340 getProximityName :: Proximity -> String
 341 getProximityName proximity =
 342     case proximity of
 343         WeightedLogJaccard _ -> "WLJaccard"
 344         WeightedLogSim _ -> "WeightedLogSim"
 345         Hamming -> "Hamming"
 346
 347 ---------------
 348 -- | Phylo | --
 349 ---------------
 350
 351 addPointers :: Filiation -> PointerType -> [Pointer] -> PhyloGroup -> PhyloGroup
 352 addPointers fil pty pointers g =
 353     case pty of
 354         TemporalPointer -> case fil of
 355                                 ToChilds  -> g & phylo_groupPeriodChilds  .~ pointers
 356                                 ToParents -> g & phylo_groupPeriodParents .~ pointers
 357         LevelPointer    -> case fil of
 358                                 ToChilds  -> g & phylo_groupLevelChilds   .~ pointers
 359                                 ToParents -> g & phylo_groupLevelParents  .~ pointers
 360
 361
 362 getPeriodIds :: Phylo -> [(Date,Date)]
 363 getPeriodIds phylo = sortOn fst
 364                    $ keys
 365                    $ phylo ^. phylo_periods
 366
 367 getLevelParentId :: PhyloGroup -> PhyloGroupId
 368 getLevelParentId g = fst $ head' "getLevelParentId" $ g ^. phylo_groupLevelParents
 369
 370 getLastLevel :: Phylo -> Level
 371 getLastLevel phylo = last' "lastLevel" $ getLevels phylo
 372
 373 getLevels :: Phylo -> [Level]
 374 getLevels phylo = nub
 375                 $ map snd
 376                 $ keys $ view ( phylo_periods
 377                        .  traverse
 378                        . phylo_periodLevels ) phylo
 379
 380 getSeaElevation :: Phylo -> SeaElevation
 381 getSeaElevation phylo = seaElevation (getConfig phylo)
 382
 383
 384 getConfig :: Phylo -> Config
 385 getConfig phylo = (phylo ^. phylo_param) ^. phyloParam_config
 386
 387
 388 setConfig :: Config -> Phylo -> Phylo
 389 setConfig config phylo = phylo
 390                        & phylo_param .~ (PhyloParam
 391                                             ((phylo ^. phylo_param) ^. phyloParam_version)
 392                                             ((phylo ^. phylo_param) ^. phyloParam_software)
 393                                             config)
 394
 395 -- & phylo_param & phyloParam_config & phyloParam_config .~ config
 396
 397
 398 getRoots :: Phylo -> Vector Ngrams
 399 getRoots phylo = (phylo ^. phylo_foundations) ^. foundations_roots
 400
 401 getSources :: Phylo -> Vector Text
 402 getSources phylo = _sources (phylo ^. phylo_sources)
 403
 404 phyloToLastBranches :: Phylo -> [[PhyloGroup]]
 405 phyloToLastBranches phylo = elems
 406     $ fromListWith (++)
 407     $ map (\g -> (g ^. phylo_groupBranchId, [g]))
 408     $ getGroupsFromLevel (last' "byBranches" $ getLevels phylo) phylo
 409
 410 getGroupsFromLevel :: Level -> Phylo -> [PhyloGroup]
 411 getGroupsFromLevel lvl phylo =
 412     elems $ view ( phylo_periods
 413                  .  traverse
 414                  . phylo_periodLevels
 415                  .  traverse
 416                  .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
 417                  . phylo_levelGroups ) phylo
 418
 419
 420 getGroupsFromLevelPeriods :: Level -> [PhyloPeriodId] -> Phylo -> [PhyloGroup]
 421 getGroupsFromLevelPeriods lvl periods phylo =
 422     elems $ view ( phylo_periods
 423                  .  traverse
 424                  .  filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods)
 425                  . phylo_periodLevels
 426                  .  traverse
 427                  .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
 428                  . phylo_levelGroups ) phylo
 429
 430
 431 getGroupsFromPeriods :: Level -> Map PhyloPeriodId PhyloPeriod -> [PhyloGroup]
 432 getGroupsFromPeriods lvl periods =
 433     elems $ view (  traverse
 434                  . phylo_periodLevels
 435                  .  traverse
 436                  .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
 437                  . phylo_levelGroups ) periods
 438
 439
 440 updatePhyloGroups :: Level -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
 441 updatePhyloGroups lvl m phylo =
 442     over ( phylo_periods
 443          .  traverse
 444          . phylo_periodLevels
 445          .  traverse
 446          .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
 447          . phylo_levelGroups
 448          .  traverse
 449          ) (\g ->
 450                 let id = getGroupId g
 451                 in
 452                     if member id m
 453                     then m ! id
 454                     else g ) phylo
 455
 456 updatePeriods :: Map (Date,Date) (Text,Text) -> Phylo -> Phylo
 457 updatePeriods periods' phylo =
 458     over (phylo_periods . traverse)
 459             (\prd ->
 460                 let prd' = periods' ! (prd ^. phylo_periodPeriod)
 461                     lvls = map (\lvl -> lvl & phylo_levelPeriod' .~ prd') $ prd ^. phylo_periodLevels
 462                  in prd & phylo_periodPeriod' .~ prd'
 463                         & phylo_periodLevels  .~ lvls
 464                 ) phylo
 465
 466
 467 traceToPhylo :: Level -> Phylo -> Phylo
 468 traceToPhylo lvl phylo =
 469     trace ("\n" <> "-- | End of phylo making at level " <> show (lvl) <> " with "
 470                 <> show (length $ getGroupsFromLevel lvl phylo) <> " groups and "
 471                 <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel lvl phylo) <> " branches" <> "\n") phylo
 472
 473 --------------------
 474 -- | Clustering | --
 475 --------------------
 476
 477 mergeBranchIds :: [[Int]] -> [Int]
 478 mergeBranchIds ids = (head' "mergeBranchIds" . sort . mostFreq') ids
 479   where
 480     -- | 2) find the most Up Left ids in the hierarchy of similarity
 481     -- mostUpLeft :: [[Int]] -> [[Int]]
 482     -- mostUpLeft ids' =
 483     --      let groupIds = (map (\gIds -> (length $ head' "gIds" gIds, head' "gIds" gIds)) . groupBy (\id id' -> length id == length id') . sortOn length) ids'
 484     --          inf = (fst . minimum) groupIds
 485     --      in map snd $ filter (\gIds -> fst gIds == inf) groupIds
 486     -- | 1) find the most frequent ids
 487     mostFreq' :: [[Int]] -> [[Int]]
 488     mostFreq' ids' =
 489        let groupIds = (map (\gIds -> (length gIds, head' "gIds" gIds)) . group . sort) ids'
 490            sup = (fst . maximum) groupIds
 491         in map snd $ filter (\gIds -> fst gIds == sup) groupIds
 492
 493
 494 mergeMeta :: [Int] -> [PhyloGroup] -> Map Text [Double]
 495 mergeMeta bId groups =
 496   let ego = head' "mergeMeta" $ filter (\g -> (snd (g ^. phylo_groupBranchId)) == bId) groups
 497    in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")]
 498
 499
 500 groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
 501 groupsToBranches groups =
 502     {- run the related component algorithm -}
 503     let egos  = map (\g -> [getGroupId g]
 504                         ++ (map fst $ g ^. phylo_groupPeriodParents)
 505                         ++ (map fst $ g ^. phylo_groupPeriodChilds)
 506                         ++ (map fst $ g ^. phylo_groupAncestors)) $ elems groups
 507         graph = relatedComponents egos
 508     {- update each group's branch id -}
 509     in map (\ids ->
 510         let groups' = elems $ restrictKeys groups (Set.fromList ids)
 511             bId = mergeBranchIds $ map (\g -> snd $ g ^. phylo_groupBranchId) groups'
 512          in map (\g -> g & phylo_groupBranchId %~ (\(lvl,_) -> (lvl,bId))) groups') graph
 513
 514 relatedComponents :: Ord a => [[a]] -> [[a]]
 515 relatedComponents graph = foldl' (\acc groups ->
 516     if (null acc)
 517     then acc ++ [groups]
 518     else
 519         let acc' = partition (\groups' -> disjoint (Set.fromList groups') (Set.fromList groups)) acc
 520          in (fst acc') ++ [nub $ concat $ (snd acc') ++ [groups]]) [] graph
 521
 522 toRelatedComponents :: [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)] -> [[PhyloGroup]]
 523 toRelatedComponents nodes edges =
 524   let ref = fromList $ map (\g -> (getGroupId g, g)) nodes
 525       clusters = relatedComponents $ ((map (\((g,g'),_) -> [getGroupId g, getGroupId g']) edges) ++ (map (\g -> [getGroupId g]) nodes))
 526    in map (\cluster -> map (\gId -> ref ! gId) cluster) clusters
 527
 528
 529 traceSynchronyEnd :: Phylo -> Phylo
 530 traceSynchronyEnd phylo =
 531     trace ( "-- | End synchronic clustering at level " <> show (getLastLevel phylo)
 532                  <> " with " <> show (length $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " groups"
 533                  <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " branches"
 534                  <> "\n" ) phylo
 535
 536 traceSynchronyStart :: Phylo -> Phylo
 537 traceSynchronyStart phylo =
 538     trace ( "\n" <> "-- | Start synchronic clustering at level " <> show (getLastLevel phylo)
 539                  <> " with " <> show (length $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " groups"
 540                  <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " branches"
 541                  <> "\n" ) phylo
 542
 543
 544 -------------------
 545 -- | Proximity | --
 546 -------------------
 547
 548 getSensibility :: Proximity -> Double
 549 getSensibility proxi = case proxi of
 550     WeightedLogJaccard s -> s
 551     WeightedLogSim s -> s
 552     Hamming -> undefined
 553
 554 ----------------
 555 -- | Branch | --
 556 ----------------
 557
 558 intersectInit :: Eq a => [a] -> [a] -> [a] -> [a]
 559 intersectInit acc lst lst' =
 560     if (null lst) || (null lst')
 561     then acc
 562     else if (head' "intersectInit" lst) == (head' "intersectInit" lst')
 563          then intersectInit (acc ++ [head' "intersectInit" lst]) (tail lst) (tail lst')
 564          else acc
 565
 566 branchIdsToProximity :: PhyloBranchId -> PhyloBranchId -> Double -> Double -> Double
 567 branchIdsToProximity id id' thrInit thrStep = thrInit + thrStep * (fromIntegral $ length $ intersectInit [] (snd id) (snd id'))
 568
 569 ngramsInBranches :: [[PhyloGroup]] -> [Int]
 570 ngramsInBranches branches = nub $ foldl (\acc g -> acc ++ (g ^. phylo_groupNgrams)) [] $ concat branches
 571
 572
 573 traceMatchSuccess :: Double -> Double -> Double -> [[[PhyloGroup]]] -> [[[PhyloGroup]]]
 574 traceMatchSuccess thr qua qua' nextBranches =
 575     trace ( "\n" <> "-- local branches : " <> (init $ show ((init . init . snd)
 576                                                     $ (head' "trace" $ head' "trace" $ head' "trace" nextBranches) ^. phylo_groupBranchId))
 577                                            <> ",(1.." <> show (length nextBranches) <> ")]"
 578                  <> " | " <> show ((length . concat . concat) nextBranches) <> " groups" <> "\n"
 579          <> " - splited with success in "  <> show (map length nextBranches) <> " sub-branches" <> "\n"
 580          <> " - for the local threshold "  <> show (thr) <> " ( quality : " <> show (qua) <> " < " <> show(qua') <> ")\n" ) nextBranches
 581
 582
 583 traceMatchFailure :: Double -> Double -> Double -> [[PhyloGroup]] -> [[PhyloGroup]]
 584 traceMatchFailure thr qua qua' branches =
 585     trace ( "\n" <> "-- local branches : " <> (init $ show ((init . snd) $ (head' "trace" $ head' "trace" branches) ^. phylo_groupBranchId))
 586                                            <> ",(1.." <> show (length branches) <> ")]"
 587                  <> " | " <> show (length $ concat branches) <> " groups" <> "\n"
 588          <> " - split with failure for the local threshold " <> show (thr) <> " ( quality : " <> show (qua) <> " > " <> show(qua') <> ")\n"
 589         ) branches
 590
 591
 592 traceMatchNoSplit :: [[PhyloGroup]] -> [[PhyloGroup]]
 593 traceMatchNoSplit branches =
 594     trace ( "\n" <> "-- local branches : " <> (init $ show ((init . snd) $ (head' "trace" $ head' "trace" branches) ^. phylo_groupBranchId))
 595                                            <> ",(1.." <> show (length branches) <> ")]"
 596                  <> " | " <> show (length $ concat branches) <> " groups" <> "\n"
 597          <> " - unable to split in smaller branches" <> "\n"
 598         ) branches
 599
 600
 601 traceMatchLimit :: [[PhyloGroup]] -> [[PhyloGroup]]
 602 traceMatchLimit branches =
 603     trace ( "\n" <> "-- local branches : " <> (init $ show ((init . snd) $ (head' "trace" $ head' "trace" branches) ^. phylo_groupBranchId))
 604                                            <> ",(1.." <> show (length branches) <> ")]"
 605                  <> " | " <> show (length $ concat branches) <> " groups" <> "\n"
 606          <> " - unable to increase the threshold above 1" <> "\n"
 607         ) branches
 608
 609
 610 traceMatchEnd :: [PhyloGroup] -> [PhyloGroup]
 611 traceMatchEnd groups =
 612     trace ("\n" <> "-- | End temporal matching with " <> show (length $ nub $ map (\g -> g ^. phylo_groupBranchId) groups)
 613                                                          <> " branches and " <> show (length groups) <> " groups" <> "\n") groups
 614
 615
 616 traceTemporalMatching :: [PhyloGroup] -> [PhyloGroup]
 617 traceTemporalMatching groups =
 618     trace ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n") groups
 619
 620
 621 traceGroupsProxi :: Map (PhyloGroupId,PhyloGroupId) Double -> Map (PhyloGroupId,PhyloGroupId) Double
 622 traceGroupsProxi m =
 623     trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m