Merge branch 'dev-pairing' into dev

devops/postgres/schema.sql

@@ -135,16 +135,27 @@ CREATE TABLE public.nodes_nodes (
 ALTER TABLE public.nodes_nodes OWNER TO gargantua;
 
 
+
 -- To attach contexts to a Corpus
 CREATE TABLE public.nodes_contexts (
+    id SERIAL                          ,
     node_id    INTEGER NOT NULL REFERENCES public.nodes(id)    ON DELETE CASCADE,
     context_id INTEGER NOT NULL REFERENCES public.contexts(id) ON DELETE CASCADE,
     score    REAL    ,
     category INTEGER ,
-    PRIMARY KEY (node_id, context_id)
+    PRIMARY KEY (id)
 );
 ALTER TABLE public.nodes_contexts OWNER TO gargantua;
 
+CREATE TABLE public.nodescontexts_nodescontexts (
+    nodescontexts1 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
+    nodescontexts2 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
+
+    PRIMARY KEY (nodescontexts1, nodescontexts2)
+);
+ALTER TABLE public.nodescontexts_nodescontexts OWNER TO gargantua;
+
+
 ---------------------------------------------------------------
 CREATE TABLE public.context_node_ngrams (
     context_id    INTEGER NOT NULL REFERENCES public.contexts (id) ON DELETE CASCADE,
@@ -157,7 +168,7 @@ CREATE TABLE public.context_node_ngrams (
 ALTER TABLE public.context_node_ngrams OWNER TO gargantua;
 
 CREATE TABLE public.context_node_ngrams2 (
-    context_id      INTEGER NOT NULL REFERENCES public.contexts  (id)       ON DELETE CASCADE,
+    context_id      INTEGER NOT NULL REFERENCES public.contexts     (id) ON DELETE CASCADE,
     nodengrams_id   INTEGER NOT NULL REFERENCES public.node_ngrams  (id) ON DELETE CASCADE,
     weight double   precision,
     PRIMARY KEY (context_id, nodengrams_id)
@@ -185,8 +196,6 @@ PRIMARY KEY (node_id, nodengrams_id)
 ALTER TABLE public.node_node_ngrams2 OWNER TO gargantua;
 
 
-
-
 --------------------------------------------------------------
 
 --CREATE TABLE public.nodes_ngrams_repo (
@@ -230,7 +239,7 @@ CREATE INDEX        ON public.contexts USING btree (id, typename, date DESC);
 CREATE INDEX        ON public.contexts USING btree (typename, id);
 CREATE UNIQUE INDEX ON public.contexts USING btree (hash_id);
 
-
+CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2);
 -- CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqId'::text)));
 -- CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqIdBdd'::text)));
 -- CREATE UNIQUE INDEX ON public.nodes USING btree (typename, parent_id, ((hyperdata ->> 'uniqId'::text)));
@@ -249,6 +258,7 @@ CREATE UNIQUE INDEX ON public.node_ngrams USING btree (node_id,node_subtype, ngr
 CREATE UNIQUE INDEX ON public.nodes_nodes  USING btree (node1_id, node2_id);
 CREATE INDEX        ON public.nodes_nodes  USING btree (node1_id, node2_id, category);
 
+
 -- To make the links between Corpus Node and its contexts
 CREATE UNIQUE INDEX ON public.nodes_contexts  USING btree (node_id, context_id);
 CREATE INDEX        ON public.nodes_contexts  USING btree (node_id, context_id, category);

devops/postgres/upgrade/0.0.5.7.5.sql

+
+ALTER TABLE nodes_contexts DROP CONSTRAINT nodes_contexts_pkey;
+ALTER TABLE nodes_contexts ADD COLUMN id SERIAL PRIMARY KEY ;
+
+CREATE TABLE public.nodescontexts_nodescontexts (
+    nodescontexts1 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
+    nodescontexts2 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
+
+    PRIMARY KEY (nodescontexts1, nodescontexts2)
+);
+ALTER TABLE public.nodescontexts_nodescontexts OWNER TO gargantua;
+
+CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2)
+

src/Gargantext/API/Client.hs

@@ -116,7 +116,7 @@ postNodeSearch :: Token -> NodeId -> SearchQuery -> Maybe Int -> Maybe Int -> Ma
 
 postNodeShare :: Token -> NodeId -> ShareNodeParams -> ClientM Int
 
-postNodePairCorpusAnnuaire :: Token -> NodeId -> AnnuaireId -> Maybe ListId -> ClientM Int
+postNodePairCorpusAnnuaire :: Token -> NodeId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
 getNodePairs :: Token -> NodeId -> ClientM [AnnuaireId]
 getNodePairings :: Token -> NodeId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
 
@@ -205,7 +205,7 @@ postCorpusSearch :: Token -> CorpusId -> SearchQuery -> Maybe Int -> Maybe Int -
 
 postCorpusShare :: Token -> CorpusId -> ShareNodeParams -> ClientM Int
 
-postCorpusPairCorpusAnnuaire :: Token -> CorpusId -> AnnuaireId -> Maybe ListId -> ClientM Int
+postCorpusPairCorpusAnnuaire :: Token -> CorpusId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
 getCorpusPairs :: Token -> CorpusId -> ClientM [AnnuaireId]
 getCorpusPairings :: Token -> CorpusId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
 
@@ -299,7 +299,7 @@ putAnnuaireScore :: Token -> AnnuaireId -> NodesToScore -> ClientM [Int]
 postAnnuaireSearch :: Token -> AnnuaireId -> SearchQuery -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM SearchResult
 postAnnuaireShare :: Token -> AnnuaireId -> ShareNodeParams -> ClientM Int
 
-postAnnuairePairCorpusAnnuaire :: Token -> AnnuaireId -> AnnuaireId -> Maybe ListId -> ClientM Int
+postAnnuairePairCorpusAnnuaire :: Token -> AnnuaireId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
 getAnnuairePairs :: Token -> AnnuaireId -> ClientM [AnnuaireId]
 getAnnuairePairings :: Token -> AnnuaireId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
 

src/Gargantext/API/Ngrams/Tools.hs

@@ -135,16 +135,16 @@ filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
         Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
         Just  (l',_) -> l' == lt
 
-filterListWithRoot :: ListType
+filterListWithRoot :: [ListType]
                    -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
                    -> HashMap NgramsTerm (Maybe RootTerm)
 filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
   where
     isMapTerm (l, maybeRoot) = case maybeRoot of
-      Nothing -> l == lt
+      Nothing -> elem l lt
       Just  r -> case HM.lookup r m of
         Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
-        Just  (l',_) -> l' == lt
+        Just  (l',_) -> elem l' lt
 
 groupNodesByNgrams :: ( At root_map
                       , Index root_map ~ NgramsTerm

src/Gargantext/API/Node.hs

@@ -312,7 +312,7 @@ pairs cId = do
 type PairWith = Summary "Pair a Corpus with an Annuaire"
               :> "annuaire" :> Capture "annuaire_id" AnnuaireId
               :> QueryParam "list_id"     ListId
-              :> Post '[JSON] Int
+              :> Post '[JSON] [Int]
 
 pairWith :: CorpusId -> GargServer PairWith
 pairWith cId aId lId = do

src/Gargantext/API/Node/Corpus/Export.hs

@@ -95,7 +95,7 @@ getContextNgrams cId lId listType nt repo = do
 --    Just  l -> pure l
 
   lIds <- selectNodesWithUsername NodeList userMaster
-  let ngs = filterListWithRoot listType $ mapTermListRoot [lId] nt repo
+  let ngs = filterListWithRoot [listType] $ mapTermListRoot [lId] nt repo
   -- TODO HashMap
   r <- getNgramsByContextOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
   pure r

src/Gargantext/Core/Viz/Chart.hs

@@ -61,7 +61,7 @@ chartData cId nt lt = do
   ls <- map (_node_id) <$> getListsWithParentId cId
   ts <- mapTermListRoot ls nt <$> getRepo' ls
   let
-    dico = filterListWithRoot lt ts
+    dico = filterListWithRoot [lt] ts
     terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
     group dico' x = case HashMap.lookup x dico' of
         Nothing -> x
@@ -86,7 +86,7 @@ treeData cId nt lt = do
   ts <- mapTermListRoot ls nt <$> getRepo' ls
 
   let
-    dico = filterListWithRoot lt ts
+    dico = filterListWithRoot [lt] ts
     terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
 
   cs' <- getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms

src/Gargantext/Core/Viz/Graph/API.hs

@@ -174,7 +174,7 @@ computeGraph cId method d nt repo = do
   lId  <- defaultList cId
   lIds <- selectNodesWithUsername NodeList userMaster
 
-  let ngs = filterListWithRoot MapTerm
+  let ngs = filterListWithRoot [MapTerm]
           $ mapTermListRoot [lId] nt repo
 
   myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)

src/Gargantext/Database/Action/Flow/Pairing.hs

@@ -16,15 +16,18 @@ module Gargantext.Database.Action.Flow.Pairing
   -- (pairing)
     where
 
+import Debug.Trace (trace)
 import Control.Lens (_Just, (^.))
+import Data.Hashable (Hashable)
 import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HM
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (fromMaybe, catMaybes)
 import Data.Set (Set)
+import Data.Text (Text)
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Ngrams.Types (NgramsTerm(..))
 import Gargantext.API.Prelude (GargNoServer)
 import Gargantext.Core
+import Gargantext.Core.Text.Metrics.CharByChar (levenshtein)
 import Gargantext.Core.Types (TableResult(..))
 import Gargantext.Core.Types.Main
 import Gargantext.Database
@@ -33,18 +36,21 @@ import Gargantext.Database.Admin.Config
 import Gargantext.Database.Admin.Types.Hyperdata -- (HyperdataContact(..))
 import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
 import Gargantext.Database.Query.Prelude (leftJoin2, returnA, queryNodeNodeTable)
+import Gargantext.Database.Query.Table.Node (defaultList)
 import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
 import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
-import Gargantext.Database.Query.Table.Node (defaultList)
+import Gargantext.Database.Query.Table.NodeContext_NodeContext (insertNodeContext_NodeContext)
 import Gargantext.Database.Query.Table.NodeNode (insertNodeNode)
 import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
 import Gargantext.Database.Schema.Node
+-- import Gargantext.Database.Schema.Context
+import qualified Data.HashMap.Strict as HM
 import Gargantext.Prelude hiding (sum)
 import Opaleye
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List           as List
 import qualified Data.Set            as Set
-import qualified Data.Text           as DT
+import qualified Data.Text           as Text
 
 -- | isPairedWith
 -- All NodeAnnuaire paired with a Corpus of NodeId nId:
@@ -65,120 +71,117 @@ isPairedWith nId nt = runOpaQuery (selectQuery nt nId)
         cond (node, node_node) = node^.node_id .== node_node^. nn_node2_id
 
 -----------------------------------------------------------------------
-pairing :: AnnuaireId -> CorpusId -> Maybe ListId -> GargNoServer Int
+pairing :: AnnuaireId -> CorpusId -> Maybe ListId -> GargNoServer [Int]
 pairing a c l' = do
   l <- case l' of
     Nothing -> defaultList c
     Just l'' -> pure l''
-  dataPaired <- dataPairing a (c,l,Authors) takeName takeName
-  r <- insertDB $ prepareInsert dataPaired
-  _ <- insertNodeNode [ NodeNode { _nn_node1_id = c
-                                 , _nn_node2_id = a
-                                 , _nn_score = Nothing
-                                 , _nn_category = Nothing }]
-  pure r
+  dataPaired <- dataPairing a (c,l,Authors)
+  _ <- insertNodeNode [ NodeNode c a Nothing Nothing]
+  insertNodeContext_NodeContext $ prepareInsert c a dataPaired
 
 
 dataPairing :: AnnuaireId
              -> (CorpusId, ListId, NgramsType)
-             -> (ContactName -> Projected)
-             -> (DocAuthor   -> Projected)
              -> GargNoServer (HashMap ContactId (Set DocId))
-dataPairing aId (cId, lId, ngt) fc fa = do
+dataPairing aId (cId, lId, ngt) = do
+  -- mc :: HM.HashMap ContactName (Set ContactId) 
   mc <- getNgramsContactId aId
-  md <- getNgramsDocId cId lId ngt
-
-  printDebug "ngramsContactId" mc
-  printDebug "ngramsDocId"     md
-  let
-    from = projectionFrom (Set.fromList $ HM.keys mc) fc
-    to   = projectionTo   (Set.fromList $ HM.keys md) fa
-
-  pure $ fusion mc $ align from to md
-
-
-
-prepareInsert :: HashMap ContactId (Set DocId) -> [NodeNode]
-prepareInsert m =  map (\(n1,n2) -> NodeNode { _nn_node1_id = n1
-                                             , _nn_node2_id = n2
-                                             , _nn_score = Nothing
-                                             , _nn_category = Nothing })
-                $ List.concat
-                $ map (\(contactId, setDocIds)
-                        -> map (\setDocId
-                                 -> (contactId, setDocId)
-                               ) $ Set.toList setDocIds
-                       )
-                $ HM.toList m
+  -- md :: HM.HashMap DocAuthor   (Set DocId)
+  md <- getNgramsDocId     cId lId ngt
+  -- printDebug "dataPairing authors" (HM.keys md)
+  let result = fusion mc md
+  -- printDebug "dataPairing" (length $ HM.keys result)
+  pure result
+
+
+prepareInsert :: CorpusId -> AnnuaireId -> HashMap ContactId (Set DocId)
+              -> [(CorpusId, AnnuaireId, DocId, ContactId)]
+prepareInsert corpusId annuaireId mapContactDocs =
+  map (\(contactId,docId) -> (corpusId, docId, annuaireId, contactId))
+        $ List.concat
+        $ map (\(contactId, setDocIds)
+                -> map (\setDocId
+                         -> (contactId, setDocId)
+                       ) $ Set.toList setDocIds
+               )
+        $ HM.toList mapContactDocs
 
 ------------------------------------------------------------------------
 type ContactName = NgramsTerm
 type DocAuthor   = NgramsTerm
 type Projected   = NgramsTerm
 
-projectionFrom :: Set ContactName -> (ContactName -> Projected) -> HashMap ContactName Projected
-projectionFrom ss f = HM.fromList $ map (\s -> (s, f s)) (Set.toList ss)  -- use HS.toMap
+fusion :: HashMap ContactName (Set ContactId)
+       -> HashMap DocAuthor   (Set DocId)
+       -> HashMap ContactId   (Set DocId)
+fusion mc md = HM.fromListWith (<>)
+             $ List.concat
+             $ map (\(docAuthor, docs)
+                     -> case (getClosest Text.toLower docAuthor (HM.keys mc)) of
+                          Nothing -> []
+                          Just author -> case HM.lookup author mc of
+                                          Nothing    -> []
+                                          Just contactIds -> map (\contactId -> (contactId, docs))
+                                                                 $ Set.toList contactIds
+                   )
+             $ HM.toList md
+
+fusion'' :: HashMap ContactName (Set ContactId)
+       -> HashMap DocAuthor   (Set DocId)
+       -> HashMap ContactId   (Set DocId)
+fusion'' mc md = hashmapReverse $ fusion' mc (hashmapReverse md)
+
 
-projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> HashMap Projected (Set DocAuthor)
-projectionTo ss f = HM.fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss)  -- use HS.toMap
-------------------------------------------------------------------------
-takeName :: NgramsTerm -> NgramsTerm
-takeName (NgramsTerm texte) = NgramsTerm $ DT.toLower texte'
+fusion' :: HashMap ContactName (Set ContactId)
+       -> HashMap DocId (Set DocAuthor)
+       -> HashMap DocId (Set ContactId)
+fusion' mc md = HM.fromListWith (<>)
+             $ map (\(docId, setAuthors) -> (docId, getContactIds mc $ getClosest' setAuthors (HM.keys mc)))
+             $ HM.toList md
+
+getContactIds :: HashMap ContactName (Set ContactId) -> Set ContactName -> Set ContactId
+getContactIds mapContactNames contactNames =
+  if Set.null contactNames
+     then Set.empty
+     else Set.unions $ catMaybes $ map (\contactName -> HM.lookup contactName mapContactNames) $ Set.toList contactNames
+
+getClosest' :: Set DocAuthor -> [ContactName] -> Set ContactName
+getClosest' setAuthors contactNames = trace (show (setAuthors, setContactNames)) $ setContactNames
   where
-    texte' = maybe texte (\x -> if DT.length x > 3 then x else texte)
-                           (lastName' texte)
-    lastName' = lastMay . DT.splitOn " "
+    setContactNames = if Set.null xs then ys else xs
+    xs = Set.fromList $ catMaybes $ map (\author -> getClosest Text.toLower author contactNames) $ Set.toList setAuthors
+    ys = Set.fromList $ catMaybes $ map (\(NgramsTerm author) -> case ((lastMay . (Text.splitOn " ")) author) of
+                                                      Nothing      -> Nothing
+                                                      Just authorReduced -> getClosest Text.toLower (NgramsTerm authorReduced) contactNames)
+                                  $ Set.toList setAuthors
 
 
-------------------------------------------------------------------------
-align :: HashMap ContactName Projected
-      -> HashMap Projected (Set DocAuthor)
-      -> HashMap DocAuthor (Set DocId)
-      -> HashMap ContactName (Set DocId)
-align mc ma md = HM.fromListWith (<>)
-               $ map (\c -> (c, getProjection md $ testProjection c mc ma))
-               $ HM.keys mc
+getClosest :: (Text -> Text) -> NgramsTerm -> [NgramsTerm] -> Maybe NgramsTerm
+getClosest f (NgramsTerm from) candidates = fst <$> head scored
   where
-    getProjection :: HashMap DocAuthor (Set DocId) -> Set DocAuthor -> Set DocId
-    getProjection ma' sa' =
-      if Set.null sa'
-         then Set.empty
-         else Set.unions $ sets ma' sa'
-           where
-             sets ma'' sa'' = Set.map (\s -> lookup s ma'') sa''
-             lookup s' ma''= fromMaybe Set.empty (HM.lookup s' ma'')
-
-    testProjection :: ContactName
-                   -> HashMap ContactName Projected
-                   -> HashMap Projected (Set DocAuthor)
-                   -> Set DocAuthor
-    testProjection cn' mc' ma' = case HM.lookup cn' mc' of
-      Nothing -> Set.empty
-      Just  c -> case HM.lookup c ma' of
-        Nothing -> Set.empty
-        Just  a -> a
+    scored   = List.sortOn snd
+             $ List.filter (\(_,score) -> score <= 2)
+             $ map (\cand@(NgramsTerm candidate) -> (cand, levenshtein (f from) (f candidate))) candidates
 
-fusion :: HashMap ContactName (Set ContactId)
-       -> HashMap ContactName (Set DocId)
-       -> HashMap ContactId   (Set DocId)
-fusion mc md = HM.fromListWith (<>)
-             $ catMaybes
-             $ [ (,) <$> Just cId <*> HM.lookup cn md
-                      | (cn, setContactId) <- HM.toList mc
-                      , cId <- Set.toList setContactId
-               ]
-------------------------------------------------------------------------
 
+------------------------------------------------------------------------
 getNgramsContactId :: AnnuaireId
                    -> Cmd err (HashMap ContactName (Set NodeId))
 getNgramsContactId aId = do
   contacts <- getAllContacts aId
-  pure $ HM.fromListWith (<>)
-       $ catMaybes
-       $ map (\contact -> (,) <$> (NgramsTerm <$> contact^.(node_hyperdata . hc_who . _Just . cw_lastName))
-                              <*> Just ( Set.singleton (contact^.node_id))
+  -- printDebug "getAllContexts" (tr_count contacts)
+  let paired= HM.fromListWith (<>)
+       $ map (\contact -> (toName contact, Set.singleton (contact^.node_id))
               ) (tr_docs contacts)
-
+  -- printDebug "paired" (HM.keys paired)
+  pure paired
+-- POC here, should be a probabilistic function (see the one used to find lang)
+toName :: Node HyperdataContact -> NgramsTerm
+toName contact = NgramsTerm $ (Text.toTitle $ Text.take 1 firstName) <> ". " <> (Text.toTitle lastName)
+  where
+    firstName = fromMaybe "" $ contact^.(node_hyperdata . hc_who . _Just . cw_firstName)
+    lastName  = fromMaybe "" $ contact^.(node_hyperdata . hc_who . _Just . cw_lastName)
 
 getNgramsDocId :: CorpusId
                 -> ListId
@@ -186,8 +189,15 @@ getNgramsDocId :: CorpusId
                 -> GargNoServer (HashMap DocAuthor (Set NodeId))
 getNgramsDocId cId lId nt = do
   lIds <- selectNodesWithUsername NodeList userMaster
-  repo <- getRepo' lIds
-  let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
-
-  groupNodesByNgrams ngs
-    <$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
+  repo <- getRepo' (lId:lIds)
+  let ngs = filterListWithRoot [MapTerm, CandidateTerm] $ mapTermListRoot (lId:lIds) nt repo
+  -- printDebug "getNgramsDocId" ngs
+
+  groupNodesByNgrams ngs <$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
+
+hashmapReverse :: (Ord a, Eq b, Hashable b)
+        => HashMap a (Set b) -> HashMap b (Set a)
+hashmapReverse m = HM.fromListWith (<>)
+          $ List.concat
+          $ map (\(k,vs) -> [ (v, Set.singleton k) | v <- Set.toList vs])
+          $ HM.toList m

src/Gargantext/Database/Action/Metrics.hs

@@ -234,8 +234,9 @@ getNgrams :: (HasMail env, HasNodeStory env err m)
 getNgrams lId tabType = do
 
   lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo' [lId]
+  -- TODO filterListWithRoot [MapTerm, StopTerm, CandidateTerm] lists
   let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
-                                 [MapTerm, StopTerm, CandidateTerm]
+                                 [[MapTerm], [StopTerm], [CandidateTerm]]
   pure (lists, maybeSyn)
 
 -- Some useful Tools

src/Gargantext/Database/Action/Metrics/NgramsByContext.hs

@@ -172,7 +172,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt tms =
 
 queryNgramsOccurrencesOnlyByContextUser_withSample :: DPS.Query
 queryNgramsOccurrencesOnlyByContextUser_withSample = [sql|
-  WITH nodes_sample AS (SELECT id FROM contexts n TABLESAMPLE SYSTEM_ROWS (?)
+  WITH nodes_sample AS (SELECT n.id FROM contexts n TABLESAMPLE SYSTEM_ROWS (?)
                           JOIN nodes_contexts nn ON n.id = nn.context_id
                             WHERE n.typename  = ?
                             AND nn.node_id = ?),

src/Gargantext/Database/Action/Search.hs

@@ -26,8 +26,8 @@ import Gargantext.Database.Query.Filter
 import Gargantext.Database.Query.Join (leftJoin5)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Context
-import Gargantext.Database.Query.Table.NodeNode
 import Gargantext.Database.Query.Table.NodeContext
+import Gargantext.Database.Query.Table.NodeContext_NodeContext
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Schema.Context
 import Gargantext.Prelude
@@ -41,11 +41,11 @@ searchDocInDatabase :: HasDBid NodeType
                     => ParentId
                     -> Text
                     -> Cmd err [(NodeId, HyperdataDocument)]
-searchDocInDatabase _p t = runOpaQuery (queryDocInDatabase t)
+searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
   where
     -- | Global search query where ParentId is Master Node Corpus Id 
-    queryDocInDatabase :: Text -> O.Select (Column SqlInt4, Column SqlJsonb)
-    queryDocInDatabase q = proc () -> do
+    queryDocInDatabase :: ParentId -> Text -> O.Select (Column SqlInt4, Column SqlJsonb)
+    queryDocInDatabase _p q = proc () -> do
         row <- queryNodeSearchTable -< ()
         restrict -< (_ns_search row)    @@ (sqlTSQuery (unpack q))
         restrict -< (_ns_typename row) .== (sqlInt4 $ toDBid NodeDocument)
@@ -118,11 +118,22 @@ searchInCorpusWithContacts
 searchInCorpusWithContacts cId aId q o l _order =
   runOpaQuery $ limit'   l
               $ offset'  o
-              $ orderBy ( desc _fp_score)
+              $ orderBy (desc _fp_score)
               $ selectGroup cId aId
               $ intercalate " | "
               $ map stemIt q
 
+selectGroup :: HasDBid NodeType
+            => CorpusId
+            -> AnnuaireId
+            -> Text
+            -> Select FacetPairedReadNull
+selectGroup cId aId q = proc () -> do
+  (a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
+                            (selectContactViaDoc cId aId q) -< ()
+  returnA -< FacetPaired a b c d
+
+
 selectContactViaDoc
   :: HasDBid NodeType
   => CorpusId
@@ -134,81 +145,68 @@ selectContactViaDoc
                , Column (Nullable SqlJsonb)
                , Column (Nullable SqlInt4)
                )
-selectContactViaDoc cId aId q = proc () -> do
-  (doc, (corpus_doc, (_contact_doc, (annuaire_contact, contact)))) <- queryContactViaDoc -< ()
-  restrict -< (doc^.ns_search)           @@ (sqlTSQuery  $ unpack q  )
-  restrict -< (doc^.ns_typename)        .== (sqlInt4 $ toDBid NodeDocument)
-  restrict -< (corpus_doc^.nn_node1_id)  .== (toNullable $ pgNodeId cId)
-  restrict -< (annuaire_contact^.nn_node1_id) .== (toNullable $ pgNodeId aId)
-  restrict -< (contact^.node_typename)        .== (toNullable $ sqlInt4 $ toDBid NodeContact)
-  returnA  -< ( contact^.node_id
-              , contact^.node_date
-              , contact^.node_hyperdata
+selectContactViaDoc cId aId query = proc () -> do
+  (doc, (corpus, (_nodeContext_nodeContext, (annuaire, contact)))) <- queryContactViaDoc -< ()
+  restrict -< (doc^.cs_search)             @@ (sqlTSQuery $ unpack query                )
+  restrict -< (doc^.cs_typename)          .== (sqlInt4    $ toDBid NodeDocument         )
+  restrict -< (corpus^.nc_node_id)        .== (toNullable $ pgNodeId cId                )
+  restrict -< (annuaire^.nc_node_id)      .== (toNullable $ pgNodeId aId                )
+  restrict -< (contact^.context_typename) .== (toNullable $ sqlInt4 $ toDBid NodeContact)
+  returnA  -< ( contact^.context_id
+              , contact^.context_date
+              , contact^.context_hyperdata
               , toNullable $ sqlInt4 1
               )
 
-selectGroup :: HasDBid NodeType
-            => NodeId
-            -> NodeId
-            -> Text
-            -> Select FacetPairedReadNull
-selectGroup cId aId q = proc () -> do
-  (a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
-                            (selectContactViaDoc cId aId q) -< ()
-  returnA -< FacetPaired a b c d
-
-
-queryContactViaDoc :: O.Select ( NodeSearchRead
-                               , ( NodeNodeReadNull
-                                 , ( NodeNodeReadNull
-                                   , ( NodeNodeReadNull
-                                     , NodeReadNull
+queryContactViaDoc :: O.Select ( ContextSearchRead
+                               , ( NodeContextReadNull
+                                 , ( NodeContext_NodeContextReadNull
+                                   , ( NodeContextReadNull
+                                     , ContextReadNull
                                      )
                                    )
                                  )
                                )
 queryContactViaDoc =
   leftJoin5
-  queryNodeTable
-  queryNodeNodeTable
-  queryNodeNodeTable
-  queryNodeNodeTable
-  queryNodeSearchTable
+  queryContextTable
+  queryNodeContextTable
+  queryNodeContext_NodeContextTable
+  queryNodeContextTable
+  queryContextSearchTable
   cond12
   cond23
   cond34
   cond45
     where
-      cond12 :: (NodeNodeRead, NodeRead) -> Column SqlBool
-      cond12 (annuaire_contact, contact) = contact^.node_id .== annuaire_contact^.nn_node2_id
+      cond12 :: (NodeContextRead, ContextRead) -> Column SqlBool
+      cond12 (annuaire, contact) = contact^.context_id .== annuaire^.nc_context_id
 
-      cond23 :: ( NodeNodeRead
-                , ( NodeNodeRead
-                  , NodeReadNull
+      cond23 :: ( NodeContext_NodeContextRead
+                , ( NodeContextRead
+                  , ContextReadNull
                   )
                 ) -> Column SqlBool
-      cond23 (contact_doc, (annuaire_contact, _)) = contact_doc^.nn_node1_id .== annuaire_contact^.nn_node2_id
+      cond23 (nodeContext_nodeContext, (annuaire, _)) = nodeContext_nodeContext^.ncnc_nodecontext2 .== annuaire^.nc_id
 
-      cond34 :: ( NodeNodeRead
-                , ( NodeNodeRead
-                  , ( NodeNodeReadNull
-                    , NodeReadNull
+      cond34 :: ( NodeContextRead
+                , ( NodeContext_NodeContextRead
+                  , ( NodeContextReadNull
+                    , ContextReadNull
                     )
                   )
                 ) -> Column SqlBool
-      cond34 (corpus_doc, (contact_doc, (_,_))) =  corpus_doc^.nn_node2_id .== contact_doc^.nn_node2_id
+      cond34 (corpus, (nodeContext_nodeContext, (_,_))) =  nodeContext_nodeContext^.ncnc_nodecontext1 .== corpus^.nc_id
 
 
-      cond45 :: ( NodeSearchRead
-                , ( NodeNodeRead
-                  , ( NodeNodeReadNull
-                    , ( NodeNodeReadNull
-                      , NodeReadNull
+      cond45 :: ( ContextSearchRead
+                , ( NodeContextRead
+                  , ( NodeContext_NodeContextReadNull
+                    , ( NodeContextReadNull
+                      , ContextReadNull
                       )
                     )
                   )
                 ) -> Column SqlBool
-      cond45 (doc, (corpus_doc, (_,(_,_)))) = doc^.ns_id .== corpus_doc^.nn_node2_id
+      cond45 (doc, (corpus, (_,(_,_)))) = doc^.cs_id .== corpus^.nc_context_id
 
-
-------------------------------------------------------------------------

src/Gargantext/Database/Admin/Types/Node.hs

@@ -187,13 +187,13 @@ instance (Arbitrary hyperdata
                         ) where
     --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
     arbitrary = ContextSearch <$> arbitrary
-                           <*> arbitrary
-                           <*> arbitrary
-                           <*> arbitrary
-                           <*> arbitrary
-                           <*> arbitrary
-                           <*> arbitrary
-                           <*> arbitrary
+                              <*> arbitrary
+                              <*> arbitrary
+                              <*> arbitrary
+                              <*> arbitrary
+                              <*> arbitrary
+                              <*> arbitrary
+                              <*> arbitrary
 
 
 
@@ -212,10 +212,13 @@ pgContextId = pgNodeId
 newtype NodeId = NodeId Int
   deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
 
-
--- TODO make another type?
+-- TODO make another type
 type ContextId = NodeId
 
+newtype NodeContextId = NodeContextId Int
+  deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
+
+
 instance GQLType NodeId
 instance Show NodeId where
   show (NodeId n) = "nodeId-" <> show n

src/Gargantext/Database/Query/Table/Context.hs

 {-|
-import Gargantext.Database.Prelude (Cmd, runPGSQuery)
 Module      : Gargantext.Database.Query.Table.Node
 Description : Main Tools of Node to the database
 Copyright   : (c) CNRS, 2017-Present
@@ -9,7 +8,6 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-
 {-# OPTIONS_GHC -fno-warn-orphans        #-}
 
 {-# LANGUAGE Arrows                 #-}
@@ -31,8 +29,8 @@ import Gargantext.Database.Query.Filter (limit', offset')
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Schema.Context
 import Gargantext.Prelude hiding (sum, head)
-import Opaleye hiding (FromField)
-import Prelude hiding (null, id, map, sum)
+import Opaleye            hiding (FromField)
+import Prelude            hiding (null, id, map, sum)
 
 
 getContextWith :: (HasNodeError err, JSONB a)

src/Gargantext/Database/Query/Table/Node/Children.hs

@@ -84,9 +84,9 @@ getChildrenNode pId _ maybeNodeType maybeOffset maybeLimit = do
 
 
 selectChildrenNode :: HasDBid NodeType
-               => ParentId
-               -> Maybe NodeType
-               -> Select NodeRead
+                   => ParentId
+                   -> Maybe NodeType
+                   -> Select NodeRead
 selectChildrenNode parentId maybeNodeType = proc () -> do
     row@(Node _ _ typeName _ parent_id _ _ _) <- queryNodeTable -< ()
     let nodeType = maybe 0 toDBid maybeNodeType
@@ -122,7 +122,7 @@ selectChildren' :: HasDBid NodeType
                -> Select ContextRead
 selectChildren' parentId maybeNodeType = proc () -> do
     row@(Context cid _ typeName _ _ _ _ _) <- queryContextTable     -< ()
-    (NodeContext nid cid' _ _)                    <- queryNodeContextTable -< ()
+    (NodeContext _ nid cid' _ _)           <- queryNodeContextTable -< ()
 
     let nodeType = maybe 0 toDBid maybeNodeType
     restrict -< typeName  .== sqlInt4 nodeType

src/Gargantext/Database/Query/Table/NodeContext.hs

@@ -77,8 +77,9 @@ insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
                           $ Insert nodeContextTable ns' rCount (Just DoNothing))
   where
     ns' :: [NodeContextWrite]
-    ns' = map (\(NodeContext n c x y)
-                -> NodeContext (pgNodeId n)
+    ns' = map (\(NodeContext i n c x y)
+                -> NodeContext (sqlInt4 <$> i)
+                               (pgNodeId n)
                                (pgNodeId c)
                                (sqlDouble <$> x)
                                (sqlInt4  <$> y)
@@ -93,7 +94,7 @@ deleteNodeContext :: Node_Id -> Context_Id -> Cmd err Int
 deleteNodeContext n c = mkCmd $ \conn ->
   fromIntegral <$> runDelete_ conn
                               (Delete nodeContextTable
-                                      (\(NodeContext n_id c_id _ _) -> n_id .== pgNodeId n
+                                      (\(NodeContext _ n_id c_id _ _) -> n_id .== pgNodeId n
                                                                    .&& c_id .== pgNodeId c
                                       )
                                       rCount

src/Gargantext/Database/Query/Table/NodeContext_NodeContext.hs

+{-|
+Module      : Gargantext.Database.Select.Table.NodeContext_NodeContext
+Description : 
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE QuasiQuotes            #-}
+{-# LANGUAGE TemplateHaskell        #-}
+
+module Gargantext.Database.Query.Table.NodeContext_NodeContext
+  ( module Gargantext.Database.Schema.NodeContext_NodeContext
+--  , query_NodeContext_NodeContext_Table
+  , insertNodeContext_NodeContext
+  )
+  where
+
+import Data.Text (Text)
+import Gargantext.Core.Types
+import Gargantext.Database.Prelude
+import Gargantext.Database.Schema.NodeContext_NodeContext
+import Gargantext.Database.Schema.Prelude hiding (sum)
+import Gargantext.Prelude
+import qualified Database.PostgreSQL.Simple as PGS
+
+{-
+queryNodeContext_NodeContextTable :: Select NodeContext_NodeContextRead
+queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
+-}
+
+insertNodeContext_NodeContext :: [(CorpusId, DocId, AnnuaireId, ContactId)] -> Cmd err [Int]
+insertNodeContext_NodeContext contexts = do
+  let
+    fields = map (\t -> QualifiedIdentifier Nothing t) $ snd fields_name
+    fields_name :: ( [Text], [Text])
+    fields_name = ( ["corpus_id", "doc_id", "annuaire_id", "contact_id"]
+                            , ["int4"     , "int4"  , "int4"       , "int4"      ]
+                            )
+  result <- map (\(PGS.Only a) -> a) <$> runPGSQuery queryInsert (PGS.Only $ Values fields contexts)
+  pure [sum result]
+
+queryInsert :: PGS.Query
+queryInsert = [sql|
+  WITH input(corpus_id, doc_id, annuaire_id, contact_id) AS (?)
+  INSERT into nodescontexts_nodescontexts (nodescontexts1, nodescontexts2)
+  SELECT context1.id, context2.id FROM input
+  INNER JOIN nodes_contexts context1 ON context1.node_id = input.corpus_id
+  INNER JOIN nodes_contexts context2 ON context2.node_id = input.annuaire_id
+  WHERE context1.context_id = input.doc_id
+  AND   context2.context_id = input.contact_id
+  ON CONFLICT (nodescontexts1, nodescontexts2) DO Nothing
+  RETURNING 1
+  |]

src/Gargantext/Database/Schema/NodeContext.hs

@@ -26,29 +26,33 @@ import Gargantext.Database.Schema.NodeNode () -- Just importing some instances
 import Gargantext.Prelude
 
 
-data NodeContextPoly node_id context_id score cat
-                   = NodeContext { _nc_node_id     :: !node_id
+data NodeContextPoly id node_id context_id score cat
+                   = NodeContext { _nc_id          :: !id
+                                 , _nc_node_id     :: !node_id
                                  , _nc_context_id  :: !context_id
                                  , _nc_score       :: !score
                                  , _nc_category    :: !cat
                                  } deriving (Show)
 
-type NodeContextWrite     = NodeContextPoly (Column (SqlInt4))
-                                      (Column (SqlInt4))
-                                      (Maybe  (Column (SqlFloat8)))
-                                      (Maybe  (Column (SqlInt4)))
+type NodeContextWrite     = NodeContextPoly (Maybe (Column (SqlInt4)))
+                                            (Column (SqlInt4))
+                                            (Column (SqlInt4))
+                                            (Maybe  (Column (SqlFloat8)))
+                                            (Maybe  (Column (SqlInt4)))
 
 type NodeContextRead      = NodeContextPoly (Column (SqlInt4))
-                                      (Column (SqlInt4))
-                                      (Column (SqlFloat8))
-                                      (Column (SqlInt4))
+                                            (Column (SqlInt4))
+                                            (Column (SqlInt4))
+                                            (Column (SqlFloat8))
+                                            (Column (SqlInt4))
 
 type NodeContextReadNull  = NodeContextPoly (Column (Nullable SqlInt4))
-                                      (Column (Nullable SqlInt4))
-                                      (Column (Nullable SqlFloat8))
-                                      (Column (Nullable SqlInt4))
+                                            (Column (Nullable SqlInt4))
+                                            (Column (Nullable SqlInt4))
+                                            (Column (Nullable SqlFloat8))
+                                            (Column (Nullable SqlInt4))
 
-type NodeContext = NodeContextPoly NodeId NodeId (Maybe Double) (Maybe Int)
+type NodeContext = NodeContextPoly (Maybe Int) NodeId NodeId (Maybe Double) (Maybe Int)
 
 $(makeAdaptorAndInstance "pNodeContext" ''NodeContextPoly)
 makeLenses ''NodeContextPoly
@@ -57,7 +61,8 @@ nodeContextTable :: Table NodeContextWrite NodeContextRead
 nodeContextTable  =
   Table "nodes_contexts"
          ( pNodeContext
-           NodeContext { _nc_node_id    = requiredTableField "node_id"
+           NodeContext { _nc_id         = optionalTableField "id" 
+                       , _nc_node_id    = requiredTableField "node_id"
                        , _nc_context_id = requiredTableField "context_id"
                        , _nc_score      = optionalTableField "score"
                        , _nc_category   = optionalTableField "category"

src/Gargantext/Database/Schema/NodeContext_NodeContext.hs

+{-|
+Module      : Gargantext.Database.Schema.ContextContext
+Description : 
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE QuasiQuotes            #-}
+{-# LANGUAGE TemplateHaskell        #-}
+
+module Gargantext.Database.Schema.NodeContext_NodeContext where
+
+import Gargantext.Core.Types
+import Gargantext.Database.Schema.Prelude
+import Gargantext.Prelude
+
+
+
+data NodeContext_NodeContextPoly nodecontext1 nodecontext2
+                   = NodeContext_NodeContext { _ncnc_nodecontext1 :: !nodecontext1
+                                             , _ncnc_nodecontext2 :: !nodecontext2
+                                    } deriving (Show)
+
+type NodeContext_NodeContextWrite = NodeContext_NodeContextPoly (Column (SqlInt4))
+                                                                (Column (SqlInt4))
+
+type NodeContext_NodeContextRead  = NodeContext_NodeContextPoly (Column (SqlInt4))
+                                                                (Column (SqlInt4))
+
+type NodeContext_NodeContextReadNull  = NodeContext_NodeContextPoly (Column (Nullable SqlInt4))
+                                                                    (Column (Nullable SqlInt4))
+
+type NodeContext_NodeContext = NodeContext_NodeContextPoly NodeContextId NodeContextId
+
+$(makeAdaptorAndInstance "pNodeContext_NodeContext" ''NodeContext_NodeContextPoly)
+makeLenses ''NodeContext_NodeContextPoly
+
+nodeContext_NodeContextTable :: Table NodeContext_NodeContextWrite NodeContext_NodeContextRead
+nodeContext_NodeContextTable =
+  Table "nodescontexts_nodescontexts"
+         ( pNodeContext_NodeContext
+           NodeContext_NodeContext { _ncnc_nodecontext1 = requiredTableField "nodescontexts1"
+                                   , _ncnc_nodecontext2 = requiredTableField "nodescontexts2"
+                                   }
+          )
+queryNodeContext_NodeContextTable :: Query NodeContext_NodeContextRead
+queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
+
+
+

src/Gargantext/Database/Schema/NodeNode.hs

@@ -11,8 +11,6 @@ Here is a longer description of this module, containing some
 commentary with @some markup@.
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 {-# LANGUAGE Arrows                 #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE QuasiQuotes            #-}
@@ -63,18 +61,3 @@ nodeNodeTable  =
                     }
                 )
 
-instance DefaultFromField (Nullable SqlInt4)   Int            where
-    defaultFromField = fromPGSFromField
-
-instance DefaultFromField (Nullable SqlFloat8) Int            where
-    defaultFromField = fromPGSFromField
-
-instance DefaultFromField (Nullable SqlFloat8) Double         where
-    defaultFromField = fromPGSFromField
-
-instance DefaultFromField SqlFloat8            (Maybe Double) where
-    defaultFromField = fromPGSFromField
-
-instance DefaultFromField SqlInt4              (Maybe Int)    where
-    defaultFromField = fromPGSFromField
-

src/Gargantext/Database/Types.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 module Gargantext.Database.Types
@@ -40,3 +41,19 @@ instance HasText a => HasText (Indexed i a)
     hasText (Indexed _ a) = hasText a
 
 instance (Hashable a, Hashable b) => Hashable (Indexed a b)
+
+instance DefaultFromField (Nullable SqlInt4)   Int            where
+    defaultFromField = fromPGSFromField
+
+instance DefaultFromField (Nullable SqlFloat8) Int            where
+    defaultFromField = fromPGSFromField
+
+instance DefaultFromField (Nullable SqlFloat8) Double         where
+    defaultFromField = fromPGSFromField
+
+instance DefaultFromField SqlFloat8            (Maybe Double) where
+    defaultFromField = fromPGSFromField
+
+instance DefaultFromField SqlInt4              (Maybe Int)    where
+    defaultFromField = fromPGSFromField
+