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