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