[ngrams] send array of context ids, instead of occurrences int
[gargantext.git] / src / Gargantext / API / Ngrams / Tools.hs
index 8005a727d5ab14adf70647687817fd787a522601..d7d11b8db217b45f53c5ae4941eab5045ce7ded9 100644 (file)
@@ -17,74 +17,118 @@ module Gargantext.API.Ngrams.Tools
 import Control.Concurrent
 import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
 import Control.Monad.Reader
-import Data.Hashable (Hashable)
 import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HM
-import Gargantext.Data.HashMap.Strict.Utils as HM
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
+import Data.Hashable (Hashable)
+import Data.Pool (withResource)
 import Data.Set (Set)
-import Data.Text (Text)
 import Data.Validity
-
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types (ListType(..), NodeId, ListId)
+import Gargantext.Core.NodeStory
+import Gargantext.Core.Types (ListType(..), NodeId, NodeType(..), ListId)
+import Gargantext.Database.Prelude (CmdM, HasConnectionPool(..))
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Map.Strict     as Map
+import qualified Data.Set            as Set
+import qualified Gargantext.Core.NodeStoryFile as NSF
+
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
 mergeNgramsElement _neOld neNew = neNew
 
 type RootTerm = NgramsTerm
 
-getRepo :: RepoCmdM env err m => m NgramsRepo
-getRepo = do
-  v <- view repoVar
-  liftBase $ readMVar v
 
-listNgramsFromRepo :: [ListId] -> NgramsType
-                   -> NgramsRepo -> Map NgramsTerm NgramsRepoElement
-listNgramsFromRepo nodeIds ngramsType repo = ngrams
-  where
-    ngramsMap = repo ^. r_state . at ngramsType . _Just
-
-    ngrams    = Map.unionsWith mergeNgramsElement
-                [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
+getRepo :: HasNodeStory env err m
+         => [ListId] -> m NodeListStory
+getRepo listIds = do
+  f <- getNodeListStory
+  v  <- liftBase $ f listIds
+  v' <- liftBase $ readMVar v
+  pure $ v'
 
 
+repoSize :: Ord k1 => NodeStory (Map.Map k1 (Map.Map k2 a)) p
+                   -> NodeId
+                   -> Map.Map k1 Int
+repoSize repo node_id = Map.map Map.size state
+  where
+    state = repo ^. unNodeStory
+                  . at node_id . _Just
+                  . a_state
+
+
+getNodeStoryVar :: HasNodeStory env err m
+           => [ListId] -> m (MVar NodeListStory)
+getNodeStoryVar l = do
+  f <- getNodeListStory
+  v  <- liftBase $ f l
+  pure v
+
+
+getNodeListStory :: HasNodeStory env err m
+                 => m ([NodeId] -> IO (MVar NodeListStory))
+getNodeListStory = do
+  env <- view hasNodeStory
+  pure $ view nse_getter env
+
+
+
+listNgramsFromRepo :: [ListId]
+                   -> NgramsType
+                   -> NodeListStory
+                   -> HashMap NgramsTerm NgramsRepoElement
+listNgramsFromRepo nodeIds ngramsType repo =
+  HM.fromList $ Map.toList
+              $ Map.unionsWith mergeNgramsElement ngrams
+    where
+      ngrams = [ repo
+               ^. unNodeStory
+                . at nodeId . _Just
+                . a_state
+                . at ngramsType . _Just
+                | nodeId <- nodeIds
+                ]
 
 -- TODO-ACCESS: We want to do the security check before entering here.
 --              Add a static capability parameter would be nice.
 --              Ideally this is the access to `repoVar` which needs to
 --              be properly guarded.
-getListNgrams :: RepoCmdM env err m
+getListNgrams :: HasNodeStory env err m
               => [ListId] -> NgramsType
-              -> m (Map NgramsTerm NgramsRepoElement)
-getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
+              -> m (HashMap NgramsTerm NgramsRepoElement)
+getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType
+                                 <$> getRepo nodeIds
 
-getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
+
+getTermsWith :: (HasNodeStory env err m, Eq a, Hashable a)
           => (NgramsTerm -> a) -> [ListId]
-          -> NgramsType -> ListType
+          -> NgramsType -> Set ListType
           -> m (HashMap a [a])
-getTermsWith f ls ngt lt = HM.fromListWith (<>)
+getTermsWith f ls ngt lt = HM.fromListWith (<>)
                       <$> map toTreeWith
-                      <$> Map.toList
-                      <$> Map.filter (\f' -> fst f' == lt)
+                      <$> HM.toList
+                      <$> HM.filter (\f' -> Set.member (fst f') lts)
                       <$> mapTermListRoot ls ngt
-                      <$> getRepo
+                      <$> getRepo ls
   where
     toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
       Nothing -> (f t, [])
       Just  r -> (f r, [f t])
 
+
+
 mapTermListRoot :: [ListId]
                 -> NgramsType
-                -> NgramsRepo
-                -> Map NgramsTerm (ListType, Maybe NgramsTerm)
+                -> NodeListStory
+                -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
 mapTermListRoot nodeIds ngramsType repo =
