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.words . 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 -> (Clique,Support) -> 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 $ 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 -> Proximity -> Cluster -> 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 (getProximity clus) 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 Method
 176 toPhylo1 :: Cluster -> Proximity -> Map (Date, Date) [Document] -> Phylo -> Phylo
 177 toPhylo1 clus prox d p = case clus of
 178   Fis (FisParams f k s) -> setPhyloBranches 1
 179                             $ interTempoMatching Descendant 1 prox
 180                             $ interTempoMatching Ascendant 1 prox
 181                             $ setLevelLinks (0,1)
 182                             $ setLevelLinks (1,0)
 183                             $ addPhyloLevel 1 phyloFis p
 184     where
 185       --------------------------------------
 186       phyloFis :: Map (Date, Date) [PhyloFis]
 187       phyloFis = if f
 188                  then filterFisBySupport k s (filterFisByNested (docsToFis d))
 189                  else docsToFis d
 190       --------------------------------------
 191
 192   _   -> panic "[ERR][Viz.Phylo.PhyloMaker.toPhylo1] fst clustering not recognized"
 193
 194
 195 -- | To reconstruct the Level 0 of a Phylo
 196 toPhylo0 :: Map (Date, Date) [Document] -> Phylo -> Phylo
 197 toPhylo0 d p = addPhyloLevel 0 d p
 198
 199
 200 -- | To reconstruct the Base of a Phylo
 201 toPhyloBase :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo
 202 toPhyloBase q c a = initPhyloBase periods foundations
 203   where
 204     --------------------------------------
 205     periods :: [(Date,Date)]
 206     periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
 207             $ both fst (head c,last c)
 208     --------------------------------------
 209     foundations :: Vector Ngrams
 210     foundations = initFoundations a
 211     --------------------------------------
 212
 213
 214 -- | To reconstruct a Phylomemy from a PhyloQuery, a Corpus and a list of actants
 215 toPhylo :: PhyloQuery -> [(Date, Text)] -> [Ngrams] -> Phylo
 216 toPhylo q c a = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
 217   where
 218     --------------------------------------
 219     phylo1 :: Phylo
 220     phylo1 = toPhylo1 (getFstCluster q) (getInterTemporalMatching q) phyloDocs phylo0
 221     --------------------------------------
 222     phylo0 :: Phylo
 223     phylo0 = toPhylo0 phyloDocs phyloBase
 224     --------------------------------------
 225     phyloDocs :: Map (Date, Date) [Document]
 226     phyloDocs = corpusToDocs groupNgramsWithTrees c phyloBase
 227     --------------------------------------
 228     phyloBase :: Phylo
 229     phyloBase = toPhyloBase q c a
 230     --------------------------------------