src/Gargantext/Database/Action/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 Arrows #-}
  14
  15 module Gargantext.Database.Action.Flow.Pairing
  16   -- (pairing)
  17     where
  18
  19 import Data.Set (Set)
  20 import Control.Lens (_Just, (^.))
  21 import Data.Map (Map, fromList, fromListWith)
  22 import Data.Maybe (catMaybes, fromMaybe)
  23 import Data.Text (Text, toLower)
  24 import Database.PostgreSQL.Simple.SqlQQ (sql)
  25 import Gargantext.Core.Types (TableResult(..))
  26 import Gargantext.Database
  27 import Gargantext.Database.Action.Flow.Utils
  28 import Gargantext.Database.Admin.Types.Hyperdata -- (HyperdataContact(..))
  29 import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
  30 import Gargantext.Database.Prelude (Cmd, runPGSQuery)
  31 import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
  32 import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
  33 import Gargantext.Database.Schema.Node
  34 import Gargantext.Prelude hiding (sum)
  35 import Safe (lastMay)
  36 import qualified Data.List as List
  37 import qualified Data.Map  as DM
  38 import qualified Data.Map  as Map
  39 import qualified Data.Text as DT
  40 import qualified Data.Set  as Set
  41
  42 -- TODO mv this type in Types Main
  43 type Terms = Text
  44
  45
  46
  47 {-
  48 pairingPolicy :: (Terms -> Terms)
  49               -> NgramsT Ngrams
  50               -> NgramsT Ngrams
  51 pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
  52
  53
  54 pairMaps :: Map (NgramsT Ngrams) a
  55          -> Map (NgramsT Ngrams) NgramsId
  56          -> Map NgramsIndexed (Map NgramsType a)
  57 pairMaps m1 m2 =
  58   DM.fromList
  59     [ (NgramsIndexed ng nId, DM.singleton nt n2i)
  60     | (k@(NgramsT nt ng),n2i) <- DM.toList m1
  61     , Just nId <- [DM.lookup k m2]
  62     ]
  63 -}
  64
  65 -----------------------------------------------------------------------
  66
  67 pairing :: AnnuaireId -> CorpusId -> ListId -> Cmd err Int
  68 pairing a c l = do
  69   dataPaired <- dataPairing a (c,l,Authors) lastName toLower
  70   insertDB $ prepareInsert dataPaired
  71
  72
  73 dataPairing :: AnnuaireId
  74              -> (CorpusId, ListId, NgramsType)
  75              -> (ContactName -> Projected)
  76              -> (DocAuthor   -> Projected)
  77              -> Cmd err (Map ContactId (Set DocId))
  78 dataPairing aId (cId, lId, ngt) fc fa = do
  79   mc <- getNgramsContactId aId
  80   md <- getNgramsDocId cId lId ngt
  81
  82   let
  83     from = projectionFrom (Set.fromList $ Map.keys mc) fc
  84     to   = projectionTo   (Set.fromList $ Map.keys md) fa
  85
  86   pure $ fusion mc $ align from to md
  87
  88
  89
  90 prepareInsert :: Map ContactId (Set DocId) -> [NodeNode]
  91 prepareInsert m =  map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing)
  92                 $ List.concat
  93                 $ map (\(contactId, setDocIds)
  94                         -> map (\setDocId
  95                                  -> (contactId, setDocId)
  96                                ) $ Set.toList setDocIds
  97                        )
  98                 $ Map.toList m
  99
 100
 101
 102 ------------------------------------------------------------------------
 103 type ContactName = Text
 104 type DocAuthor   = Text
 105 type Projected   = Text
 106
 107 projectionFrom :: Set ContactName -> (ContactName -> Projected) -> Map ContactName Projected
 108 projectionFrom ss f = fromList $ map (\s -> (s, f s)) (Set.toList ss)
 109
 110 projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> Map Projected (Set DocAuthor)
 111 projectionTo ss f = fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss)
 112
 113 ------------------------------------------------------------------------
 114 lastName :: Terms -> Terms
 115 lastName texte = DT.toLower
 116                $ maybe texte (\x -> if DT.length x > 3 then x else texte)
 117                              (lastName' texte)
 118   where
 119     lastName' = lastMay . DT.splitOn " "
 120
 121
 122 ------------------------------------------------------------------------
 123 align :: Map ContactName Projected
 124       -> Map Projected (Set DocAuthor)
 125       -> Map DocAuthor (Set DocId)
 126       -> Map ContactName (Set DocId)
 127 align mc ma md = fromListWith (<>)
 128                $ map (\c -> (c, getProjection md $ testProjection c mc ma))
 129                $ Map.keys mc
 130   where
 131     getProjection :: Map DocAuthor (Set DocId) -> Set DocAuthor -> Set DocId
 132     getProjection ma' sa' =
 133       if Set.null sa'
 134          then Set.empty
 135          else Set.unions $ sets ma' sa'
 136            where
 137              sets ma'' sa'' = Set.map (\s -> lookup s ma'') sa''
 138              lookup s' ma''= fromMaybe Set.empty (Map.lookup s' ma'')
 139
 140     testProjection :: ContactName
 141                    -> Map ContactName Projected
 142                    -> Map Projected (Set DocAuthor)
 143                    -> Set DocAuthor
 144     testProjection cn' mc' ma' = case Map.lookup cn' mc' of
 145       Nothing -> Set.empty
 146       Just  c -> case Map.lookup c ma' of
 147         Nothing -> Set.empty
 148         Just  a -> a
 149
 150
 151 fusion :: Map ContactName (Set ContactId)
 152        -> Map ContactName (Set DocId)
 153        -> Map ContactId   (Set DocId)
 154 fusion mc md = undefined
 155 {- fromListWith (<>)
 156        $ catMaybes
 157        $ map (\c -> case Map.lookup c mc of
 158              Nothing -> Nothing
 159              Just  x -> map (\
 160
 161        $ toList mc
 162 -}
 163 ------------------------------------------------------------------------
 164
 165 getNgramsContactId :: AnnuaireId
 166                    -> Cmd err (Map ContactName (Set NodeId))
 167 getNgramsContactId aId = do
 168   contacts <- getAllContacts aId
 169   pure $ fromListWith (<>)
 170        $ catMaybes
 171        $ map (\contact -> (,) <$> contact^.(node_hyperdata . hc_who . _Just . cw_lastName)
 172                               <*> Just ( Set.singleton (contact^.node_id))
 173               ) (tr_docs contacts)
 174
 175 -- | TODO
 176 -- filter Trash / map Authors
 177 -- Indexing all ngramsType like Authors
 178 getNgramsDocId :: CorpusId
 179                   -> ListId
 180                   -> NgramsType
 181                   -> Cmd err (Map DocAuthor (Set NodeId))
 182 getNgramsDocId corpusId listId ngramsType
 183   = fromListWith (<>)
 184   <$> map (\(t,nId) -> (t, Set.singleton (NodeId nId)))
 185   <$> selectNgramsDocId corpusId listId ngramsType
 186
 187
 188 selectNgramsDocId :: CorpusId
 189                    -> ListId
 190                    -> NgramsType
 191                    -> Cmd err [(Text, Int)]
 192 selectNgramsDocId corpusId' listId' ngramsType' =
 193  runPGSQuery selectQuery (corpusId', listId', ngramsTypeId ngramsType')
 194    where
 195      selectQuery = [sql| SELECT ng.terms,nnng.node2_id from ngrams ng
 196                     JOIN node_node_ngrams nnng ON nnng.ngrams_id = ng.id
 197                     JOIN nodes_nodes      nn   ON nn.node2_id    = nnng.node2_id
 198
 199                     WHERE nn.node1_id = ?
 200                       AND nnng.node1_id    = ?
 201                       AND nnng.ngrams_type = ?
 202                     ;
 203                    |]
 204