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