src/Gargantext/Database/Action/Flow/Utils.hs

   1 {-|
   2 Module      : Gargantext.Database.Flow.Utils
   3 Description : Database Flow
   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.Database.Action.Flow.Utils
  14     where
  15
  16 import Data.Map (Map)
  17 import qualified Data.Map as DM
  18
  19 import Gargantext.Core.Types.Individu (User(..))
  20 import Gargantext.Database.Admin.Types.Node
  21 import Gargantext.Database.Admin.Types.Hyperdata (Hyperdata)
  22 import Gargantext.Database.Prelude (Cmd)
  23 import Gargantext.Database.Query.Table.Node
  24 import Gargantext.Database.Query.Table.User
  25 import Gargantext.Database.Query.Table.Node.Error
  26 import Gargantext.Database.Query.Table.NodeNodeNgrams
  27 import Gargantext.Database.Schema.Ngrams
  28 import Gargantext.Database.Schema.Node
  29 import Gargantext.Prelude
  30
  31 getUserId :: HasNodeError err
  32           => User
  33           -> Cmd err UserId
  34 getUserId (UserDBId uid) = pure uid
  35 getUserId (RootId   rid) = do
  36   n <- getNode rid
  37   pure $ _node_userId n
  38 getUserId (UserName u  ) = do
  39   muser <- getUser u
  40   case muser of
  41     Just user -> pure $ userLight_id user
  42     Nothing   -> nodeError NoUserFound
  43
  44
  45 toMaps :: Hyperdata a
  46        => (a -> Map (NgramsT Ngrams) Int)
  47        -> [Node a]
  48        -> Map (NgramsT Ngrams) (Map NodeId Int)
  49 toMaps fun ns = mapNodeIdNgrams $ documentIdWithNgrams fun ns'
  50   where
  51     ns' = map (\(Node nId _ _ _ _ _ json) -> DocumentWithId nId json) ns
  52
  53 mapNodeIdNgrams :: Hyperdata a
  54                 => [DocumentIdWithNgrams a]
  55                 -> Map (NgramsT Ngrams) (Map NodeId Int)
  56 mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
  57   where
  58     xs  = [(ng, [(nId, i)]) | (nId, n2i') <- n2i ds, (ng, i) <- DM.toList n2i']
  59     n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
  60
  61
  62 documentIdWithNgrams :: Hyperdata a
  63                      => (a -> Map (NgramsT Ngrams) Int)
  64                      -> [DocumentWithId a]
  65                      -> [DocumentIdWithNgrams a]
  66 documentIdWithNgrams f = map (\d -> DocumentIdWithNgrams d ((f . documentData) d))
  67
  68
  69 data DocumentWithId a =
  70      DocumentWithId { documentId   :: NodeId
  71                     , documentData :: a
  72                     } deriving (Show)
  73
  74
  75 data DocumentIdWithNgrams a =
  76      DocumentIdWithNgrams
  77      { documentWithId  :: DocumentWithId a
  78      , document_ngrams :: Map (NgramsT Ngrams) Int
  79      } deriving (Show)
  80
  81
  82 docNgrams2nodeNodeNgrams :: CorpusId
  83                          -> DocNgrams
  84                          -> NodeNodeNgrams
  85 docNgrams2nodeNodeNgrams cId (DocNgrams d n nt w) =
  86   NodeNodeNgrams cId d n nt w
  87
  88 data DocNgrams = DocNgrams { dn_doc_id :: DocId
  89                            , dn_ngrams_id :: Int
  90                            , dn_ngrams_type :: NgramsTypeId
  91                            , dn_weight  :: Double
  92                            }
  93
  94 insertDocNgramsOn :: CorpusId
  95                   -> [DocNgrams]
  96                   -> Cmd err Int
  97 insertDocNgramsOn cId dn =
  98   insertNodeNodeNgrams
  99   $ (map (docNgrams2nodeNodeNgrams cId) dn)
 100
 101 insertDocNgrams :: CorpusId
 102                 -> Map NgramsIndexed (Map NgramsType (Map NodeId Int))
 103                 -> Cmd err Int
 104 insertDocNgrams cId m =
 105   insertDocNgramsOn cId [ DocNgrams n (_ngramsId ng) (ngramsTypeId t) (fromIntegral i)
 106                           | (ng, t2n2i) <- DM.toList m
 107                           , (t,  n2i)   <- DM.toList t2n2i
 108                           , (n,  i)     <- DM.toList n2i
 109                         ]
 110