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 (catMaybes)
  27 import Data.Text (Text)
  28
  29 import Gargantext.API.Ngrams (NgramsElement(..), NgramsTerm(..), 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 -- | TODO check optimization
  82 mapNodeIdNgrams :: [DocumentIdWithNgrams a]
  83                 -> Map Ngrams (Map NgramsType (Map NodeId Int))
  84 mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
  85   where
  86     f :: DocumentIdWithNgrams a
  87       -> Map Ngrams (Map NgramsType (Map NodeId Int))
  88     f d = fmap (fmap (Map.singleton nId)) $ documentNgrams d
  89       where
  90         nId = documentId $ documentWithId d
  91
  92 ------------------------------------------------------------------------
  93 flowList_DbRepo :: FlowCmdM env err m
  94          => ListId
  95          -> Map NgramsType [NgramsElement]
  96          -> m ListId
  97 flowList_DbRepo lId ngs = do
  98   -- printDebug "listId flowList" lId
  99   mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
 100   let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent))
 101                                  <*>  getCgramsId mapCgramsId ntype ngram
 102                            | (ntype, ngs') <- Map.toList ngs
 103                            , NgramsElement (NgramsTerm ngram) _ _ _ _ parent _ <- ngs'
 104                            ]
 105   -- Inserting groups of ngrams
 106   _r <- insert_Node_NodeNgrams_NodeNgrams
 107      $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
 108
 109   listInsert lId ngs
 110
 111   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
 112   pure lId
 113 ------------------------------------------------------------------------
 114 ------------------------------------------------------------------------
 115
 116 toNodeNgramsW :: ListId
 117               -> [(NgramsType, [NgramsElement])]
 118               -> [NodeNgramsW]
 119 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
 120   where
 121     toNodeNgramsW'' :: ListId
 122                   -> (NgramsType, [NgramsElement])
 123                   -> [NodeNgramsW]
 124     toNodeNgramsW'' l' (ngrams_type, elms) =
 125       [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
 126        (NgramsElement (NgramsTerm ngrams_terms') _size list_type _occ _root _parent _children) <- elms
 127       ]
 128
 129
 130 toNodeNgramsW' :: ListId
 131                -> [(Text, [NgramsType])]
 132                -> [NodeNgramsW]
 133 toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
 134                          | (terms, ngrams_types) <- ngs
 135                          , ngrams_type <- ngrams_types
 136                          ]
 137
 138
 139 listInsert :: FlowCmdM env err m
 140              => ListId
 141              -> Map NgramsType [NgramsElement]
 142              -> m ()
 143 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 144                              -> putListNgrams lId typeList ngElmts) (toList ngs)
 145
 146 ------------------------------------------------------------------------
 147 ------------------------------------------------------------------------