-  (\nre -> (_nre_list nre, _nre_root nre)) <$>
-  listNgramsFromRepo nodeIds ngramsType repo
+      (\nre -> (_nre_list nre, _nre_root nre))
+  <$> listNgramsFromRepo nodeIds ngramsType repo
+
+
+
 
 filterListWithRootHashMap :: ListType
                           -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
@@ -94,19 +138,19 @@ filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
     isMapTerm (l, maybeRoot) = case maybeRoot of
       Nothing -> l == lt
       Just  r -> case HM.lookup r m of
-        Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r
+        Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
         Just  (l',_) -> l' == lt
 
-filterListWithRoot :: ListType
-                   -> Map NgramsTerm (ListType, Maybe NgramsTerm)
-                   -> Map NgramsTerm (Maybe RootTerm)
-filterListWithRoot lt m = snd <$> Map.filter isMapTerm m
+filterListWithRoot :: [ListType]
+                   -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
+                   -> HashMap NgramsTerm (Maybe RootTerm)
+filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
   where
     isMapTerm (l, maybeRoot) = case maybeRoot of
-      Nothing -> l == lt
-      Just  r -> case Map.lookup r m of
-        Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r
-        Just  (l',_) -> l' == lt
+      Nothing -> elem l lt
+      Just  r -> case HM.lookup r m of
+        Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
+        Just  (l',_) -> elem l' lt
 
 groupNodesByNgrams :: ( At root_map
                       , Index root_map ~ NgramsTerm
@@ -126,22 +170,79 @@ groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
 
 data Diagonal = Diagonal Bool
 
-getCoocByNgrams :: Diagonal -> HashMap Text (Set NodeId) -> HashMap (Text, Text) Int
+getCoocByNgrams :: Diagonal
+                -> HashMap NgramsTerm (Set NodeId)
+                -> HashMap (NgramsTerm, NgramsTerm) Int
 getCoocByNgrams = getCoocByNgrams' identity
 
 
-getCoocByNgrams' :: (Hashable a, Ord a, Ord c) => (b -> Set c) -> Diagonal -> HashMap a b -> HashMap (a, a) Int
+getCoocByNgrams' :: (Hashable a, Ord a, Ord c)
+                 => (b -> Set c)
+                 -> Diagonal
+                 -> HashMap a b
+                 -> HashMap (a, a) Int
 getCoocByNgrams' f (Diagonal diag) m =
   HM.fromList [( (t1,t2)
                , maybe 0 Set.size $ Set.intersection
                                  <$> (fmap f $ HM.lookup t1 m)
                                  <*> (fmap f $ HM.lookup t2 m)
                )
-              | (t1,t2) <- if diag then
-                             [ (x,y) | x <- ks, y <- ks, x <= y] -- TODO if we keep a Data.Map here it might be
-                                                                 -- more efficient to enumerate all the y <= x.
-                           else
-                             listToCombi identity ks
+              | (t1,t2) <- if diag
+                              then [ (x,y) | x <- ks, y <- ks, x <= y]
+                                   -- TODO if we keep a Data.Map here it might be
+                                   -- more efficient to enumerate all the y <= x.
+                              else
+                                listToCombi identity ks
               ]
 
-  where ks = HM.keys m
\ No newline at end of file
+  where 
+    ks = HM.keys m
+
+-- TODO k could be either k1 or k2 here
+getCoocByNgrams'' :: (Hashable k, Ord k, Ord contexts)
+                  => Diagonal
+                  -> (contextA -> Set contexts, contextB -> Set contexts)
+                  -> (HashMap k contextA, HashMap k contextB)
+                  -> HashMap (k, k) Int
+getCoocByNgrams'' (Diagonal diag) (f1,f2) (m1,m2) =
+  HM.fromList [( (t1,t2)
+               , maybe 0 Set.size $ Set.intersection
+                                 <$> (fmap f1 $ HM.lookup t1 m1)
+                                 <*> (fmap f2 $ HM.lookup t2 m2)
+               )
+              | (t1,t2) <- if diag
+                              then
+                                [ (x,y) | x <- ks1, y <- ks2, x <= y]
+                                   -- TODO if we keep a Data.Map here it might be
+                                   -- more efficient to enumerate all the y <= x.
+                              else
+                                [ (x,y) | x <- ks1, y <- ks2, x < y]
+                                -- TODO check optim
+                                -- listToCombi identity ks1
+              ]
+  where 
+    ks1 = HM.keys m1
+    ks2 = HM.keys m2
+
+
+
+------------------------------------------
+
+
+migrateFromDirToDb :: (CmdM env err m) -- , HasNodeStory env err m)
+                   => m ()
+migrateFromDirToDb = do
+  pool <- view connPool
+  withResource pool $ \c -> do
+    listIds <- liftBase $ getNodesIdWithType c NodeList
+    printDebug "[migrateFromDirToDb] listIds" listIds
+    (NodeStory nls) <- NSF.getRepoReadConfig listIds
+    printDebug "[migrateFromDirToDb] nls" nls
+    _ <- mapM (\(nId, a) -> do
+                  n <- liftBase $ nodeExists c nId
+                  case n of
+                    False -> pure ()
+                    True  -> liftBase $ upsertNodeStories c nId a
+              ) $ Map.toList nls
+    --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
+    pure ()