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

   1 {-|
   2 Module      : Gargantext.Database.Flow.List
   3 Description : List 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 {-# OPTIONS_GHC -fno-warn-orphans    #-}
  13
  14 {-# LANGUAGE ConstraintKinds         #-}
  15 {-# LANGUAGE ConstrainedClassMethods #-}
  16 {-# LANGUAGE ConstraintKinds         #-}
  17 {-# LANGUAGE InstanceSigs            #-}
  18
  19 module Gargantext.Database.Action.Flow.List
  20     where
  21
  22 import Control.Monad (mapM_)
  23 import qualified Data.List as List
  24 import qualified Data.Map  as Map
  25 import Data.Map (Map, toList)
  26 import Data.Maybe (Maybe(..), catMaybes)
  27 import Data.Text (Text)
  28
  29 import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
  30 import Gargantext.Core.Flow.Types
  31 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
  32 import Gargantext.Database.Admin.Types.Node
  33 import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
  34 import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
  35 import Gargantext.Database.Action.Flow.Types
  36 import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
  37 import Gargantext.Prelude
  38
  39 -- FLOW LIST
  40 -- 1. select specific terms of the corpus when compared with others langs
  41 -- (for now, suppose english)
  42 -- 2. select specific terms of the corpus when compared with others corpora (same database)
  43 -- 3. select clusters of terms (generic and specific)
  44
  45 {-
  46 data FlowList = FlowListLang
  47               | FlowListTficf
  48               | FlowListSpeGen
  49
  50
  51 flowList_Tficf :: UserCorpusId
  52                -> MasterCorpusId
  53                -> NgramsType
  54                -> (Text -> Text)
  55                -> Cmd err (Map Text (Double, Set Text))
  56 flowList_Tficf u m nt f = do
  57
  58   u' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsUser   u nt
  59   m' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsMaster u m
  60
  61   pure $ sortTficf Down
  62        $ toTficfData (countNodesByNgramsWith f u')
  63                      (countNodesByNgramsWith f m')
  64
  65 flowList_Tficf' :: UserCorpusId
  66                -> MasterCorpusId
  67                -> NgramsType
  68                -> Cmd err (Map Text (Double, Set Text))
  69 flowList_Tficf' u m nt f = do
  70
  71   u' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsUser   u nt
  72   m' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsMaster u m
  73
  74   pure $ sortTficf Down
  75        $ toTficfData (countNodesByNgramsWith f u')
  76                      (countNodesByNgramsWith f m')
  77
  78 -}
  79
  80
  81
  82
  83
  84
  85 -- | TODO check optimization
  86 mapNodeIdNgrams :: [DocumentIdWithNgrams a]
  87                 -> Map Ngrams (Map NgramsType (Map NodeId Int))
  88 mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
  89   where
  90     f :: DocumentIdWithNgrams a
  91       -> Map Ngrams (Map NgramsType (Map NodeId Int))
  92     f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
  93       where
  94         nId = documentId $ documentWithId d
  95
  96 ------------------------------------------------------------------------
  97 flowList_DbRepo :: FlowCmdM env err m
  98          => ListId
  99          -> Map NgramsType [NgramsElement]
 100          -> m ListId
 101 flowList_DbRepo lId ngs = do
 102   -- printDebug "listId flowList" lId
 103   mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
 104   let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> parent)
 105                                  <*>  getCgramsId mapCgramsId ntype ngram
 106                            | (ntype, ngs') <- Map.toList ngs
 107                            , NgramsElement ngram _ _ _ _ parent _ <- ngs'
 108                            ]
 109   -- Inserting groups of ngrams
 110   _r <- insert_Node_NodeNgrams_NodeNgrams
 111      $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
 112
 113   listInsert lId ngs
 114
 115   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
 116   pure lId
 117 ------------------------------------------------------------------------
 118 ------------------------------------------------------------------------
 119
 120 toNodeNgramsW :: ListId
 121               -> [(NgramsType, [NgramsElement])]
 122               -> [NodeNgramsW]
 123 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
 124   where
 125     toNodeNgramsW'' :: ListId
 126                   -> (NgramsType, [NgramsElement])
 127                   -> [NodeNgramsW]
 128     toNodeNgramsW'' l' (ngrams_type, elms) =
 129       [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
 130        (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
 131       ]
 132
 133
 134 toNodeNgramsW' :: ListId
 135                -> [(Text, [NgramsType])]
 136                -> [NodeNgramsW]
 137 toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
 138                          | (terms, ngrams_types) <- ngs
 139                          , ngrams_type <- ngrams_types
 140                          ]
 141
 142
 143 listInsert :: FlowCmdM env err m
 144              => ListId
 145              -> Map NgramsType [NgramsElement]
 146              -> m ()
 147 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 148                              -> putListNgrams lId typeList ngElmts) (toList ngs)
 149
 150 ------------------------------------------------------------------------
 151 ------------------------------------------------------------------------