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