src/Gargantext/API/Ngrams/Tools.hs

   1 {-|
   2 Module      : Gargantext.API.Ngrams.Tools
   3 Description : Tools to manage Ngrams Elements (from the API)
   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 module Gargantext.API.Ngrams.Tools
  14   where
  15
  16 import Control.Concurrent
  17 import Control.Lens (_Just, (^.), at, view)
  18 import Control.Monad.Reader
  19 import Data.Map.Strict (Map)
  20 import qualified Data.Map.Strict as Map
  21 import qualified Data.Set as Set
  22 import Data.Set (Set)
  23 import Data.Text (Text)
  24 import Data.Validity
  25
  26 import Gargantext.API.Ngrams
  27 import Gargantext.Core.Types (ListType(..), NodeId, ListId)
  28 import Gargantext.Database.Schema.Ngrams (NgramsType)
  29 import Gargantext.Prelude
  30
  31 type RootTerm = Text
  32
  33 getRepo :: RepoCmdM env err m => m NgramsRepo
  34 getRepo = do
  35   v <- view repoVar
  36   liftBase $ readMVar v
  37
  38 listNgramsFromRepo :: [ListId] -> NgramsType
  39                    -> NgramsRepo -> Map Text NgramsRepoElement
  40 listNgramsFromRepo nodeIds ngramsType repo = Map.mapKeys unNgramsTerm ngrams
  41   where
  42     ngramsMap = repo ^. r_state . at ngramsType . _Just
  43
  44     ngrams    = Map.unionsWith mergeNgramsElement
  45                 [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
  46
  47 -- TODO-ACCESS: We want to do the security check before entering here.
  48 --              Add a static capability parameter would be nice.
  49 --              Ideally this is the access to `repoVar` which needs to
  50 --              be properly guarded.
  51 getListNgrams :: RepoCmdM env err m
  52               => [ListId] -> NgramsType
  53               -> m (Map Text NgramsRepoElement)
  54 getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
  55
  56 getTermsWith :: (RepoCmdM env err m, Ord a)
  57           => (Text -> a ) -> [ListId]
  58           -> NgramsType -> ListType
  59           -> m (Map a [a])
  60 getTermsWith f ls ngt lt = Map.fromListWith (<>)
  61                       <$> map (toTreeWith f)
  62                       <$> Map.toList
  63                       <$> Map.filter (\f' -> (fst f') == lt)
  64                       <$> mapTermListRoot ls ngt
  65                       <$> getRepo
  66   where
  67     toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
  68       Nothing -> (f'' t, [])
  69       Just  r -> (f'' r, map f'' [t])
  70
  71 mapTermListRoot :: [ListId]
  72                 -> NgramsType
  73                 -> NgramsRepo
  74                 -> Map Text (ListType, (Maybe Text))
  75 mapTermListRoot nodeIds ngramsType repo =
  76   Map.fromList [ (t, (_nre_list nre, unNgramsTerm <$> _nre_root nre))
  77                | (t, nre) <- Map.toList ngrams
  78                ]
  79   where ngrams = listNgramsFromRepo nodeIds ngramsType repo
  80
  81 filterListWithRoot :: ListType
  82                    -> Map Text (ListType, Maybe Text)
  83                    -> Map Text (Maybe RootTerm)
  84 filterListWithRoot lt m = Map.fromList
  85                     $ map (\(t,(_,r)) -> (t,r))
  86                     $ filter isMapTerm (Map.toList m)
  87   where
  88     isMapTerm (_t,(l, maybeRoot)) = case maybeRoot of
  89       Nothing -> l == lt
  90       Just  r -> case Map.lookup r m of
  91         Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> r
  92         Just  (l',_) -> l' == lt
  93
  94 groupNodesByNgrams :: Map Text (Maybe RootTerm)
  95                    -> Map Text (Set NodeId)
  96                    -> Map Text (Set NodeId)
  97 groupNodesByNgrams syn occs = Map.fromListWith (<>) occs'
  98   where
  99     occs' = map toSyn (Map.toList occs)
 100     toSyn (t,ns) = case Map.lookup t syn of
 101       Nothing -> panic $ "[Garg.API.Ngrams.Tools.groupNodesByNgrams] unknown key: " <> t
 102       Just  r -> case r of
 103         Nothing  -> (t, ns)
 104         Just  r' -> (r',ns)
 105
 106 data Diagonal = Diagonal Bool
 107
 108 getCoocByNgrams :: Diagonal -> Map Text (Set NodeId) -> Map (Text, Text) Int
 109 getCoocByNgrams = getCoocByNgrams' identity
 110
 111
 112 getCoocByNgrams' :: (Ord a, Ord c) => (b -> Set c) -> Diagonal -> Map a b -> Map (a, a) Int
 113 getCoocByNgrams' f (Diagonal diag) m =
 114   Map.fromList [( (t1,t2)
 115                 , maybe 0 Set.size $ Set.intersection
 116                                   <$> (fmap f $ Map.lookup t1 m)
 117                                   <*> (fmap f $ Map.lookup t2 m)
 118                 ) | (t1,t2) <- case diag of
 119                                  True   -> [ (x,y) | x <- Map.keys m, y <- Map.keys m, x <= y]
 120                                  False  -> listToCombi identity (Map.keys m)
 121                ]
 122