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 {-# LANGUAGE TypeFamilies #-}
  13
  14 module Gargantext.API.Ngrams.Tools
  15   where
  16
  17 import Control.Concurrent
  18 import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
  19 import Control.Monad.Reader
  20 import Data.HashMap.Strict (HashMap)
  21 import Data.Hashable (Hashable)
  22 import Data.Set (Set)
  23 import Data.Validity
  24 import Gargantext.API.Ngrams.Types
  25 import Gargantext.Core.Types (ListType(..), NodeId, ListId)
  26 import Gargantext.Database.Schema.Ngrams (NgramsType)
  27 import Gargantext.Prelude
  28 import qualified Data.HashMap.Strict as HM
  29 import qualified Data.Map.Strict     as Map
  30 import qualified Data.Set            as Set
  31 import Gargantext.Core.NodeStory
  32
  33 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
  34 mergeNgramsElement _neOld neNew = neNew
  35
  36 type RootTerm = NgramsTerm
  37
  38 getRepo :: RepoCmdM env err m => m NgramsRepo
  39 getRepo = do
  40   v <- view repoVar
  41   liftBase $ readMVar v
  42
  43 getNodeListStory :: HasNodeStory' env err m
  44                  => m (NodeId -> IO (MVar NodeListStory))
  45 getNodeListStory = do
  46   env <- view hasNodeStory
  47   pure $ view nse_getter env
  48
  49 getNodeListStory' :: HasNodeStory' env err m
  50                  => NodeId -> m (IO NodeListStory)
  51 getNodeListStory' n = do
  52   f <- getNodeListStory
  53   v <- liftBase $ f n
  54   pure $ readMVar v
  55
  56 getNodeListStory'' :: HasNodeStory' env err m
  57                  => NodeId -> m NodeListStory
  58 getNodeListStory'' n = do
  59   f <- getNodeListStory
  60   v  <- liftBase  $ f n
  61   v' <- liftBase $ readMVar v
  62   pure $ v'
  63
  64
  65
  66 listNgramsFromRepo :: [ListId] -> NgramsType
  67                    -> NgramsRepo -> HashMap NgramsTerm NgramsRepoElement
  68 listNgramsFromRepo nodeIds ngramsType repo = ngrams
  69   where
  70     ngramsMap = repo ^. r_state . at ngramsType . _Just
  71
  72     -- TODO HashMap linked
  73     ngrams    = HM.fromList $ Map.toList $ Map.unionsWith mergeNgramsElement
  74                 [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
  75
  76
  77 -- TODO-ACCESS: We want to do the security check before entering here.
  78 --              Add a static capability parameter would be nice.
  79 --              Ideally this is the access to `repoVar` which needs to
  80 --              be properly guarded.
  81 getListNgrams :: RepoCmdM env err m
  82               => [ListId] -> NgramsType
  83               -> m (HashMap NgramsTerm NgramsRepoElement)
  84 getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
  85
  86 getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
  87           => (NgramsTerm -> a) -> [ListId]
  88           -> NgramsType -> Set ListType
  89           -> m (HashMap a [a])
  90 getTermsWith f ls ngt lts = HM.fromListWith (<>)
  91                       <$> map toTreeWith
  92                       <$> HM.toList
  93                       <$> HM.filter (\f' -> Set.member (fst f') lts)
  94                       <$> mapTermListRoot ls ngt
  95                       <$> getRepo
  96   where
  97     toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
  98       Nothing -> (f t, [])
  99       Just  r -> (f r, [f t])
 100
 101 mapTermListRoot :: [ListId]
 102                 -> NgramsType
 103                 -> NgramsRepo
 104                 -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
 105 mapTermListRoot nodeIds ngramsType repo =
 106       (\nre -> (_nre_list nre, _nre_root nre))
 107   <$> listNgramsFromRepo nodeIds ngramsType repo
 108
 109 filterListWithRootHashMap :: ListType
 110                           -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
 111                           -> HashMap NgramsTerm (Maybe RootTerm)
 112 filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
 113   where
 114     isMapTerm (l, maybeRoot) = case maybeRoot of
 115       Nothing -> l == lt
 116       Just  r -> case HM.lookup r m of
 117         Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
 118         Just  (l',_) -> l' == lt
 119
 120 filterListWithRoot :: ListType
 121                    -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
 122                    -> HashMap NgramsTerm (Maybe RootTerm)
 123 filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
 124   where
 125     isMapTerm (l, maybeRoot) = case maybeRoot of
 126       Nothing -> l == lt
 127       Just  r -> case HM.lookup r m of
 128         Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
 129         Just  (l',_) -> l' == lt
 130
 131 groupNodesByNgrams :: ( At root_map
 132                       , Index root_map ~ NgramsTerm
 133                       , IxValue root_map ~ Maybe RootTerm
 134                       )
 135                    => root_map
 136                    -> HashMap NgramsTerm (Set NodeId)
 137                    -> HashMap NgramsTerm (Set NodeId)
 138 groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
 139   where
 140     occs' = map toSyn (HM.toList occs)
 141     toSyn (t,ns) = case syn ^. at t of
 142       Nothing -> panic $ "[Garg.API.Ngrams.Tools.groupNodesByNgrams] unknown key: " <> unNgramsTerm t
 143       Just  r -> case r of
 144         Nothing  -> (t, ns)
 145         Just  r' -> (r',ns)
 146
 147 data Diagonal = Diagonal Bool
 148
 149 getCoocByNgrams :: Diagonal -> HashMap NgramsTerm (Set NodeId) -> HashMap (NgramsTerm, NgramsTerm) Int
 150 getCoocByNgrams = getCoocByNgrams' identity
 151
 152
 153 getCoocByNgrams' :: (Hashable a, Ord a, Ord c) => (b -> Set c) -> Diagonal -> HashMap a b -> HashMap (a, a) Int
 154 getCoocByNgrams' f (Diagonal diag) m =
 155   HM.fromList [( (t1,t2)
 156                , maybe 0 Set.size $ Set.intersection
 157                                  <$> (fmap f $ HM.lookup t1 m)
 158                                  <*> (fmap f $ HM.lookup t2 m)
 159                )
 160               | (t1,t2) <- if diag then
 161                              [ (x,y) | x <- ks, y <- ks, x <= y] -- TODO if we keep a Data.Map here it might be
 162                                                                  -- more efficient to enumerate all the y <= x.
 163                            else
 164                              listToCombi identity ks
 165               ]
 166
 167   where ks = HM.keys m
 168
 169 ------------------------------------------