src/Gargantext/Viz/Phylo/PhyloMaker.hs

   1 {-|
   2 Module      : Gargantext.Viz.Phylo.PhyloMaker
   3 Description : Maker engine for rebuilding 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.PhyloMaker where
  17
  18 import Data.List (concat, nub, partition, sort, (++), group, intersect, null, sortOn, groupBy, tail)
  19 import Data.Map (Map, fromListWith, keys, unionWith, fromList, empty, toList, elems, (!), restrictKeys, foldlWithKey, insert)
  20 import Data.Vector (Vector)
  21
  22 import Gargantext.Prelude
  23 import Gargantext.Viz.AdaptativePhylo
  24 import Gargantext.Viz.Phylo.PhyloTools
  25 import Gargantext.Viz.Phylo.TemporalMatching (adaptativeTemporalMatching, constanteTemporalMatching, getNextPeriods, filterDocs, filterDiago, reduceDiagos, toProximity)
  26 import Gargantext.Viz.Phylo.SynchronicClustering (synchronicClustering)
  27 import Gargantext.Text.Context (TermList)
  28 import Gargantext.Text.Metrics.FrequentItemSet (fisWithSizePolyMap, Size(..))
  29 import Gargantext.Viz.Graph.MaxClique (getMaxCliques)
  30
  31 import Control.DeepSeq (NFData)
  32 import Control.Parallel.Strategies (parList, rdeepseq, using)
  33 import Debug.Trace (trace)
  34 import Control.Lens hiding (Level)
  35
  36 import qualified Data.Vector as Vector
  37 import qualified Data.Set as Set
  38
  39
  40 ------------------
  41 -- | To Phylo | --
  42 ------------------
  43
  44
  45 toPhylo :: [Document] -> TermList -> Config -> Phylo
  46 toPhylo docs lst conf = trace ("# phylo1 groups " <> show(length $ getGroupsFromLevel 1 phylo1))
  47                       $ traceToPhylo (phyloLevel conf) $
  48     if (phyloLevel conf) > 1
  49       then foldl' (\phylo' _ -> synchronicClustering phylo') phylo1 [2..(phyloLevel conf)]
  50       else phylo1
  51     where
  52         --------------------------------------
  53         phylo1 :: Phylo
  54         phylo1 = toPhylo1 docs phyloBase
  55         --------------------------------------
  56         phyloBase :: Phylo
  57         phyloBase = toPhyloBase docs lst conf
  58         --------------------------------------
  59
  60
  61
  62 --------------------
  63 -- | To Phylo 1 | --
  64 --------------------
  65
  66 toGroupsProxi :: Level -> Phylo -> Phylo
  67 toGroupsProxi lvl phylo =
  68   let proximity = phyloProximity $ getConfig phylo
  69       groupsProxi = foldlWithKey (\acc pId pds ->
  70                       -- 1) process period by period
  71                       let egos = map (\g -> (getGroupId g, g ^. phylo_groupNgrams))
  72                                $ elems
  73                                $ view ( phylo_periodLevels
  74                                       . traverse . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
  75                                       . phylo_levelGroups ) pds
  76                           next    = getNextPeriods ToParents (getTimeFrame $ timeUnit $ getConfig phylo) pId (keys $ phylo ^. phylo_periods)
  77                           targets = map (\g ->  (getGroupId g, g ^. phylo_groupNgrams)) $ getGroupsFromLevelPeriods lvl next phylo
  78                           docs    = filterDocs  (phylo ^. phylo_timeDocs) ([pId] ++ next)
  79                           diagos  = filterDiago (phylo ^. phylo_timeCooc) ([pId] ++ next)
  80                           -- 2) compute the pairs in parallel
  81                           pairs  = map (\(id,ngrams) ->
  82                                         map (\(id',ngrams') ->
  83                                             let nbDocs = (sum . elems) $ filterDocs docs    ([idToPrd id, idToPrd id'])
  84                                                 diago  = reduceDiagos  $ filterDiago diagos ([idToPrd id, idToPrd id'])
  85                                              in ((id,id'),toProximity nbDocs diago proximity ngrams ngrams' ngrams')
  86                                         ) $ filter (\(_,ngrams') -> (not . null) $ intersect ngrams ngrams') targets
  87                                  ) egos
  88                           pairs' = pairs `using` parList rdeepseq
  89                        in acc ++ (concat pairs')
  90                     ) [] $ phylo ^. phylo_periods
  91    in phylo & phylo_groupsProxi .~ ((traceGroupsProxi . fromList) groupsProxi)
  92
  93
  94 appendGroups :: (a -> PhyloPeriodId -> Level -> Int -> [Cooc] -> PhyloGroup) -> Level -> Map (Date,Date) [a] -> Phylo -> Phylo
  95 appendGroups f lvl m phylo =  trace ("\n" <> "-- | Append " <> show (length $ concat $ elems m) <> " groups to Level " <> show (lvl) <> "\n")
  96     $ over ( phylo_periods
  97            .  traverse
  98            . phylo_periodLevels
  99            .  traverse)
 100            (\phyloLvl -> if lvl == (phyloLvl ^. phylo_levelLevel)
 101                          then
 102                             let pId = phyloLvl ^. phylo_levelPeriod
 103                                 phyloCUnit = m ! pId
 104                             in  phyloLvl
 105                               & phylo_levelGroups .~ (fromList $ foldl (\groups obj ->
 106                                     groups ++ [ (((pId,lvl),length groups)
 107                                               , f obj pId lvl (length groups)
 108                                                   (elems $ restrictKeys (phylo ^. phylo_timeCooc) $ periodsToYears [pId]))
 109                                               ] ) [] phyloCUnit)
 110                          else
 111                             phyloLvl )
 112            phylo
 113
 114
 115 cliqueToGroup :: PhyloClique -> PhyloPeriodId -> Level ->  Int -> [Cooc] -> PhyloGroup
 116 cliqueToGroup fis pId lvl idx coocs = PhyloGroup pId lvl idx ""
 117                    (fis ^. phyloClique_support)
 118                    (fis ^. phyloClique_nodes)
 119                    (ngramsToCooc (fis ^. phyloClique_nodes) coocs)
 120                    (1,[0]) -- | branchid (lvl,[path in the branching tree])
 121                    (fromList [("breaks",[0]),("seaLevels",[0])])
 122                    [] [] [] []
 123
 124
 125 toPhylo1 :: [Document] -> Phylo -> Phylo
 126 toPhylo1 docs phyloBase = case (getSeaElevation phyloBase) of
 127     Constante start gap -> constanteTemporalMatching  start gap
 128                    $ appendGroups cliqueToGroup 1 phyloClique phyloBase
 129     Adaptative steps    -> adaptativeTemporalMatching steps
 130                    $ toGroupsProxi 1
 131                    $ appendGroups cliqueToGroup 1 phyloClique phyloBase
 132     where
 133         --------------------------------------
 134         phyloClique :: Map (Date,Date) [PhyloClique]
 135         phyloClique =  toPhyloClique phyloBase docs'
 136         --------------------------------------
 137         docs' :: Map (Date,Date) [Document]
 138         docs' =  groupDocsByPeriodRec date (getPeriodIds phyloBase) (sortOn date docs) empty
 139         -- docs' =  groupDocsByPeriod' date (getPeriodIds phyloBase) docs
 140         --------------------------------------
 141
 142
 143 ---------------------------
 144 -- | Frequent Item Set | --
 145 ---------------------------
 146
 147
 148 -- | To apply a filter with the possibility of keeping some periods non empty (keep : True|False)
 149 filterClique :: Bool -> Int -> (Int -> [PhyloClique] -> [PhyloClique]) -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
 150 filterClique keep thr f m = case keep of
 151   False -> map (\l -> f thr l) m
 152   True  -> map (\l -> keepFilled (f) thr l) m
 153
 154
 155 -- | To filter Fis with small Support
 156 filterCliqueBySupport :: Int -> [PhyloClique] -> [PhyloClique]
 157 filterCliqueBySupport thr l = filter (\clq -> (clq ^. phyloClique_support) >= thr) l
 158
 159
 160 -- | To filter Fis with small Clique size
 161 filterCliqueBySize :: Int -> [PhyloClique] -> [PhyloClique]
 162 filterCliqueBySize thr l = filter (\clq -> (length $ clq ^. phyloClique_nodes) >= thr) l
 163
 164
 165 -- | To filter nested Fis
 166 filterCliqueByNested :: Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
 167 filterCliqueByNested m =
 168   let clq  = map (\l ->
 169                 foldl (\mem f -> if (any (\f' -> isNested (f' ^. phyloClique_nodes) (f ^. phyloClique_nodes)) mem)
 170                                  then mem
 171                                  else
 172                                     let fMax = filter (\f' -> not $ isNested (f ^. phyloClique_nodes) (f' ^. phyloClique_nodes)) mem
 173                                     in  fMax ++ [f] ) [] l)
 174            $ elems m
 175       clq' = clq `using` parList rdeepseq
 176   in  fromList $ zip (keys m) clq'
 177
 178
 179 -- | To transform a time map of docs into a time map of Fis with some filters
 180 toPhyloClique :: Phylo -> Map (Date, Date) [Document] -> Map (Date,Date) [PhyloClique]
 181 toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of
 182     Fis s s'    -> -- traceFis "Filtered Fis"
 183                    filterCliqueByNested
 184                   -- $ traceFis "Filtered by clique size"
 185                  $ filterClique True s' (filterCliqueBySize)
 186                  -- $ traceFis "Filtered by support"
 187                  $ filterClique True s (filterCliqueBySupport)
 188                  -- $ traceFis "Unfiltered Fis"
 189                  phyloClique
 190     MaxClique s -> filterClique True s (filterCliqueBySize)
 191                  phyloClique
 192     where
 193         --------------------------------------
 194         phyloClique :: Map (Date,Date) [PhyloClique]
 195         phyloClique = case (clique $ getConfig phylo) of
 196           Fis _ _     ->
 197                       let fis  = map (\(prd,docs) ->
 198                                   let lst = toList $ fisWithSizePolyMap (Segment 1 20) 1 (map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs)
 199                                    in (prd, map (\f -> PhyloClique (Set.toList $ fst f) (snd f) prd) lst))
 200                                $ toList phyloDocs
 201                           fis' = fis `using` parList rdeepseq
 202                        in fromList fis'
 203           MaxClique _ ->
 204                       let mcl  = map (\(prd,docs) ->
 205                                     let cooc = map round
 206                                              $ foldl sumCooc empty
 207                                              $ map listToMatrix
 208                                              $ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs
 209
 210
 211                                      in (prd, map (\cl -> PhyloClique cl 0 prd) $ getMaxCliques 0.001 cooc))
 212
 213                                $ toList phyloDocs
 214                           mcl' = mcl `using` parList rdeepseq
 215                        in fromList mcl'
 216         --------------------------------------
 217
 218         -- dev viz graph maxClique getMaxClique
 219
 220
 221 --------------------
 222 -- | Coocurency | --
 223 --------------------
 224
 225
 226 -- | To transform the docs into a time map of coocurency matrix
 227 docsToTimeScaleCooc :: [Document] -> Vector Ngrams -> Map Date Cooc
 228 docsToTimeScaleCooc docs fdt =
 229     let mCooc  = fromListWith sumCooc
 230                $ map (\(_d,l) -> (_d, listToMatrix l))
 231                $ map (\doc -> (date doc, sort $ ngramsToIdx (text doc) fdt)) docs
 232         mCooc' = fromList
 233                $ map (\t -> (t,empty))
 234                $ toTimeScale (map date docs) 1
 235     in  trace ("\n" <> "-- | Build the coocurency matrix for " <> show (length $ keys mCooc') <> " unit of time" <> "\n")
 236        $ unionWith sumCooc mCooc mCooc'
 237
 238
 239 -----------------------
 240 -- | to Phylo Base | --
 241 -----------------------
 242
 243 groupDocsByPeriodRec :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc] -> Map (date, date) [doc]
 244 groupDocsByPeriodRec f prds docs acc =
 245     if ((null prds) || (null docs))
 246       then acc
 247       else
 248         let prd = head' "groupBy" prds
 249             docs' = partition (\d -> (f d >= fst prd) && (f d <= snd prd)) docs
 250          in groupDocsByPeriodRec f (tail prds) (snd docs') (insert prd (fst docs') acc)
 251
 252
 253 -- | To group a list of Documents by fixed periods
 254 groupDocsByPeriod' :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
 255 groupDocsByPeriod' f pds docs =
 256   let docs'    = groupBy (\d d' -> f d == f d') $ sortOn f docs
 257       periods  = map (inPeriode f docs') pds
 258       periods' = periods `using` parList rdeepseq
 259    in trace ("\n" <> "-- | Group " <> show(length docs) <> " docs by " <> show(length pds) <> " periods" <> "\n")
 260     $ fromList $ zip pds periods'
 261   where
 262     --------------------------------------
 263     inPeriode :: Ord b => (t -> b) -> [[t]] -> (b, b) -> [t]
 264     inPeriode f' h (start,end) =
 265       concat $ fst $ partition (\d -> f' (head' "inPeriode" d) >= start && f' (head' "inPeriode" d) <= end) h
 266
 267
 268
 269 -- | To group a list of Documents by fixed periods
 270 groupDocsByPeriod :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
 271 groupDocsByPeriod _ _   [] = panic "[ERR][Viz.Phylo.PhyloMaker] Empty [Documents] can not have any periods"
 272 groupDocsByPeriod f pds es =
 273   let periods  = map (inPeriode f es) pds
 274       periods' = periods `using` parList rdeepseq
 275
 276   in  trace ("\n" <> "-- | Group " <> show(length es) <> " docs by " <> show(length pds) <> " periods" <> "\n")
 277     $ fromList $ zip pds periods'
 278   where
 279     --------------------------------------
 280     inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
 281     inPeriode f' h (start,end) =
 282       fst $ partition (\d -> f' d >= start && f' d <= end) h
 283     --------------------------------------
 284
 285
 286 docsToTermFreq :: [Document] -> Vector Ngrams -> Map Int Double
 287 docsToTermFreq docs fdt =
 288   let nbDocs = fromIntegral $ length docs
 289       freqs = map (/(nbDocs))
 290              $ fromList
 291              $ map (\lst -> (head' "docsToTermFreq" lst, fromIntegral $ length lst))
 292              $ group $ sort $ concat $ map (\d -> nub $ ngramsToIdx (text d) fdt) docs
 293       sumFreqs = sum $ elems freqs
 294    in map (/sumFreqs) freqs
 295
 296
 297 -- | To count the number of docs by unit of time
 298 docsToTimeScaleNb :: [Document] -> Map Date Double
 299 docsToTimeScaleNb docs =
 300     let docs' = fromListWith (+) $ map (\d -> (date d,1)) docs
 301         time  = fromList $ map (\t -> (t,0)) $ toTimeScale (keys docs') 1
 302     in  trace ("\n" <> "-- | Group " <> show(length docs) <> " docs by " <> show(length time) <> " unit of time" <> "\n")
 303       $ unionWith (+) time docs'
 304
 305
 306 initPhyloLevels :: Int -> PhyloPeriodId -> Map PhyloLevelId PhyloLevel
 307 initPhyloLevels lvlMax pId =
 308     fromList $ map (\lvl -> ((pId,lvl),PhyloLevel pId lvl empty)) [1..lvlMax]
 309
 310
 311 -- | To init the basic elements of a Phylo
 312 toPhyloBase :: [Document] -> TermList -> Config -> Phylo
 313 toPhyloBase docs lst conf =
 314     let foundations  = PhyloFoundations (Vector.fromList $ nub $ concat $ map text docs) lst
 315         params = defaultPhyloParam { _phyloParam_config = conf }
 316         periods = toPeriods (sort $ nub $ map date docs) (getTimePeriod $ timeUnit conf) (getTimeStep $ timeUnit conf)
 317     in trace ("\n" <> "-- | Create PhyloBase out of " <> show(length docs) <> " docs \n")
 318        $ Phylo foundations
 319                (docsToTimeScaleCooc docs (foundations ^. foundations_roots))
 320                (docsToTimeScaleNb docs)
 321                (docsToTermFreq docs (foundations ^. foundations_roots))
 322                empty
 323                empty
 324                params
 325                (fromList $ map (\prd -> (prd, PhyloPeriod prd (initPhyloLevels 1 prd))) periods)