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 PhyloCluster
  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 PhyloFis
  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 l
  93     --------------------------------------
  94
  95
  96 -- | To transform a Cluster into a Phylogroup
  97 clusterToGroup :: PhyloPeriodId -> Level -> Int -> Text -> PhyloCluster -> Map (Date,Date) [PhyloCluster] -> 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 -> PhyloFis -> Map (Date, Date) [PhyloFis] -> Phylo -> PhyloGroup
 115 cliqueToGroup prd lvl idx lbl fis m p =
 116     PhyloGroup ((prd, lvl), idx) lbl ngrams (singleton "support" (fromIntegral $ getSupport fis)) cooc Nothing [] [] [] []
 117       where
 118         --------------------------------------
 119         ngrams :: [Int]
 120         ngrams = sort $ map (\x -> getIdxInPeaks x p)
 121                       $ Set.toList
 122                       $ getClique 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 -> getIdxInPeaks 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 incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
 148 toNthLevel :: Level -> Proximity -> Cluster -> Phylo -> Phylo
 149 toNthLevel lvlMax prox clus p
 150   | lvl >= lvlMax = p
 151   | otherwise     = toNthLevel lvlMax prox clus
 152                   $ setPhyloBranches (lvl + 1)
 153                   $ interTempoMatching Descendant  (lvl + 1) prox
 154                   $ interTempoMatching Ascendant (lvl + 1) prox
 155                   $ setLevelLinks (lvl, lvl + 1)
 156                   $ addPhyloLevel (lvl + 1)
 157                     (phyloToClusters lvl (getProximity clus) clus p) p
 158   where
 159     --------------------------------------
 160     lvl :: Level
 161     lvl = getLastLevel p
 162     --------------------------------------
 163
 164
 165 -- | To reconstruct the Level 1 of a Phylo based on a Clustering Method
 166 toPhylo1 :: Cluster -> Proximity -> [Metric] -> [Filter] -> Map (Date, Date) [Document] -> Phylo -> Phylo
 167 toPhylo1 clus prox metrics filters d p = case clus of
 168   Fis (FisParams k s) -> setPhyloBranches 1
 169                        $ interTempoMatching Descendant 1 prox
 170                        $ interTempoMatching Ascendant 1 prox
 171                        $ setLevelLinks (0,1)
 172                        $ setLevelLinks (1,0)
 173                        $ addPhyloLevel 1 phyloFis p
 174     where
 175       --------------------------------------
 176       phyloFis :: Map (Date, Date) [PhyloFis]
 177       phyloFis = toPhyloFis d k s metrics filters
 178       --------------------------------------
 179
 180   _   -> panic "[ERR][Viz.Phylo.LevelMaker.toPhylo1] fst clustering not recognized"
 181
 182
 183 -- | To reconstruct the Level 0 of a Phylo
 184 toPhylo0 :: Map (Date, Date) [Document] -> Phylo -> Phylo
 185 toPhylo0 d p = addPhyloLevel 0 d p
 186
 187
 188 -- | To reconstruct the Base of a Phylo
 189 toPhyloBase :: PhyloQuery -> PhyloParam -> [(Date, Text)] -> [Ngrams] -> [Tree Ngrams] -> Phylo
 190 toPhyloBase q p c a ts = initPhyloBase periods foundations peaks p
 191   where
 192     --------------------------------------
 193     peaks :: PhyloPeaks
 194     peaks = initPeaks (map (\t -> alterLabels phyloAnalyzer t) ts) foundations
 195     --------------------------------------
 196     periods :: [(Date,Date)]
 197     periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
 198             $ both fst (head c,last c)
 199     --------------------------------------
 200     foundations :: Vector Ngrams
 201     foundations = initFoundations a
 202     --------------------------------------
 203
 204
 205 -- | To reconstruct a Phylomemy from a PhyloQuery, a Corpus and a list of actants
 206 toPhylo :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> [Tree Ngrams] -> Phylo
 207 toPhylo q c a ts = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
 208   where
 209     --------------------------------------
 210     phylo1 :: Phylo
 211     phylo1 = toPhylo1 (getContextualUnit q) (getInterTemporalMatching q) (getContextualUnitMetrics q) (getContextualUnitFilters q) phyloDocs phylo0
 212     --------------------------------------
 213     phylo0 :: Phylo
 214     phylo0 = toPhylo0 phyloDocs phyloBase
 215     --------------------------------------
 216     phyloDocs :: Map (Date, Date) [Document]
 217     phyloDocs = corpusToDocs c phyloBase
 218     --------------------------------------
 219     phyloBase :: Phylo
 220     phyloBase = toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c a ts
 221     --------------------------------------