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