src/Gargantext/Viz/Phylo/TemporalMatching.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.TemporalMatching
   3 Description : Module dedicated to the adaptative temporal matching 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
  16 module Gargantext.Viz.Phylo.TemporalMatching where
  17
  18 import Data.List (concat, splitAt, tail, sortOn, (++), intersect, null, inits, groupBy, scanl, nub, union, dropWhile, partition, or, sort, (!!))
  19 import Data.Map  (Map, fromList, elems, restrictKeys, unionWith, findWithDefault, keys, (!), (!?), filterWithKey, singleton, empty, mapKeys, adjust)
  20
  21 import Gargantext.Prelude
  22 import Gargantext.Viz.AdaptativePhylo
  23 import Gargantext.Viz.Phylo.PhyloTools
  24
  25 import Prelude (floor)
  26 import Control.Lens hiding (Level)
  27 import Control.Parallel.Strategies (parList, rdeepseq, using)
  28 import Debug.Trace (trace)
  29
  30 import Text.Printf
  31
  32 import qualified Data.Map as Map
  33 import qualified Data.Set as Set
  34
  35
  36 -------------------
  37 -- | Proximity | --
  38 -------------------
  39
  40
  41 -- | To compute a jaccard similarity between two lists
  42 jaccard :: [Int] -> [Int] -> Double
  43 jaccard inter' union' = ((fromIntegral . length) $ inter') / ((fromIntegral . length) $ union')
  44
  45
  46 -- | Process the inverse sumLog
  47 sumInvLog' :: Double -> Double -> [Double] -> Double
  48 sumInvLog' s nb diago = foldl (\mem occ -> mem + (1 / (log (occ + s) / log (nb + s)))) 0 diago
  49
  50
  51 -- | Process the sumLog
  52 sumLog' :: Double -> Double -> [Double] -> Double
  53 sumLog' s nb diago = foldl (\mem occ -> mem + (log (occ + s) / log (nb + s))) 0 diago
  54
  55
  56 weightedLogJaccard' :: Double -> Double -> Map Int Double -> [Int] -> [Int] -> Double
  57 weightedLogJaccard' sens nbDocs diago ngrams ngrams'
  58   | null ngramsInter           = 0
  59   | ngramsInter == ngramsUnion = 1
  60   | sens == 0    = jaccard ngramsInter ngramsUnion
  61   | sens > 0     = (sumInvLog' sens nbDocs diagoInter) / (sumInvLog' sens nbDocs diagoUnion)
  62   | otherwise    = (sumLog' sens nbDocs diagoInter) / (sumLog' sens nbDocs diagoUnion)
  63   where
  64     --------------------------------------
  65     ngramsInter :: [Int]
  66     ngramsInter = intersect ngrams ngrams'
  67     --------------------------------------
  68     ngramsUnion :: [Int]
  69     ngramsUnion = union ngrams ngrams'
  70     --------------------------------------
  71     diagoInter :: [Double]
  72     diagoInter =  elems $ restrictKeys diago (Set.fromList ngramsInter)
  73     --------------------------------------
  74     diagoUnion :: [Double]
  75     diagoUnion =  elems $ restrictKeys diago (Set.fromList ngramsUnion)
  76     --------------------------------------
  77
  78
  79 -- | To process the proximity between a current group and a pair of targets group
  80 toProximity :: Double -> Map Int Double -> Proximity -> [Int] -> [Int] -> [Int] -> Double
  81 toProximity nbDocs diago proximity egoNgrams targetNgrams targetNgrams' =
  82   case proximity of
  83     WeightedLogJaccard sens ->
  84       let pairNgrams = if targetNgrams == targetNgrams'
  85                           then targetNgrams
  86                           else union targetNgrams targetNgrams'
  87        in weightedLogJaccard' sens nbDocs diago egoNgrams pairNgrams
  88     Hamming -> undefined
  89
  90
  91 ------------------------
  92 -- | Local Matching | --
  93 ------------------------
  94
  95 findLastPeriod :: Filiation -> [PhyloPeriodId] -> PhyloPeriodId
  96 findLastPeriod fil periods = case fil of
  97     ToParents -> head' "findLastPeriod" (sortOn fst periods)
  98     ToChilds  -> last' "findLastPeriod" (sortOn fst periods)
  99
 100
 101 -- | To filter pairs of candidates related to old pointers periods
 102 removeOldPointers :: [Pointer] -> Filiation -> Double -> Proximity -> PhyloPeriodId
 103                   -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
 104                   -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
 105 removeOldPointers oldPointers fil thr prox prd pairs
 106   | null oldPointers = pairs
 107   | null (filterPointers prox thr oldPointers) =
 108     let lastMatchedPrd = findLastPeriod fil (map (fst . fst . fst) oldPointers)
 109      in if lastMatchedPrd == prd
 110         then []
 111         else filter (\((id,_),(id',_)) ->
 112                 case fil of
 113                      ToParents -> (((fst . fst . fst) id ) < (fst lastMatchedPrd))
 114                                || (((fst . fst . fst) id') < (fst lastMatchedPrd))
 115                      ToChilds  -> (((fst . fst . fst) id ) > (fst lastMatchedPrd))
 116                                || (((fst . fst . fst) id') > (fst lastMatchedPrd))) pairs
 117   | otherwise = []
 118
 119
 120 makePairs' :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [PhyloPeriodId] -> [Pointer] -> Filiation -> Double -> Proximity
 121            -> Map Date Double -> Map Date Cooc -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
 122 makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs diagos =
 123     if (null periods)
 124         then []
 125         else removeOldPointers oldPointers fil thr prox lastPrd
 126            -- | at least on of the pair candidates should be from the last added period
 127            $ filter (\((id,_),(id',_)) -> ((fst . fst) id == lastPrd) || ((fst . fst) id' == lastPrd))
 128            $ listToKeys
 129            $ filter (\(id,ngrams) ->
 130                 let nbDocs = (sum . elems) $ filterDocs docs    ([(fst . fst) egoId, (fst . fst) id])
 131                     diago  = reduceDiagos  $ filterDiago diagos ([(fst . fst) egoId, (fst . fst) id])
 132                  in (toProximity nbDocs diago prox egoNgrams egoNgrams ngrams) >= thr
 133             ) candidates
 134     where
 135       lastPrd :: PhyloPeriodId
 136       lastPrd = findLastPeriod fil periods
 137
 138
 139 filterPointers :: Proximity -> Double -> [Pointer] -> [Pointer]
 140 filterPointers proxi thr pts = filter (\(_,w) -> filterProximity proxi thr w) pts
 141
 142
 143 reduceDiagos :: Map Date Cooc -> Map Int Double
 144 reduceDiagos diagos = mapKeys (\(k,_) -> k)
 145                     $ foldl (\acc diago -> unionWith (+) acc diago) empty (elems diagos)
 146
 147
 148 phyloGroupMatching :: [[(PhyloGroupId,[Int])]] -> Filiation -> Proximity -> Map Date Double -> Map Date Cooc
 149                    -> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer]
 150 phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams) =
 151         if (null $ filterPointers proxi thr oldPointers)
 152           -- | let's find new pointers
 153           then if null nextPointers
 154             then []
 155             else head' "phyloGroupMatching"
 156                -- | Keep only the best set of pointers grouped by proximity
 157                $ groupBy (\pt pt' -> snd pt == snd pt')
 158                $ reverse $ sortOn snd $ head' "pointers" nextPointers
 159                -- | Find the first time frame where at leats one pointer satisfies the proximity threshold
 160           else oldPointers
 161     where
 162         nextPointers :: [[Pointer]]
 163         nextPointers = take 1
 164                  $ dropWhile (null)
 165                  -- | for each time frame, process the proximity on relevant pairs of targeted groups
 166                  $ scanl (\acc groups ->
 167                             let periods = nub $ map (fst . fst . fst) $ concat groups
 168                                 nbdocs  = sum $ elems $ (filterDocs docs ([(fst . fst) id] ++ periods))
 169                                 diago   = reduceDiagos
 170                                         $ filterDiago diagos ([(fst . fst) id] ++ periods)
 171                                         -- | important resize nbdocs et diago dans le make pairs
 172                                 pairs = makePairs' (id,ngrams) (concat groups) periods oldPointers fil thr proxi docs diagos
 173                             in acc ++ ( filterPointers proxi thr
 174                                         $ concat
 175                                         $ map (\(c,c') ->
 176                                             -- | process the proximity between the current group and a pair of candidates
 177                                             let proximity = toProximity nbdocs diago proxi ngrams (snd c) (snd c')
 178                                             in if (c == c')
 179                                                then [(fst c,proximity)]
 180                                                else [(fst c,proximity),(fst c',proximity)] ) pairs )) []
 181                  $ inits candidates -- | groups from [[1900],[1900,1901],[1900,1901,1902],...]
 182
 183
 184 filterDocs :: Map Date Double -> [PhyloPeriodId] -> Map Date Double
 185 filterDocs d pds = restrictKeys d $ periodsToYears pds
 186
 187 filterDiago :: Map Date Cooc -> [PhyloPeriodId] -> Map Date Cooc
 188 filterDiago diago pds = restrictKeys diago $ periodsToYears pds
 189
 190
 191 -----------------------------
 192 -- | Matching Processing | --
 193 -----------------------------
 194
 195
 196 getNextPeriods :: Filiation -> Int -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
 197 getNextPeriods fil max' pId pIds =
 198     case fil of
 199         ToChilds  -> take max' $ (tail . snd) $ splitAt (elemIndex' pId pIds) pIds
 200         ToParents -> take max' $ (reverse . fst) $ splitAt (elemIndex' pId pIds) pIds
 201
 202
 203 getCandidates :: PhyloGroup -> [[(PhyloGroupId,[Int])]] -> [[(PhyloGroupId,[Int])]]
 204 getCandidates ego targets =
 205   map (\groups' ->
 206     filter (\g' -> (not . null) $ intersect (ego ^. phylo_groupNgrams) (snd g')
 207   ) groups') targets
 208
 209
 210 matchGroupsToGroups :: Int -> [PhyloPeriodId] -> Proximity -> Double -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
 211 matchGroupsToGroups frame periods proximity thr docs coocs groups =
 212   let groups' = groupByField _phylo_groupPeriod groups
 213    in foldl' (\acc prd ->
 214         let -- | 1) find the parents/childs matching periods
 215             periodsPar = getNextPeriods ToParents frame prd periods
 216             periodsChi = getNextPeriods ToChilds  frame prd periods
 217             -- | 2) find the parents/childs matching candidates
 218             candidatesPar = map (\prd' -> map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ findWithDefault [] prd' groups') periodsPar
 219             candidatesChi = map (\prd' -> map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ findWithDefault [] prd' groups') periodsChi
 220             -- | 3) find the parents/child number of docs by years
 221             docsPar = filterDocs docs ([prd] ++ periodsPar)
 222             docsChi = filterDocs docs ([prd] ++ periodsChi)
 223             -- | 4) find the parents/child diago by years
 224             diagoPar = filterDiago (map coocToDiago coocs) ([prd] ++ periodsPar)
 225             diagoChi = filterDiago (map coocToDiago coocs) ([prd] ++ periodsPar)
 226             -- | 5) match in parallel all the groups (egos) to their possible candidates
 227             egos  = map (\ego ->
 228                       let pointersPar = phyloGroupMatching (getCandidates ego candidatesPar) ToParents proximity docsPar diagoPar
 229                                         thr (getPeriodPointers ToParents ego) (getGroupId ego, ego ^. phylo_groupNgrams)
 230                           pointersChi = phyloGroupMatching (getCandidates ego candidatesChi) ToChilds  proximity docsChi diagoChi
 231                                         thr (getPeriodPointers ToChilds  ego) (getGroupId ego, ego ^. phylo_groupNgrams)
 232                        in addPointers ToChilds  TemporalPointer pointersChi
 233                         $ addPointers ToParents TemporalPointer pointersPar ego)
 234                   $ findWithDefault [] prd groups'
 235             egos' = egos `using` parList rdeepseq
 236          in acc ++ egos'
 237     ) [] periods
 238
 239
 240 -----------------------
 241 -- | Phylo Quality | --
 242 -----------------------
 243
 244
 245 relevantBranches :: Int -> [[PhyloGroup]] -> [[PhyloGroup]]
 246 relevantBranches term branches =
 247     filter (\groups -> (any (\group -> elem term $ group ^. phylo_groupNgrams) groups)) branches
 248
 249 fScore :: Double -> Int -> [PhyloGroup] -> [[PhyloGroup]] -> Double
 250 fScore beta x bk bx =
 251   let recall = ( (fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) bk)
 252                / (fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) $ concat bx))
 253       accuracy = ( (fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) bk)
 254                  / (fromIntegral $ length bk))
 255    in ((1 + beta ** 2) * accuracy * recall)
 256     / (((beta ** 2) * accuracy + recall))
 257
 258
 259 wk :: [PhyloGroup] -> Double
 260 wk bk = fromIntegral $ length bk
 261
 262
 263 toPhyloQuality' :: Double -> Map Int Double -> [[PhyloGroup]] -> Double
 264 toPhyloQuality' beta freq branches =
 265   if (null branches)
 266     then 0
 267     else sum
 268        $ map (\i ->
 269           let bks = relevantBranches i branches
 270            in (freq ! i) * (sum $ map (\bk -> ((wk bk) / (sum $ map wk bks)) * (fScore beta i bk bks)) bks))
 271        $ keys freq
 272
 273 -- | here we do the average of all the local f_scores
 274 toPhyloQuality :: Double -> Map Int Double -> [[PhyloGroup]] -> Double
 275 toPhyloQuality beta freq branches =
 276   if (null branches)
 277     then 0
 278     else sum
 279        $ map (\x ->
 280           let px = freq ! x
 281               bx = relevantBranches x branches
 282               wks = sum $ map wk bx
 283            in (px / pys) * (sum $ map (\bk -> ((wk bk) / wks) * (fScore beta x bk bx)) bx))
 284        $ keys freq
 285   where
 286       pys :: Double
 287       pys = sum (elems freq)
 288
 289
 290 ------------------------------------
 291 -- | Constant Temporal Matching | --
 292 ------------------------------------
 293
 294
 295 groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
 296 groupsToBranches groups =
 297     -- | run the related component algorithm
 298     let egos = groupBy (\gs gs' -> (fst $ fst $ head' "egos" gs) == (fst $ fst $ head' "egos" gs'))
 299              $ sortOn  (\gs -> fst $ fst $ head' "egos" gs)
 300              $ map (\group -> [getGroupId group]
 301                             ++ (map fst $ group ^. phylo_groupPeriodParents)
 302                             ++ (map fst $ group ^. phylo_groupPeriodChilds) ) $ elems groups
 303         -- | first find the related components by inside each ego's period
 304         -- | a supprimer
 305         graph' = map relatedComponents egos
 306         -- | then run it for the all the periods
 307         graph  = zip [1..]
 308                $ relatedComponents $ concat (graph' `using` parList rdeepseq)
 309     -- | update each group's branch id
 310     in map (\(bId,ids) ->
 311         let groups'  = map (\group -> group & phylo_groupBranchId %~ (\(lvl,lst) -> (lvl,lst ++ [bId])))
 312                      $ elems $ restrictKeys groups (Set.fromList ids)
 313          in groups' `using` parList rdeepseq ) graph
 314
 315
 316 reduceFrequency :: Map Int Double -> [[PhyloGroup]] -> Map Int Double
 317 reduceFrequency frequency branches =
 318   restrictKeys frequency (Set.fromList $ (nub . concat) $ map _phylo_groupNgrams $ concat branches)
 319
 320 updateThr :: Double -> [[PhyloGroup]] -> [[PhyloGroup]]
 321 updateThr thr branches = map (\b -> map (\g ->
 322   g & phylo_groupMeta .~ (singleton "seaLevels" (((g ^. phylo_groupMeta) ! "seaLevels") ++ [thr]))) b) branches
 323
 324
 325 -- | Sequentially break each branch of a phylo where
 326 -- done = all the allready broken branches
 327 -- ego  = the current branch we want to break
 328 -- rest = the branches we still have to break
 329 breakBranches :: Proximity -> Double -> Map Int Double -> Int -> Double -> Double -> Double
 330               -> Int -> Map Date Double -> Map Date Cooc -> [PhyloPeriodId] -> [([PhyloGroup],Bool)] -> ([PhyloGroup],Bool) -> [([PhyloGroup],Bool)] -> [([PhyloGroup],Bool)]
 331 breakBranches proximity beta frequency minBranch thr depth elevation frame docs coocs periods done ego rest =
 332   -- | 1) keep or not the new division of ego
 333   let done' = done ++ (if snd ego
 334                         then
 335                             (if ((null (fst ego')) || (quality > quality'))
 336                                then
 337                                 -- trace ("  ✗ F(β) = " <> show(quality) <> " (vs) " <> show(quality')
 338                                 --         <> "  | "  <> show(length $ fst ego) <> " groups : "
 339                                 --         <> "  |✓ " <> show(length $ fst ego') <> show(map length $ fst ego')
 340                                 --         <> "  |✗ " <> show(length $ snd ego') <> "[" <> show(length $ concat $ snd ego') <> "]")
 341                                   [(fst ego,False)]
 342                                else
 343                                 -- trace ("  ✓ level = " <> printf "%.1f" thr <> "")
 344                                 -- trace ("  ✓ F(β) = " <> show(quality) <> " (vs) " <> show(quality')
 345                                 --         <> "  | "  <> show(length $ fst ego) <> " groups : "
 346                                 --         <> "  |✓ " <> show(length $ fst ego') <> show(map length $ fst ego')
 347                                 --         <> "  |✗ " <> show(length $ snd ego') <> "[" <> show(length $ concat $ snd ego') <> "]")
 348                                   ((map (\e -> (e,True)) (fst ego')) ++ (map (\e -> (e,False)) (snd ego'))))
 349                         else [ego])
 350   in
 351     -- | 2) if there is no more branches in rest then return else continue
 352     if null rest
 353       then done'
 354       else breakBranches proximity beta frequency minBranch thr depth elevation frame docs coocs periods
 355                        done' (head' "breakBranches" rest) (tail' "breakBranches" rest)
 356   where
 357     --------------------------------------
 358     quality :: Double
 359     quality = toPhyloQuality beta frequency ((map fst done) ++ [fst ego] ++ (map fst rest))
 360     --------------------------------------
 361     ego' :: ([[PhyloGroup]],[[PhyloGroup]])
 362     ego' =
 363       let branches  = groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
 364                     $ matchGroupsToGroups frame periods proximity thr docs coocs (fst ego)
 365           branches' = branches `using` parList rdeepseq
 366        in partition (\b -> (length $ nub $ map _phylo_groupPeriod b) >= minBranch)
 367         $ thrToMeta thr
 368         $ depthToMeta (elevation - depth) branches'
 369     --------------------------------------
 370     quality' :: Double
 371     quality' = toPhyloQuality beta frequency
 372                                     ((map fst done) ++ (fst ego') ++ (snd ego') ++ (map fst rest))
 373
 374
 375 seaLevelMatching :: Proximity -> Double -> Int -> Map Int Double -> Double -> Double -> Double -> Double
 376                  -> Int -> [PhyloPeriodId] -> Map Date Double -> Map Date Cooc -> [([PhyloGroup],Bool)] -> [([PhyloGroup],Bool)]
 377 seaLevelMatching proximity beta minBranch frequency thr step depth elevation frame periods docs coocs branches =
 378   -- | if there is no branch to break or if seaLvl level > 1 then end
 379   if (thr >= 1) || ((not . or) $ map snd branches)
 380     then branches
 381     else
 382       -- | break all the possible branches at the current seaLvl level
 383       let branches'  = trace ("↑ level = " <> printf "%.1f" thr <> " branches = " <> show(length branches))
 384                      $ breakBranches proximity beta frequency minBranch thr depth elevation frame docs coocs periods
 385                                      [] (head' "seaLevelMatching" branches) (tail' "seaLevelMatching" branches)
 386           frequency' = reduceFrequency frequency (map fst branches')
 387        in seaLevelMatching proximity beta minBranch frequency' (thr + step) step (depth - 1) elevation frame periods docs coocs branches'
 388
 389
 390 constanteTemporalMatching :: Double -> Double -> Phylo -> Phylo
 391 constanteTemporalMatching start step phylo = updatePhyloGroups 1
 392                          (fromList $ map (\g -> (getGroupId g,g)) $ traceMatchEnd $ concat branches)
 393                          (toPhyloHorizon phylo)
 394   where
 395     -- | 2) process the temporal matching by elevating seaLvl level
 396     branches :: [[PhyloGroup]]
 397     branches = map fst
 398              $ seaLevelMatching (phyloProximity $ getConfig phylo)
 399                                 (_qua_granularity $ phyloQuality $ getConfig phylo)
 400                                 (_qua_minBranch $ phyloQuality $ getConfig phylo)
 401                                 (phylo ^. phylo_termFreq)
 402                                 start step
 403                                 ((((1 - start) / step) - 1))
 404                                 (((1 - start) / step))
 405                                 (getTimeFrame $ timeUnit $ getConfig phylo)
 406                                 (getPeriodIds phylo)
 407                                 (phylo ^. phylo_timeDocs)
 408                                 (phylo ^. phylo_timeCooc)
 409                                 groups
 410     -- | 1) for each group process an initial temporal Matching
 411     -- | here we suppose that all the groups of level 1 are part of the same big branch
 412     groups :: [([PhyloGroup],Bool)]
 413     groups = map (\b -> (b,(length $ nub $ map _phylo_groupPeriod b) >= (_qua_minBranch $ phyloQuality $ getConfig phylo)))
 414            $ groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
 415            $ matchGroupsToGroups (getTimeFrame $ timeUnit $ getConfig phylo)
 416                          (getPeriodIds phylo) (phyloProximity $ getConfig phylo)
 417                          start
 418                          (phylo ^. phylo_timeDocs)
 419                          (phylo ^. phylo_timeCooc)
 420                          (traceTemporalMatching $ getGroupsFromLevel 1 phylo)
 421
 422 -----------------
 423 -- | Horizon | --
 424 -----------------
 425
 426 toPhyloHorizon :: Phylo -> Phylo
 427 toPhyloHorizon phylo =
 428   let t0 = take 1 (getPeriodIds phylo)
 429       groups = getGroupsFromLevelPeriods 1 t0 phylo
 430       sens = getSensibility (phyloProximity $ getConfig phylo)
 431       nbDocs = sum $ elems $ filterDocs (phylo ^. phylo_timeDocs) t0
 432       diago = reduceDiagos $ filterDiago (phylo ^. phylo_timeCooc) t0
 433    in phylo & phylo_horizon .~ (fromList $ map (\(g,g') ->
 434         ((getGroupId g,getGroupId g'),weightedLogJaccard' sens nbDocs diago (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) $ listToCombi' groups)
 435
 436
 437 --------------------------------------
 438 -- | Adaptative Temporal Matching | --
 439 --------------------------------------
 440
 441
 442 thrToMeta :: Double -> [[PhyloGroup]] -> [[PhyloGroup]]
 443 thrToMeta thr branches =
 444   map (\b ->
 445     map (\g -> g & phylo_groupMeta .~ (adjust (\lst -> lst ++ [thr]) "seaLevels" (g ^. phylo_groupMeta))) b) branches
 446
 447 depthToMeta :: Double -> [[PhyloGroup]] -> [[PhyloGroup]]
 448 depthToMeta depth branches =
 449   let break = length branches > 1
 450    in map (\b ->
 451         map (\g ->
 452           if break then g & phylo_groupMeta .~ (adjust (\lst -> lst ++ [depth]) "breaks"(g ^. phylo_groupMeta))
 453                    else g) b) branches
 454
 455 reduceTupleMapByKeys :: Eq a => [a] -> Map (a,a) Double -> Map (a,a) Double
 456 reduceTupleMapByKeys ks m = filterWithKey (\(k,k') _ -> (elem k ks) && (elem k' ks)) m
 457
 458
 459 getInTupleMap :: Ord a => Map (a,a) Double -> a -> a -> Double
 460 getInTupleMap m k k'
 461   | isJust (m !? ( k ,k')) = m ! ( k ,k')
 462   | isJust (m !? ( k',k )) = m ! ( k',k )
 463   | otherwise = 0
 464
 465
 466 toThreshold :: Double -> Map (PhyloGroupId,PhyloGroupId) Double -> Double
 467 toThreshold lvl proxiGroups =
 468   let idx = ((Map.size proxiGroups) `div` (floor lvl)) - 1
 469    in if idx >= 0
 470         then (sort $ elems proxiGroups) !! idx
 471         else 1
 472
 473
 474 -- done = all the allready broken branches
 475 -- ego  = the current branch we want to break
 476 -- rest = the branches we still have to break
 477 adaptativeBreakBranches :: Proximity -> Double -> Double -> Map (PhyloGroupId,PhyloGroupId) Double
 478                -> Double -> Map Int Double -> Int -> Int -> Map Date Double -> Map Date Cooc
 479                -> [PhyloPeriodId] -> [([PhyloGroup],(Bool,[Double]))] -> ([PhyloGroup],(Bool,[Double])) -> [([PhyloGroup],(Bool,[Double]))]
 480                -> [([PhyloGroup],(Bool,[Double]))]
 481 adaptativeBreakBranches proxiConf depth elevation groupsProxi beta frequency minBranch frame docs coocs periods done ego rest =
 482   -- | 1) keep or not the new division of ego
 483   let done' = done ++ (if (fst . snd) ego
 484                         then (if ((null (fst ego')) || (quality > quality'))
 485                                then
 486                                   [(concat $ thrToMeta thr $ [fst ego],(False, ((snd . snd) ego)))]
 487                                else
 488                                   (  (map (\e -> (e,(True,  ((snd . snd) ego) ++ [thr]))) (fst ego'))
 489                                   ++ (map (\e -> (e,(False, ((snd . snd) ego)))) (snd ego'))))
 490                         else [(concat $ thrToMeta thr $ [fst ego], snd ego)])
 491   in
 492     -- | uncomment let .. in for debugging
 493     -- let part1 = partition (snd) done'
 494     --     part2 = partition (snd) rest
 495     --  in trace ( "[✓ " <> show(length $ fst part1) <> "(" <> show(length $ concat $ map (fst) $ fst part1) <> ")|✗ " <> show(length $ snd part1) <> "(" <> show(length $ concat $ map (fst) $ snd part1) <> ")] "
 496     --          <> "[✓ " <> show(length $ fst part2) <> "(" <> show(length $ concat $ map (fst) $ fst part2) <> ")|✗ " <> show(length $ snd part2) <> "(" <> show(length $ concat $ map (fst) $ snd part2) <> ")]"
 497     --            ) $
 498     -- | 2) if there is no more branches in rest then return else continue
 499     if null rest
 500       then done'
 501       else adaptativeBreakBranches proxiConf depth elevation groupsProxi beta frequency minBranch frame docs coocs periods
 502                        done' (head' "breakBranches" rest) (tail' "breakBranches" rest)
 503   where
 504     --------------------------------------
 505     thr :: Double
 506     thr = toThreshold depth $ Map.filter (\v -> v > (last' "breakBranches" $ (snd . snd) ego)) $ reduceTupleMapByKeys (map getGroupId $ fst ego) groupsProxi
 507     --------------------------------------
 508     quality :: Double
 509     quality = toPhyloQuality beta frequency ((map fst done) ++ [fst ego] ++ (map fst rest))
 510     --------------------------------------
 511     ego' :: ([[PhyloGroup]],[[PhyloGroup]])
 512     ego' =
 513       let branches  = groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
 514                     $ matchGroupsToGroups frame periods proxiConf thr docs coocs (fst ego)
 515           branches' = branches `using` parList rdeepseq
 516        in partition (\b -> (length $ nub $ map _phylo_groupPeriod b) > minBranch)
 517         $ thrToMeta thr
 518         $ depthToMeta (elevation - depth) branches'
 519     --------------------------------------
 520     quality' :: Double
 521     quality' = toPhyloQuality beta frequency
 522                                     ((map fst done) ++ (fst ego') ++ (snd ego') ++ (map fst rest))
 523
 524
 525 adaptativeSeaLevelMatching :: Proximity -> Double -> Double -> Map (PhyloGroupId, PhyloGroupId) Double
 526                   -> Double -> Int -> Map Int Double
 527                   -> Int -> [PhyloPeriodId] -> Map Date Double -> Map Date Cooc
 528                   -> [([PhyloGroup],(Bool,[Double]))] -> [([PhyloGroup],(Bool,[Double]))]
 529 adaptativeSeaLevelMatching proxiConf depth elevation groupsProxi beta minBranch frequency frame periods docs coocs branches =
 530   -- | if there is no branch to break or if seaLvl level >= depth then end
 531   if (Map.null groupsProxi) || (depth <= 0) || ((not . or) $ map (fst . snd) branches)
 532     then branches
 533     else
 534       -- | break all the possible branches at the current seaLvl level
 535       let branches'  = adaptativeBreakBranches proxiConf depth elevation groupsProxi beta frequency minBranch frame docs coocs periods
 536                                       [] (head' "seaLevelMatching" branches) (tail' "seaLevelMatching" branches)
 537           frequency' = reduceFrequency frequency (map fst branches')
 538           groupsProxi' = reduceTupleMapByKeys (map (getGroupId) $ concat $ map (fst) $ filter (fst . snd) branches') groupsProxi
 539           -- thr = toThreshold depth groupsProxi
 540        in trace("\n  " <> foldl (\acc _ -> acc <> "🌊 ") "" [0..(elevation - depth)]
 541                        <> " [✓ " <> show(length $ filter (fst . snd) branches') <> "(" <> show(length $ concat $ map (fst) $ filter (fst . snd) branches')
 542                        <> ")|✗ " <> show(length $ filter (not . fst . snd) branches') <> "(" <> show(length $ concat $ map (fst) $ filter (not . fst . snd) branches') <> ")]"
 543                        <> " thr = ")
 544         $ adaptativeSeaLevelMatching proxiConf (depth - 1) elevation groupsProxi' beta minBranch frequency' frame periods docs coocs branches'
 545
 546
 547 adaptativeTemporalMatching :: Double -> Phylo -> Phylo
 548 adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1
 549                           (fromList $ map (\g -> (getGroupId g,g)) $ traceMatchEnd $ concat branches)
 550                           (toPhyloHorizon phylo)
 551   where
 552     -- | 2) process the temporal matching by elevating seaLvl level
 553     branches :: [[PhyloGroup]]
 554     branches = map fst
 555              $ adaptativeSeaLevelMatching (phyloProximity $ getConfig phylo)
 556                                  (elevation - 1)
 557                                  elevation
 558                                  (phylo ^. phylo_groupsProxi)
 559                                  (_qua_granularity $ phyloQuality $ getConfig phylo)
 560                                  (_qua_minBranch $ phyloQuality $ getConfig phylo)
 561                                  (phylo ^. phylo_termFreq)
 562                                  (getTimeFrame $ timeUnit $ getConfig phylo)
 563                                  (getPeriodIds phylo)
 564                                  (phylo ^. phylo_timeDocs)
 565                                  (phylo ^. phylo_timeCooc)
 566                                  groups
 567     -- | 1) for each group process an initial temporal Matching
 568     -- | here we suppose that all the groups of level 1 are part of the same big branch
 569     groups :: [([PhyloGroup],(Bool,[Double]))]
 570     groups = map (\b -> (b,((length $ nub $ map _phylo_groupPeriod b) >= (_qua_minBranch $ phyloQuality $ getConfig phylo),[thr])))
 571            $ groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
 572            $ matchGroupsToGroups (getTimeFrame $ timeUnit $ getConfig phylo)
 573                          (getPeriodIds phylo) (phyloProximity $ getConfig phylo)
 574                          thr
 575                          (phylo ^. phylo_timeDocs)
 576                          (phylo ^. phylo_timeCooc)
 577                          (traceTemporalMatching $ getGroupsFromLevel 1 phylo)
 578     --------------------------------------
 579     thr :: Double
 580     thr = toThreshold elevation (phylo ^. phylo_groupsProxi)