src/Gargantext/Viz/Phylo/LinkMaker.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.Tools
   3 Description : Phylomemy Tools to build/manage it
   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 -}
  12
  13 {-# LANGUAGE NoImplicitPrelude #-}
  14 {-# LANGUAGE FlexibleContexts  #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16
  17 module Gargantext.Viz.Phylo.LinkMaker
  18   where
  19
  20 import Control.Parallel.Strategies
  21 import Control.Lens                 hiding (both, Level)
  22 import Data.List                    ((++), sortOn, null, tail, splitAt, elem, concat, delete, intersect, elemIndex, groupBy, union, inits, scanl, find)
  23 import Data.Tuple.Extra
  24 import Data.Map                     (Map, (!), fromListWith, elems, restrictKeys, filterWithKey, keys, unionWith, unions, intersectionWith, member, fromList)
  25 import Gargantext.Prelude
  26 import Gargantext.Viz.Phylo
  27 import Gargantext.Viz.Phylo.Tools
  28 import Gargantext.Viz.Phylo.Metrics
  29 import qualified Data.List  as List
  30 import qualified Data.Maybe as Maybe
  31 import qualified Data.Map as Map
  32
  33 import qualified Data.Vector.Storable as VS
  34 import Debug.Trace (trace)
  35 import Numeric.Statistics (percentile)
  36
  37 -----------------------------
  38 -- | From Level to level | --
  39 -----------------------------
  40
  41
  42 -- | To set the LevelLinks between a given PhyloGroup and a list of childs/parents PhyloGroups
  43 linkGroupToGroups :: PhyloGroup -> [PhyloGroup] -> PhyloGroup
  44 linkGroupToGroups current targets = over (phylo_groupLevelParents) addPointers current
  45   where
  46     --------------------------------------
  47     addPointers :: [Pointer] -> [Pointer]
  48     addPointers lp = lp ++ Maybe.mapMaybe (\target ->
  49                                             if (elem (getGroupId current) (getGroupLevelChildsId target))
  50                                             then Just ((getGroupId target),1)
  51                                             else Nothing) targets
  52     --------------------------------------
  53
  54
  55 setLevelLinks :: (Level,Level) -> Phylo -> Phylo
  56 setLevelLinks (lvl,lvl') p = alterGroupWithLevel (\group -> linkGroupToGroups group
  57                                                            $ filter (\g' -> (not . null) $ intersect (getGroupNgrams group) (getGroupNgrams g'))
  58                                                            $ getGroupsWithFilters lvl' (getGroupPeriod group) p) lvl p
  59
  60
  61 -------------------------------
  62 -- | From Period to Period | --
  63 -------------------------------
  64
  65
  66 -- | To get the next or previous PhyloPeriod based on a given PhyloPeriodId
  67 getNextPeriods :: Filiation -> Int -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
  68 getNextPeriods to' limit id l = case to' of
  69     Descendant -> take limit $ (tail . snd) next
  70     Ascendant  -> take limit $ (reverse . fst) next
  71     _          -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] Filiation type not defined")
  72     where
  73       --------------------------------------
  74       next :: ([PhyloPeriodId], [PhyloPeriodId])
  75       next = splitAt idx l
  76       --------------------------------------
  77       idx :: Int
  78       idx = case (List.elemIndex id l) of
  79         Nothing -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PhyloPeriodId not defined")
  80         Just i  -> i
  81       --------------------------------------
  82
  83
  84 -- | To get the number of docs produced during a list of periods
  85 periodsToNbDocs :: [PhyloPeriodId] -> Phylo -> Double
  86 periodsToNbDocs prds phylo = sum $ elems
  87                            $ restrictKeys (phylo ^. phylo_docsByYears)
  88                            $ periodsToYears prds
  89
  90
  91 -- | To process a given Proximity
  92 processProximity :: Proximity -> Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> [Int] -> [Int] -> Double
  93 processProximity proximity nbDocs cooc cooc' ngrams ngrams' = case proximity of
  94   WeightedLogJaccard (WLJParams _ sens) -> weightedLogJaccard sens nbDocs cooc cooc' ngrams ngrams'
  95   Hamming (HammingParams _)             -> hamming cooc cooc'
  96   _                                     -> panic "[ERR][Viz.Phylo.LinkMaker.processProximity] Unknown proximity"
  97
  98
  99 filterProximity :: Double -> Proximity -> Bool
 100 filterProximity score prox =  case prox of
 101   WeightedLogJaccard (WLJParams thr _)   -> score >= thr
 102   Hamming (HammingParams thr)            -> score <= thr
 103   _                                      -> panic "[ERR][Viz.Phylo.LinkMaker.filterProximity] Unknown proximity"
 104
 105
 106 makePairs :: [(Date,Date)] -> PhyloGroup -> Phylo -> [(PhyloGroup,PhyloGroup)]
 107 makePairs prds g p = filter (\pair -> ((last' "makePairs" prds) == (getGroupPeriod $ fst pair))
 108                                     || ((last' "makePairs" prds) == (getGroupPeriod $ snd pair)))
 109                     $ listToPairs
 110                     $ filter (\g' -> (elem (getGroupPeriod g') prds)
 111                                  && ((not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g'))
 112                                  && (((last' "makePairs" prds) == (getGroupPeriod g))
 113                                      ||((matchWithPairs g (g,g') p) >= (getPhyloMatchingFrameTh p))))
 114                     $ getGroupsWithLevel (getGroupLevel g) p
 115
 116 matchWithPairs :: PhyloGroup -> (PhyloGroup,PhyloGroup) -> Phylo -> Double
 117 matchWithPairs g1 (g2,g3) p =
 118   let nbDocs = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] p
 119       cooc   = if (g2 == g3)
 120                 then getGroupCooc g2
 121                 else unionWith (+) (getGroupCooc g2) (getGroupCooc g3)
 122       ngrams = if (g2 == g3)
 123                 then getGroupNgrams g2
 124                 else union (getGroupNgrams g2) (getGroupNgrams g3)
 125   in processProximity (getPhyloProximity p) nbDocs (getGroupCooc g1) cooc (getGroupNgrams g1) ngrams
 126
 127
 128 phyloGroupMatching :: [PhyloPeriodId] -> PhyloGroup -> Phylo -> [Pointer]
 129 phyloGroupMatching periods g p = case pointers of
 130   Nothing  -> []
 131   Just pts -> head' "phyloGroupMatching"
 132             -- | Keep only the best set of pointers grouped by proximity
 133             $ groupBy (\pt pt' -> snd pt == snd pt')
 134             $ reverse $ sortOn snd pts
 135             -- | Find the first time frame where at leats one pointer satisfies the proximity threshold
 136   where
 137     --------------------------------------
 138     pointers :: Maybe [Pointer]
 139     pointers = find (not . null)
 140              -- | For each time frame, process the Proximity on relevant pairs of targeted groups
 141              $ scanl (\acc frame ->
 142                  let pairs = makePairs frame g p
 143                  in  acc ++ ( filter (\(_,proxi) -> filterProximity proxi (getPhyloProximity p))
 144                             $ concat
 145                             $ map (\(t,t') ->
 146                                 let proxi = matchWithPairs g (t,t') p
 147                                 in
 148                                   if (t == t')
 149                                     then [(getGroupId t,proxi)]
 150                                     else [(getGroupId t,proxi),(getGroupId t',proxi)] ) pairs ) ) []
 151              -- | [[1900],[1900,1901],[1900,1901,1902],...] | length max => + 5 years
 152              $ inits periods
 153     --------------------------------------
 154
 155
 156 -- | To add some Pointer to a PhyloGroup
 157 addPointers' :: Filiation -> [Pointer] -> PhyloGroup -> PhyloGroup
 158 addPointers' fil pts g = g & case fil of
 159    Descendant -> phylo_groupPeriodChilds  %~ (++ pts)
 160    Ascendant  -> phylo_groupPeriodParents %~ (++ pts)
 161    _          -> panic ("[ERR][Viz.Phylo.LinkMaker.addPointers] Wrong type of filiation")
 162
 163
 164
 165 -- | To update a list of phyloGroups with some Pointers
 166 updateGroups :: Filiation -> Level -> Map PhyloGroupId [Pointer] -> Phylo -> Phylo
 167 updateGroups fil lvl m p = alterPhyloGroups (\gs -> map (\g -> if ((getGroupLevel g) == lvl) && (member (getGroupId g) m)
 168                                                                then addPointers' fil (m ! (getGroupId g)) g
 169                                                                else g ) gs) p
 170
 171
 172
 173 -- | Optimisation : to keep only the groups that have at least one ngrams in commons with the target
 174 initCandidates :: PhyloGroup -> [PhyloPeriodId] -> [PhyloGroup] -> [PhyloGroup]
 175 initCandidates g prds gs = filter (\g' -> elem (getGroupPeriod g') prds)
 176                            $ filter (\g' -> (not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g'))
 177                            $ delete g gs
 178
 179
 180 -- | a init avec la [[head groups]] et la tail groups
 181 toBranches :: [[PhyloGroup]] -> [PhyloGroup] -> [[PhyloGroup]]
 182 toBranches mem gs
 183   | null gs = mem
 184   | otherwise = toBranches mem' $ tail gs
 185   where
 186     --------------------------------------
 187     mem' :: [[PhyloGroup]]
 188     mem' = if (null withHead)
 189            then mem ++ [[head' "toBranches" gs]]
 190            else (filter (\gs' -> not $ elem gs' withHead) mem)
 191                 ++
 192                 [(concat withHead) ++ [head' "toBranches" gs]]
 193     --------------------------------------
 194     withHead :: [[PhyloGroup]]
 195     withHead = filter (\gs' -> (not . null)
 196                              $ intersect (concat $ map getGroupNgrams gs')
 197                                          (getGroupNgrams $ (head' "toBranches" gs))
 198                       ) mem
 199     --------------------------------------
 200
 201
 202 -- | To process an intertemporal matching task to a Phylo at a given level
 203 -- | 1) split all groups (of the level) in branches (ie:related components sharing at least one ngram)
 204 -- | 2) for each branch, for each group find the best candidates (by Filiation and Proximity) and create the corresponding pointers
 205 -- | 3) update all the groups with the new pointers if they exist
 206 interTempoMatching :: Filiation -> Level -> Proximity -> Phylo -> Phylo
 207 interTempoMatching fil lvl _ p = updateGroups fil lvl (Map.fromList pointers) p
 208   where
 209     --------------------------------------
 210     pointers :: [(PhyloGroupId,[Pointer])]
 211     pointers =
 212       let  pts  = map (\g -> let periods = getNextPeriods fil (getPhyloMatchingFrame p) (getGroupPeriod g) (getPhyloPeriods p)
 213                              in  (getGroupId g, phyloGroupMatching periods g p)) groups
 214            pts' = pts `using` parList rdeepseq
 215        in  pts'
 216     --------------------------------------
 217     groups :: [PhyloGroup]
 218     groups = getGroupsWithLevel lvl p
 219     --------------------------------------
 220
 221
 222 ------------------------------------------------------------------------
 223 -- | Make links from Period to Period after level 1
 224
 225
 226 listToTuple :: (a -> b) -> [a] -> [(b,a)]
 227 listToTuple f l = map (\x -> (f x, x)) l
 228
 229
 230 groupsToMaps :: Ord b => (PhyloGroup -> b) -> [PhyloGroup] -> [Map PhyloGroupId PhyloGroup]
 231 groupsToMaps f gs = map (\gs' -> fromList $ listToTuple getGroupId gs')
 232                   $ groupBy ((==) `on` f)
 233                   $ sortOn f gs
 234
 235
 236 phyloToPeriodMaps :: Level -> Filiation -> Phylo -> [Map PhyloGroupId PhyloGroup]
 237 phyloToPeriodMaps lvl fil p =
 238   let prdMap = groupsToMaps (fst . getGroupPeriod) (getGroupsWithLevel lvl p)
 239   in case fil of
 240     Ascendant  -> reverse prdMap
 241     Descendant -> prdMap
 242     _          -> panic ("[ERR][Viz.Phylo.LinkMaker.phyloToPeriodMaps] Wrong type of filiation")
 243
 244
 245 trackPointersRec :: Filiation -> Map PhyloGroupId PhyloGroup -> [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
 246 trackPointersRec fil m gs res =
 247   if (null gs) then res
 248   else if (Map.null m) then res ++ gs
 249   else
 250     let g = head' "track" gs
 251         pts  = Map.fromList $ getGroupPointers PeriodEdge fil g
 252         pts' = Map.toList $ fromListWith (\w w' -> max w w') $ concat $ elems
 253              $ intersectionWith (\w g' -> map (\(id,_w') -> (id, w))
 254                                         $ getGroupPointers LevelEdge Ascendant g') pts m
 255         res' = res ++ [case fil of
 256                         Ascendant  -> g & phylo_groupPeriodParents .~ pts'
 257                         Descendant -> g & phylo_groupPeriodChilds  .~ pts'
 258                         _          -> panic ("[ERR][Viz.Phylo.LinkMaker.transposeLinks] Wrong type of filiation")]
 259     in trackPointersRec fil (filterWithKey (\k _ -> not $ elem k (keys pts)) m) (tail' "track" gs) res'
 260
 261
 262
 263 transposeLinks :: Level -> Filiation -> Phylo -> Phylo
 264 transposeLinks lvl fil p =
 265   let prdMap = zip (phyloToPeriodMaps (lvl - 1) fil p) (phyloToPeriodMaps lvl fil p)
 266       transposed =  map (\(gs,gs') ->
 267                             let idx  = fromJust $ elemIndex (gs,gs') prdMap
 268                                 next = take (getPhyloMatchingFrame p) $ snd $ splitAt (idx + 1) prdMap
 269                                 groups = trackPointersRec fil (unions $ map fst next) (elems gs') []
 270                             in  (getGroupPeriod $ head' "transpose" groups ,groups)
 271                          ) prdMap
 272       transposed' = Map.fromList $ (transposed `using` parList rdeepseq)
 273   in alterPhyloGroups
 274       (\gs -> if ((not . null) gs) && (lvl == (getGroupLevel $ head' "transpose" gs))
 275               then transposed' ! (getGroupPeriod $ head' "transpose" gs)
 276               else gs
 277       ) p
 278
 279
 280
 281 -- | Transpose the parent/child pointers from one level to another
 282 transposePeriodLinks :: Level -> Phylo -> Phylo
 283 transposePeriodLinks lvl p = alterPhyloGroups
 284   (\gs -> if ((not . null) gs) && (elem lvl $ map getGroupLevel gs)
 285               then
 286                 let groups  = map (\g -> let m = reduceGroups g lvlGroups
 287                                          in  g & phylo_groupPeriodParents .~ (trackPointers m $ g ^. phylo_groupPeriodParents)
 288                                                & phylo_groupPeriodChilds  .~ (trackPointers m $ g ^. phylo_groupPeriodChilds )) gs
 289                     groups' = groups `using` parList rdeepseq
 290                     in groups'
 291               else gs
 292   ) p
 293   where
 294     --------------------------------------
 295     -- | find an other way to find the group from the id
 296     trackPointers :: Map PhyloGroupId PhyloGroup -> [Pointer] -> [Pointer]
 297     trackPointers m pts = Map.toList
 298                         $ fromListWith (\w w' -> max w w')
 299                         $ map (\(id,_w) -> (getGroupLevelParentId $ m ! id,_w)) pts
 300     --------------------------------------
 301     reduceGroups :: PhyloGroup -> [PhyloGroup] -> Map PhyloGroupId PhyloGroup
 302     reduceGroups g gs = Map.fromList
 303                      $ map (\g' -> (getGroupId g',g'))
 304                      $ filter (\g' -> ((not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g'))) gs
 305     --------------------------------------
 306     lvlGroups :: [PhyloGroup]
 307     lvlGroups = getGroupsWithLevel (lvl - 1) p
 308     --------------------------------------
 309
 310
 311 ----------------
 312 -- | Tracer | --
 313 ----------------
 314
 315 traceMatching :: Filiation -> Level -> Double -> [Double] -> Phylo -> Phylo
 316 traceMatching fil lvl thr lst p = trace ( "----\n" <> show (fil) <> " unfiltered temporal Matching in Phylo" <> show (lvl) <> " :\n"
 317                                       <> "count : " <> show (length lst) <> " potential pointers (" <> show (length $ filter (>= thr) lst) <> " >= " <> show (thr) <> ")\n"
 318                                       <> "similarity : " <> show (percentile 25 (VS.fromList lst)) <> " (25%) "
 319                                                          <> show (percentile 50 (VS.fromList lst)) <> " (50%) "
 320                                                          <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
 321                                                          <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") p
 322
 323
 324 tracePreBranches :: [[PhyloGroup]] -> [[PhyloGroup]]
 325 tracePreBranches bs = trace (show (length bs) <> " pre-branches" <> "\n"
 326                              <> "with sizes : " <> show (map length bs) <> "\n") bs
 327