src/Gargantext/Viz/Phylo/LevelMaker.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 FlexibleContexts     #-}
  14 {-# LANGUAGE FlexibleInstances    #-}
  15 {-# LANGUAGE NoImplicitPrelude    #-}
  16 {-# LANGUAGE OverloadedStrings    #-}
  17 {-# LANGUAGE TypeSynonymInstances #-}
  18
  19 module Gargantext.Viz.Phylo.LevelMaker
  20   where
  21
  22 import Control.Lens                 hiding (both, Level)
  23 import Data.List                    ((++), sort, concat, nub, zip, head, last)
  24 import Data.Map                     (Map, (!), empty, restrictKeys, filterWithKey, singleton, union)
  25 import Data.Text                    (Text)
  26 import Data.Tuple.Extra
  27 import Gargantext.Prelude                   hiding (head)
  28 import Gargantext.Viz.Phylo
  29 import Gargantext.Viz.Phylo.Aggregates.Cluster
  30 import Gargantext.Viz.Phylo.Aggregates.Cooc
  31 import Gargantext.Viz.Phylo.Aggregates.Document
  32 import Gargantext.Viz.Phylo.BranchMaker
  33 import Gargantext.Viz.Phylo.LinkMaker
  34 import Gargantext.Viz.Phylo.Tools
  35 import qualified Data.Set    as Set
  36 import qualified Data.Text   as Text
  37
  38
  39 -- | A typeClass for polymorphic PhyloLevel functions
  40 class PhyloLevelMaker aggregate
  41     where
  42         -- | To add a new Level of PhyloGroups to a Phylo based on a list of Aggregates
  43         addPhyloLevel :: Level -> Map (Date,Date) [aggregate] -> Phylo -> Phylo
  44         -- | To create a list of PhyloGroups based on a list of aggregates a
  45         toPhyloGroups :: Level -> (Date,Date)  -> [aggregate] -> Map (Date,Date) [aggregate] -> Phylo -> [PhyloGroup]
  46
  47
  48 instance PhyloLevelMaker Cluster
  49   where
  50     --------------------------------------
  51     -- | Level -> Map (Date,Date) [Cluster] -> Phylo -> Phylo
  52     addPhyloLevel lvl m p
  53       | lvl > 1   = toPhyloLevel lvl m p
  54       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Clusters at level < 2")
  55     --------------------------------------
  56     -- | Level -> (Date,Date) -> [Cluster] -> Map (Date,Date) [Cluster] -> Phylo -> [PhyloGroup]
  57     toPhyloGroups lvl (d,d') l m p = map (\(idx,cluster) -> clusterToGroup (d,d') lvl idx "" cluster m p) $ zip [1..] l
  58     --------------------------------------
  59
  60
  61 instance PhyloLevelMaker Fis
  62   where
  63     --------------------------------------
  64     -- | Level -> Map (Date,Date) [Fis] -> Phylo -> Phylo
  65     addPhyloLevel lvl m p
  66       | lvl == 1  = toPhyloLevel lvl m p
  67       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Fis at level <> 1")
  68     --------------------------------------
  69     -- | Level -> (Date,Date) -> [Fis] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
  70     toPhyloGroups lvl (d,d') l m p = map (\(idx,fis) -> cliqueToGroup (d,d') lvl idx "" fis m p) $ zip [1..] l
  71     --------------------------------------
  72
  73
  74 instance PhyloLevelMaker Document
  75   where
  76     --------------------------------------
  77     -- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo
  78     addPhyloLevel lvl m p
  79       | lvl == 0  = toPhyloLevel lvl m p
  80       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> 0")
  81     --------------------------------------
  82     -- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
  83     toPhyloGroups lvl (d,d') l _m p = map (\(idx,ngram) -> ngramsToGroup (d,d') lvl idx ngram [ngram] p)
  84                                           $ zip [1..]
  85                                           $ (nub . concat)
  86                                           $ map (Text.words . text) l
  87     --------------------------------------
  88
  89
  90 -- | To transform a Cluster into a Phylogroup
  91 clusterToGroup :: PhyloPeriodId -> Level -> Int -> Text -> Cluster -> Map (Date,Date) [Cluster] -> Phylo -> PhyloGroup
  92 clusterToGroup prd lvl idx lbl groups _m p =
  93     PhyloGroup ((prd, lvl), idx) lbl ngrams empty cooc Nothing [] [] [] (map (\g -> (getGroupId g, 1)) groups)
  94       where
  95         --------------------------------------
  96         ngrams :: [Int]
  97         ngrams = (sort . nub . concat) $ map getGroupNgrams groups
  98         --------------------------------------
  99         cooc :: Map (Int, Int) Double
 100         cooc = filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
 101               $ foldl union empty
 102               $ map getGroupCooc
 103               $ getGroupsWithFilters 1 prd p
 104         --------------------------------------
 105
 106
 107 -- | To transform a Clique into a PhyloGroup
 108 cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> (Clique,Support) -> Map (Date, Date) [Fis] -> Phylo -> PhyloGroup
 109 cliqueToGroup prd lvl idx lbl fis m p =
 110     PhyloGroup ((prd, lvl), idx) lbl ngrams (singleton "support" (fromIntegral $ snd fis)) cooc Nothing [] [] [] []
 111       where
 112         --------------------------------------
 113         ngrams :: [Int]
 114         ngrams = sort $ map (\x -> getIdxInFoundations x p)
 115                       $ Set.toList
 116                       $ fst fis
 117         --------------------------------------
 118         cooc :: Map (Int, Int) Double
 119         cooc =  filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
 120                                      $ fisToCooc (restrictKeys m $ Set.fromList [prd]) p
 121         --------------------------------------
 122
 123
 124 -- | To transform a list of Ngrams into a PhyloGroup
 125 ngramsToGroup ::  PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
 126 ngramsToGroup prd lvl idx lbl ngrams p =
 127     PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInFoundations x p) ngrams) empty empty Nothing [] [] [] []
 128
 129
 130 -- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
 131 toPhyloLevel :: PhyloLevelMaker a => Level -> Map (Date, Date) [a] -> Phylo -> Phylo
 132 toPhyloLevel lvl m p = alterPhyloPeriods
 133                         (\period -> let pId = _phylo_periodId period
 134                                     in  over (phylo_periodLevels)
 135                                         (\phyloLevels ->
 136                                           let groups = toPhyloGroups lvl pId (m ! pId) m p
 137                                           in  phyloLevels ++ [PhyloLevel (pId, lvl) groups]
 138                                         ) period) p
 139
 140
 141 initPhylo :: Grain -> Step -> [(Date,Text)] -> [Ngrams] -> (Ngrams -> Ngrams) -> Phylo
 142 initPhylo g s c a f = addPhyloLevel 0 (corpusToDocs f c base) base
 143   where
 144     --------------------------------------
 145     base :: Phylo
 146     base = initPhyloBase (initPeriods g s $ both fst (head c,last c)) (initFoundations a)
 147     --------------------------------------
 148
 149
 150 -- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
 151 toNthLevel :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> (Proximity,[Double]) -> Phylo -> Phylo
 152 toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3) p
 153   | lvl >= lvlMax = p
 154   | otherwise     = toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3)
 155                   $ setPhyloBranches (lvl + 1)
 156                   $ interTempoMatching Childs  (lvl + 1) (prox',param3)
 157                   $ interTempoMatching Parents (lvl + 1) (prox',param3)
 158                   $ setLevelLinks (lvl, lvl + 1)
 159                   $ addPhyloLevel (lvl + 1)
 160                     (phyloToClusters lvl (prox,param1) (clus,param2) p) p
 161   where
 162     --------------------------------------
 163     lvl :: Level
 164     lvl = getLastLevel p
 165     --------------------------------------