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