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 NoImplicitPrelude #-}
  14 {-# LANGUAGE FlexibleContexts  #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16
  17 module Gargantext.Viz.Phylo.LevelMaker
  18   where
  19
  20 import Control.Lens                 hiding (both, Level)
  21 import Data.List                    ((++), sort, concat, nub, words, zip, head, last)
  22 import Data.Map                     (Map, (!), empty, restrictKeys, filterWithKey, singleton, union)
  23 import Data.Set                     (Set)
  24 import Data.Text                    (Text, words)
  25 import Data.Tuple.Extra
  26 import Data.Vector                  (Vector)
  27
  28 import Gargantext.Prelude                   hiding (head)
  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.Aggregates.Fis
  33 import Gargantext.Viz.Phylo
  34 import Gargantext.Viz.Phylo.Tools
  35 import Gargantext.Viz.Phylo.LinkMaker
  36 import Gargantext.Viz.Phylo.BranchMaker
  37
  38 import qualified Data.List   as List
  39 import qualified Data.Map    as Map
  40 import qualified Data.Set    as Set
  41 import qualified Data.Text   as Text
  42 import qualified Data.Vector as Vector
  43
  44
  45 -- | A typeClass for polymorphic PhyloLevel functions
  46 class PhyloLevelMaker aggregate
  47     where
  48         -- | To add a new Level of PhyloGroups to a Phylo based on a list of Aggregates
  49         addPhyloLevel :: Level -> Map (Date,Date) [aggregate] -> Phylo -> Phylo
  50         -- | To create a list of PhyloGroups based on a list of aggregates a
  51         toPhyloGroups :: Level -> (Date,Date)  -> [aggregate] -> Map (Date,Date) [aggregate] -> Phylo -> [PhyloGroup]
  52
  53
  54 instance PhyloLevelMaker Cluster
  55   where
  56     --------------------------------------
  57     -- | Level -> Map (Date,Date) [Cluster] -> Phylo -> Phylo
  58     addPhyloLevel lvl m p
  59       | lvl > 1   = toPhyloLevel lvl m p
  60       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Clusters at level < 2")
  61     --------------------------------------
  62     -- | Level -> (Date,Date) -> [Cluster] -> Map (Date,Date) [Cluster] -> Phylo -> [PhyloGroup]
  63     toPhyloGroups lvl (d,d') l m p = map (\(idx,cluster) -> clusterToGroup (d,d') lvl idx "" cluster m p) $ zip [1..] l
  64     --------------------------------------
  65
  66
  67 instance PhyloLevelMaker Fis
  68   where
  69     --------------------------------------
  70     -- | Level -> Map (Date,Date) [Fis] -> Phylo -> Phylo
  71     addPhyloLevel lvl m p
  72       | lvl == 1  = toPhyloLevel lvl m p
  73       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Fis at level <> 1")
  74     --------------------------------------
  75     -- | Level -> (Date,Date) -> [Fis] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
  76     toPhyloGroups lvl (d,d') l m p = map (\(idx,fis) -> cliqueToGroup (d,d') lvl idx "" fis m p) $ zip [1..] l
  77     --------------------------------------
  78
  79
  80 instance PhyloLevelMaker Document
  81   where
  82     --------------------------------------
  83     -- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo
  84     addPhyloLevel lvl m p
  85       | lvl == 0  = toPhyloLevel lvl m p
  86       | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> 0")
  87     --------------------------------------
  88     -- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
  89     toPhyloGroups lvl (d,d') l m p = map (\(idx,ngram) -> ngramsToGroup (d,d') lvl idx ngram [ngram] p)
  90                                           $ zip [1..]
  91                                           $ (nub . concat)
  92                                           $ map (Text.words . text) l
  93     --------------------------------------
  94
  95
  96 -- | To transform a Cluster into a Phylogroup
  97 clusterToGroup :: PhyloPeriodId -> Level -> Int -> Text -> Cluster -> Map (Date,Date) [Cluster] -> Phylo -> PhyloGroup
  98 clusterToGroup prd lvl idx lbl groups m p =
  99     PhyloGroup ((prd, lvl), idx) lbl ngrams empty cooc Nothing [] [] [] (map (\g -> (getGroupId g, 1)) groups)
 100       where
 101         --------------------------------------
 102         ngrams :: [Int]
 103         ngrams = (sort . nub . concat) $ map getGroupNgrams groups
 104         --------------------------------------
 105         cooc :: Map (Int, Int) Double
 106         cooc = filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
 107               $ foldl union empty
 108               $ map getGroupCooc
 109               $ getGroupsWithFilters 1 prd p
 110         --------------------------------------
 111
 112
 113 -- | To transform a Clique into a PhyloGroup
 114 cliqueToGroup :: PhyloPeriodId -> Level -> Int -> Text -> (Clique,Support) -> Map (Date, Date) [Fis] -> Phylo -> PhyloGroup
 115 cliqueToGroup prd lvl idx lbl fis m p =
 116     PhyloGroup ((prd, lvl), idx) lbl ngrams (singleton "support" (fromIntegral $ snd fis)) cooc Nothing [] [] [] []
 117       where
 118         --------------------------------------
 119         ngrams :: [Int]
 120         ngrams = sort $ map (\x -> getIdxInFoundations x p)
 121                       $ Set.toList
 122                       $ fst fis
 123         --------------------------------------
 124         cooc :: Map (Int, Int) Double
 125         cooc =  filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams)
 126                                      $ fisToCooc (restrictKeys m $ Set.fromList [prd]) p
 127         --------------------------------------
 128
 129
 130 -- | To transform a list of Ngrams into a PhyloGroup
 131 ngramsToGroup ::  PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
 132 ngramsToGroup prd lvl idx lbl ngrams p =
 133     PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInFoundations x p) ngrams) empty empty Nothing [] [] [] []
 134
 135
 136 -- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
 137 toPhyloLevel :: PhyloLevelMaker a => Level -> Map (Date, Date) [a] -> Phylo -> Phylo
 138 toPhyloLevel lvl m p = alterPhyloPeriods
 139                         (\period -> let pId = _phylo_periodId period
 140                                     in  over (phylo_periodLevels)
 141                                         (\phyloLevels ->
 142                                           let groups = toPhyloGroups lvl pId (m ! pId) m p
 143                                           in  phyloLevels ++ [PhyloLevel (pId, lvl) groups]
 144                                         ) period) p
 145
 146
 147 -- | To init a Phylo
 148 initPhylo :: Grain -> Step -> [(Date,Text)] -> [Ngrams] -> (Ngrams -> Ngrams) -> Phylo
 149 initPhylo g s c a f = addPhyloLevel 0 (corpusToDocs f c base) base
 150   where
 151     --------------------------------------
 152     base :: Phylo
 153     base = initPhyloBase (initPeriods g s $ both fst (head c,last c)) (initFoundations a)
 154     --------------------------------------
 155
 156
 157 -- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
 158 toNthLevel :: Level -> QueryProximity -> QueryClustering -> Phylo -> Phylo
 159 toNthLevel lvlMax prox clus p
 160   | lvl >= lvlMax = p
 161   | otherwise     = toNthLevel lvlMax prox clus
 162                   $ setPhyloBranches (lvl + 1)
 163                   $ interTempoMatching Descendant  (lvl + 1) prox
 164                   $ interTempoMatching Ascendant (lvl + 1) prox
 165                   $ setLevelLinks (lvl, lvl + 1)
 166                   $ addPhyloLevel (lvl + 1)
 167                     (phyloToClusters lvl (fromJust $ clus ^. qc_proximity) clus p) p
 168   where
 169     --------------------------------------
 170     lvl :: Level
 171     lvl = getLastLevel p
 172     --------------------------------------
 173
 174
 175 -- | To reconstruct the Level 1 of a Phylo based on a Clustering Methods
 176 toPhylo1 :: QueryClustering -> QueryProximity -> Map (Date, Date) [Document] -> Phylo -> Phylo
 177 toPhylo1 clst proxy d p = case getClusterName clst of
 178                 FrequentItemSet -> setPhyloBranches 1
 179                                  $ interTempoMatching Descendant 1 proxy
 180                                  $ interTempoMatching Ascendant 1 proxy
 181                                  $ setLevelLinks (0,1)
 182                                  $ setLevelLinks (1,0)
 183                                  $ addPhyloLevel 1 phyloFis p
 184                   where
 185                     --------------------------------------
 186                     phyloFis :: Map (Date, Date) [Fis]
 187                     phyloFis = filterFisBySupport (getClusterPBool clst "emptyFis") (round $ getClusterPNum clst "supportInf") (filterFisByNested (docsToFis d))
 188                     --------------------------------------
 189
 190                 _               -> panic "[ERR][Viz.Phylo.PhyloMaker.toPhylo1] fst clustering not recognized"
 191
 192
 193 -- | To reconstruct the Level 0 of a Phylo
 194 toPhylo0 :: Map (Date, Date) [Document] -> Phylo -> Phylo
 195 toPhylo0 d p = addPhyloLevel 0 d p
 196
 197
 198 -- | To reconstruct the Base of a Phylo
 199 toPhyloBase :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo
 200 toPhyloBase q c a = initPhyloBase periods foundations
 201   where
 202     --------------------------------------
 203     periods :: [(Date,Date)]
 204     periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
 205             $ both fst (head c,last c)
 206     --------------------------------------
 207     foundations :: Vector Ngrams
 208     foundations = initFoundations a
 209     --------------------------------------
 210
 211
 212 -- | To reconstruct a Phylomemy from a PhyloQuery, a Corpus and a list of actants
 213 toPhylo :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo
 214 toPhylo q c a = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
 215   where
 216     --------------------------------------
 217     phylo1 :: Phylo
 218     phylo1 = toPhylo1 (getFstCluster q) (getInterTemporalMatching q) phyloDocs phylo0
 219     --------------------------------------
 220     phylo0 :: Phylo
 221     phylo0 = toPhylo0 phyloDocs phyloBase
 222     --------------------------------------
 223     phyloDocs :: Map (Date, Date) [Document]
 224     phyloDocs = corpusToDocs groupNgramsWithTrees c phyloBase
 225     --------------------------------------
 226     phyloBase :: Phylo
 227     phyloBase = toPhyloBase q c a
 228     --------------------------------------