src/Gargantext/Database/Flow/Pairing.hs

   1 {-|
   2 Module      : Gargantext.Database.Flow
   3 Description : Database 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 {-# LANGUAGE QuasiQuotes       #-}
  13 {-# LANGUAGE NoImplicitPrelude #-}
  14 {-# LANGUAGE OverloadedStrings #-}
  15 {-# LANGUAGE RankNTypes        #-}
  16 -- {-# LANGUAGE Arrows #-}
  17
  18 module Gargantext.Database.Flow.Pairing
  19     where
  20
  21 --import Debug.Trace (trace)
  22 import Control.Lens (_Just,view)
  23 import Database.PostgreSQL.Simple.SqlQQ (sql)
  24 -- import Opaleye
  25 -- import Opaleye.Aggregate
  26 -- import Control.Arrow (returnA)
  27 import Data.Maybe (catMaybes)
  28 import Data.Map (Map, fromList)
  29 import Safe (lastMay)
  30 import qualified Data.Map as DM
  31 import Data.Text (Text, toLower)
  32 import qualified Data.Text as DT
  33 import Gargantext.Prelude hiding (sum)
  34 import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
  35 --import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
  36 --import Gargantext.Database.Types.Node -- (Hyperdata(..))
  37 import Gargantext.Database.Node.Contact
  38 import Gargantext.Database.Flow.Utils
  39 import Gargantext.Database.Utils (Cmd, runPGSQuery)
  40 import Gargantext.Database.Types.Node (AnnuaireId, CorpusId)
  41 import Gargantext.Database.Node.Children
  42 import Gargantext.Core.Types (NodeType(..))
  43
  44 -- TODO mv this type in Types Main
  45 type Terms = Text
  46
  47 -- | TODO : add paring policy as parameter
  48 pairing :: AnnuaireId -> CorpusId -> Cmd err Int
  49 pairing aId cId = do
  50   contacts' <- getContacts aId (Just NodeContact)
  51   let contactsMap = pairingPolicyToMap toLower $ toMaps extractNgramsT contacts'
  52
  53   ngramsMap' <- getNgramsTindexed cId Authors
  54   let ngramsMap = pairingPolicyToMap lastName ngramsMap'
  55
  56   let indexedNgrams = pairMaps contactsMap ngramsMap
  57
  58   insertToNodeNgrams indexedNgrams
  59   -- TODO add List
  60
  61 lastName :: Terms -> Terms
  62 lastName texte = DT.toLower $ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
  63   where
  64     lastName' = lastMay . DT.splitOn " "
  65
  66 -- TODO: this methods is dangerous (maybe equalities of the result are not taken into account
  67 -- emergency demo plan...
  68 pairingPolicyToMap :: (Terms -> Terms)
  69                     -> Map (NgramsT Ngrams) a -> Map (NgramsT Ngrams) a
  70 pairingPolicyToMap f = DM.mapKeys (pairingPolicy f)
  71
  72 pairingPolicy :: (Terms -> Terms) -> NgramsT Ngrams -> NgramsT Ngrams
  73 pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
  74
  75 -- | TODO : use Occurrences in place of Int
  76 extractNgramsT :: HyperdataContact -> Map (NgramsT Ngrams) Int
  77 extractNgramsT contact = fromList [(NgramsT Authors    a' , 1)| a' <- authors    ]
  78   where
  79     authors    = map text2ngrams $ catMaybes [view (hc_who . _Just . cw_lastName) contact]
  80 --}
  81
  82 -- NP: notice how this function is no longer specific to the ContactId type
  83 pairMaps :: Map (NgramsT Ngrams) a
  84          -> Map (NgramsT Ngrams) NgramsId
  85          -> Map NgramsIndexed (Map NgramsType a)
  86 pairMaps m1 m2 =
  87   DM.fromList
  88     [ (NgramsIndexed ng nId, DM.singleton nt n2i)
  89     | (k@(NgramsT nt ng),n2i) <- DM.toList m1
  90     , Just nId <- [DM.lookup k m2]
  91     ]
  92
  93 -----------------------------------------------------------------------
  94 getNgramsTindexed:: CorpusId -> NgramsType -> Cmd err (Map (NgramsT Ngrams) NgramsId)
  95 getNgramsTindexed corpusId ngramsType' = fromList
  96     <$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
  97     <$> selectNgramsTindexed corpusId ngramsType'
  98
  99 selectNgramsTindexed :: CorpusId -> NgramsType -> Cmd err [(NgramsId, Terms, Int)]
 100 selectNgramsTindexed corpusId ngramsType'' = runPGSQuery selectQuery (corpusId, ngramsTypeId ngramsType'')
 101   where
 102     selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
 103                   JOIN nodes_ngrams occ ON occ.ngram_id = n.id
 104                   JOIN nodes_nodes  nn  ON nn.node2_id = occ.node_id
 105
 106                   WHERE nn.node1_id     = ?
 107                     AND occ.ngrams_type = ?
 108                     AND occ.node_id = nn.node2_id
 109                   GROUP BY n.id;
 110                  |]
 111
 112 {- | TODO more typed SQL queries
 113 selectNgramsTindexed :: CorpusId -> NgramsType -> Query NgramsRead
 114 selectNgramsTindexed corpusId ngramsType = proc () -> do
 115     nodeNode   <- queryNodeNodeTable     -< ()
 116     nodeNgrams <- queryNodesNgramsTable  -< ()
 117     ngrams     <- queryNgramsTable       -< ()
 118
 119     restrict -< node1_id nodeNode .== pgInt4 corpusId
 120     restrict -< node2_id nodeNode .== node_id nodeNgrams
 121     restrict -< ngrams_id ngrams  .== node_ngrams nodeNgrams
 122
 123     result <- aggregate groupBy (ngrams_id ngrams)
 124     returnA -< result
 125 --}
 126
 127