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 Control.Lens (_Just, (^.))
  20 import Data.Map (Map, fromList, fromListWith)
  21 import Data.Maybe (catMaybes, fromMaybe)
  22 import Data.Set (Set)
  23 import Data.Text (Text)
  24 import Gargantext.API.Ngrams.Tools
  25 import Gargantext.API.Prelude (GargNoServer)
  26 import Gargantext.Core.Types (TableResult(..), Term)
  27 import Gargantext.Core.Types.Main
  28 import Gargantext.Database
  29 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  30 import Gargantext.Database.Admin.Config
  31 import Gargantext.Database.Admin.Config (nodeTypeId)
  32 import Gargantext.Database.Admin.Types.Hyperdata -- (HyperdataContact(..))
  33 import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
  34 import Gargantext.Database.Prelude (Cmd, runOpaQuery)
  35 import Gargantext.Database.Query.Prelude (leftJoin2, returnA, queryNodeNodeTable)
  36 import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
  37 import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
  38 import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
  39 import Gargantext.Database.Schema.Node
  40 import Gargantext.Prelude hiding (sum)
  41 import Opaleye
  42 import Safe (lastMay)
  43 import qualified Data.List as List
  44 import qualified Data.Map  as Map
  45 import qualified Data.Set  as Set
  46 import qualified Data.Text as DT
  47
  48
  49 -- | isPairedWith
  50 -- All NodeAnnuaire paired with a Corpus of NodeId nId:
  51 -- isPairedWith NodeAnnuaire corpusId
  52 isPairedWith :: NodeType -> NodeId -> Cmd err [NodeId]
  53 isPairedWith nt nId = runOpaQuery (selectQuery nt nId)
  54   where
  55     selectQuery :: NodeType -> NodeId -> Query (Column PGInt4)
  56     selectQuery nt' nId' = proc () -> do
  57       (node, node_node) <- queryJoin -< ()
  58       restrict -< (node^.node_typename)    .== (pgInt4 $ nodeTypeId nt')
  59       restrict -< (node_node^.nn_node1_id) .== (toNullable $ pgNodeId nId')
  60       returnA  -<  node^.node_id
  61
  62     queryJoin :: Query (NodeRead, NodeNodeReadNull)
  63     queryJoin = leftJoin2 queryNodeTable queryNodeNodeTable cond
  64       where
  65         cond (node, node_node) = node^.node_id .== node_node^. nn_node2_id
  66
  67
  68
  69
  70 -----------------------------------------------------------------------
  71 pairing :: AnnuaireId -> CorpusId -> ListId -> GargNoServer Int
  72 pairing a c l = do
  73   dataPaired <- dataPairing a (c,l,Authors) takeName takeName
  74   insertDB $ prepareInsert dataPaired
  75
  76
  77 dataPairing :: AnnuaireId
  78              -> (CorpusId, ListId, NgramsType)
  79              -> (ContactName -> Projected)
  80              -> (DocAuthor   -> Projected)
  81              -> GargNoServer (Map ContactId (Set DocId))
  82 dataPairing aId (cId, lId, ngt) fc fa = do
  83   mc <- getNgramsContactId aId
  84   md <- getNgramsDocId cId lId ngt
  85
  86   printDebug "ngramsContactId" mc
  87   printDebug "ngramsDocId"     md
  88   let
  89     from = projectionFrom (Set.fromList $ Map.keys mc) fc
  90     to   = projectionTo   (Set.fromList $ Map.keys md) fa
  91
  92   pure $ fusion mc $ align from to md
  93
  94
  95
  96 prepareInsert :: Map ContactId (Set DocId) -> [NodeNode]
  97 prepareInsert m =  map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing)
  98                 $ List.concat
  99                 $ map (\(contactId, setDocIds)
 100                         -> map (\setDocId
 101                                  -> (contactId, setDocId)
 102                                ) $ Set.toList setDocIds
 103                        )
 104                 $ Map.toList m
 105
 106 ------------------------------------------------------------------------
 107 type ContactName = Text
 108 type DocAuthor   = Text
 109 type Projected   = Text
 110
 111 projectionFrom :: Set ContactName -> (ContactName -> Projected) -> Map ContactName Projected
 112 projectionFrom ss f = fromList $ map (\s -> (s, f s)) (Set.toList ss)
 113
 114 projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> Map Projected (Set DocAuthor)
 115 projectionTo ss f = fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss)
 116 ------------------------------------------------------------------------
 117 takeName :: Term -> Term
 118 takeName texte = DT.toLower texte'
 119   where
 120     texte' = maybe texte (\x -> if DT.length x > 3 then x else texte)
 121                            (lastName' texte)
 122     lastName' = lastMay . DT.splitOn " "
 123
 124
 125 ------------------------------------------------------------------------
 126 align :: Map ContactName Projected
 127       -> Map Projected (Set DocAuthor)
 128       -> Map DocAuthor (Set DocId)
 129       -> Map ContactName (Set DocId)
 130 align mc ma md = fromListWith (<>)
 131                $ map (\c -> (c, getProjection md $ testProjection c mc ma))
 132                $ Map.keys mc
 133   where
 134     getProjection :: Map DocAuthor (Set DocId) -> Set DocAuthor -> Set DocId
 135     getProjection ma' sa' =
 136       if Set.null sa'
 137          then Set.empty
 138          else Set.unions $ sets ma' sa'
 139            where
 140              sets ma'' sa'' = Set.map (\s -> lookup s ma'') sa''
 141              lookup s' ma''= fromMaybe Set.empty (Map.lookup s' ma'')
 142
 143     testProjection :: ContactName
 144                    -> Map ContactName Projected
 145                    -> Map Projected (Set DocAuthor)
 146                    -> Set DocAuthor
 147     testProjection cn' mc' ma' = case Map.lookup cn' mc' of
 148       Nothing -> Set.empty
 149       Just  c -> case Map.lookup c ma' of
 150         Nothing -> Set.empty
 151         Just  a -> a
 152
 153 fusion :: Map ContactName (Set ContactId)
 154        -> Map ContactName (Set DocId)
 155        -> Map ContactId   (Set DocId)
 156 fusion mc md = Map.fromListWith (<>)
 157              $ catMaybes
 158              $ [ (,) <$> Just cId <*> Map.lookup cn md
 159                       | (cn, setContactId) <- Map.toList mc
 160                       , cId <- Set.toList setContactId
 161                ]
 162 ------------------------------------------------------------------------
 163
 164 getNgramsContactId :: AnnuaireId
 165                    -> Cmd err (Map ContactName (Set NodeId))
 166 getNgramsContactId aId = do
 167   contacts <- getAllContacts aId
 168   pure $ fromListWith (<>)
 169        $ catMaybes
 170        $ map (\contact -> (,) <$> contact^.(node_hyperdata . hc_who . _Just . cw_lastName)
 171                               <*> Just ( Set.singleton (contact^.node_id))
 172               ) (tr_docs contacts)
 173
 174
 175 getNgramsDocId :: CorpusId
 176                 -> ListId
 177                 -> NgramsType
 178                 -> GargNoServer (Map DocAuthor (Set NodeId))
 179 getNgramsDocId cId lId nt = do
 180   repo <- getRepo
 181   lIds <- selectNodesWithUsername NodeList userMaster
 182   let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
 183
 184   groupNodesByNgrams ngs
 185     <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)