src/Gargantext/Database/Action/Metrics.hs

   1 {-|
   2 Module      : Gargantext.Database.Metrics
   3 Description : Get Metrics from Storage (Database like)
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Node API
  11 -}
  12
  13 module Gargantext.Database.Action.Metrics
  14   where
  15
  16 import Data.HashMap.Strict (HashMap)
  17 import Data.Vector (Vector)
  18 import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo')
  19 import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm)
  20 import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
  21 import Gargantext.Core.Mail.Types (HasMail)
  22 import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
  23 import Gargantext.Core.NodeStory
  24 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  25 import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser{-, getTficfWith-})
  26 import Gargantext.Database.Admin.Config (userMaster)
  27 import Gargantext.Database.Admin.Types.Node (ListId, CorpusId)
  28 import Gargantext.Database.Query.Table.Node (defaultList)
  29 import Gargantext.Database.Query.Table.Node.Select
  30 import Gargantext.Prelude
  31 import qualified Data.HashMap.Strict as HM
  32
  33 getMetrics :: FlowCmdM env err m
  34             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  35             -> m (HashMap NgramsTerm (ListType, Maybe NgramsTerm), Vector (Scored NgramsTerm))
  36 getMetrics cId maybeListId tabType maybeLimit = do
  37   (ngs, _, myCooc) <- getNgramsCooc cId maybeListId tabType maybeLimit
  38   -- TODO HashMap
  39   pure (ngs, scored myCooc)
  40
  41
  42 getNgramsCooc :: (FlowCmdM env err m)
  43             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
  44             -> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
  45                  , HashMap NgramsTerm (Maybe RootTerm)
  46                  , HashMap (NgramsTerm, NgramsTerm) Int
  47                  )
  48 getNgramsCooc cId maybeListId tabType maybeLimit = do
  49   (ngs', ngs) <- getNgrams cId maybeListId tabType
  50
  51   let
  52     take' Nothing  xs = xs
  53     take' (Just n) xs = take n xs
  54
  55   lId  <- defaultList cId
  56   lIds <- selectNodesWithUsername NodeList userMaster
  57
  58   myCooc <- HM.filter (>1) <$> getCoocByNgrams (Diagonal True)
  59                            <$> groupNodesByNgrams ngs
  60                            <$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) (ngramsTypeFromTabType tabType)
  61                                                             (take' maybeLimit $ HM.keys ngs)
  62   pure $ (ngs', ngs, myCooc)
  63
  64
  65
  66 getNgrams :: (HasMail env, HasNodeStory env err m)
  67             => CorpusId -> Maybe ListId -> TabType
  68             -> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
  69                  , HashMap NgramsTerm (Maybe RootTerm)
  70                  )
  71 getNgrams cId maybeListId tabType = do
  72
  73   lId <- case maybeListId of
  74     Nothing   -> defaultList cId
  75     Just lId' -> pure lId'
  76
  77   lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo' [lId]
  78   let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
  79                              [MapTerm, StopTerm, CandidateTerm]
  80   pure (lists, maybeSyn)
  81
  82
  83
  84