[Community] pairing fun (WIP:90% done + test)

src/Gargantext/API/Node.hs

@@ -282,7 +282,7 @@ type PairWith = Summary "Pair a Corpus with an Annuaire"
 pairWith :: CorpusId -> GargServer PairWith
 pairWith cId aId lId = do
   r <- pairing cId aId lId
-  _ <- insertNodeNode [ NodeNode Nothing cId aId Nothing Nothing]
+  _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
   pure r
 
 ------------------------------------------------------------------------

src/Gargantext/Database.hs

@@ -16,6 +16,7 @@ Gargantext's database.
 
 
 module Gargantext.Database ( module Gargantext.Database.Prelude
+                           , module Gargantext.Database.Schema.NodeNode
                            , insertDB
                         -- , module Gargantext.Database.Bashql
                            )
@@ -24,10 +25,10 @@ module Gargantext.Database ( module Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Gargantext.Database.Prelude -- (connectGargandb)
 
-import Gargantext.Database.Schema.Node
-import Gargantext.Database.Query.Table.Node
+-- import Gargantext.Database.Schema.Node
+-- import Gargantext.Database.Query.Table.Node
 
-import Gargantext.Database.Schema.NodeNode
+import Gargantext.Database.Schema.NodeNode -- (NodeNode(..))
 import Gargantext.Database.Query.Table.NodeNode
 
 

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

@@ -23,6 +23,7 @@ import Data.Maybe (catMaybes, fromMaybe)
 import Data.Text (Text, toLower)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Core.Types (TableResult(..))
+import Gargantext.Database
 import Gargantext.Database.Action.Flow.Utils
 import Gargantext.Database.Admin.Types.Hyperdata -- (HyperdataContact(..))
 import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
@@ -32,6 +33,7 @@ import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (sum)
 import Safe (lastMay)
+import qualified Data.List as List
 import qualified Data.Map  as DM
 import qualified Data.Map  as Map
 import qualified Data.Text as DT
@@ -40,52 +42,14 @@ import qualified Data.Set  as Set
 -- TODO mv this type in Types Main
 type Terms = Text
 
-{-
-pairing'' :: (CorpusId, CorpusId) -> (DocId -> DocId)
-pairing'' = undefined
-
-pairing' :: (CorpusId, AnnuaireId) -> (DocId -> ContactId)
-pairing' = undefined
--}
-
--- | TODO : add paring policy as parameter
-pairing :: CorpusId   -- (CorpusId,   ListId) -- Pair (Either CorpusId AnnuaireId) ListId
-        -> AnnuaireId -- (AnnuaireId, ListId) -- Pair (Either CorpusId AnnuaireId) ListId
-        -> ListId
-        -> Cmd err Int
-pairing cId aId lId = do
-  contacts'       <- getAllContacts aId
-  let contactsMap = pairingPolicyToMap toLower
-                  $ toMaps extractNgramsT (tr_docs contacts')
-
-  ngramsMap'    <- getNgramsTindexed cId Authors
-  let ngramsMap = pairingPolicyToMap lastName ngramsMap'
-
-  let indexedNgrams = pairMaps contactsMap ngramsMap
-
-  insertDocNgrams lId indexedNgrams
-
--- TODO: this method is dangerous (maybe equalities of the result are
--- not taken into account emergency demo plan...)
-pairingPolicyToMap :: (Terms -> Terms)
-                   -> Map (NgramsT Ngrams) a
-                   -> Map (NgramsT Ngrams) a
-pairingPolicyToMap f = DM.mapKeys (pairingPolicy f)
 
 
+{-
 pairingPolicy :: (Terms -> Terms)
               -> NgramsT Ngrams
               -> NgramsT Ngrams
 pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
 
--- | TODO : use Occurrences in place of Int
-extractNgramsT :: HyperdataContact
-               -> Map (NgramsT Ngrams) Int
-extractNgramsT contact = fromList [(NgramsT Authors    a' , 1)| a' <- authors    ]
-  where
-    authors    = map text2ngrams
-               $ catMaybes [ contact^.(hc_who . _Just . cw_lastName) ]
-
 
 pairMaps :: Map (NgramsT Ngrams) a
          -> Map (NgramsT Ngrams) NgramsId
@@ -96,39 +60,45 @@ pairMaps m1 m2 =
     | (k@(NgramsT nt ng),n2i) <- DM.toList m1
     , Just nId <- [DM.lookup k m2]
     ]
+-}
 
 -----------------------------------------------------------------------
-getNgramsTindexed :: CorpusId
-                  -> NgramsType
-                  -> Cmd err (Map (NgramsT Ngrams) NgramsId)
-getNgramsTindexed corpusId ngramsType' = fromList
-    <$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
-    <$> selectNgramsTindexed corpusId ngramsType'
-  where
-    selectNgramsTindexed :: CorpusId
-                         -> NgramsType
-                         -> Cmd err [(NgramsId, Terms, Int)]
-    selectNgramsTindexed corpusId' ngramsType'' = runPGSQuery selectQuery (corpusId', ngramsTypeId ngramsType'')
-      where
-        selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
-                      JOIN node_node_ngrams occ ON occ.ngrams_id = n.id
-                      -- JOIN node_node_ngrams2 occ ON occ.ngrams_id = n.id
-                      JOIN nodes_nodes      nn  ON nn.node2_id   = occ.node2_id
 
-                      WHERE nn.node1_id     = ?
-                        AND occ.ngrams_type = ?
-                        AND occ.node2_id = nn.node2_id
-                      GROUP BY n.id;
-                     |]
+pairing :: AnnuaireId -> CorpusId -> ListId -> Cmd err Int
+pairing a c l = do
+  dataPaired <- dataPairing a (c,l,Authors) lastName toLower
+  r <- insertDB $ prepareInsert dataPaired
+  pure (fromIntegral r)
+
+
+dataPairing :: AnnuaireId
+             -> (CorpusId, ListId, NgramsType)
+             -> (ContactName -> Projected)
+             -> (DocAuthor   -> Projected)
+             -> Cmd err (Map ContactId (Set DocId))
+dataPairing aId (cId, lId, ngt) fc fa = do
+  mc <- getNgramsContactId aId
+  md <- getNgramsDocId cId lId ngt
+
+  let
+    from = projectionFrom (Set.fromList $ Map.keys mc) fc
+    to   = projectionTo   (Set.fromList $ Map.keys md) fa
+
+  pure $ fusion mc $ align from to md
 
-------------------------------------------------------------------------
 
 
--- savePairing
--- insert ContactId_DocId as NodeNode
--- then each ContactId could become a corpus with its DocIds
+prepareInsert :: Map ContactId (Set DocId) -> [NodeNode]
+prepareInsert m =  map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing)
+                $ List.concat
+                $ map (\(contactId, setDocIds)
+                        -> map (\setDocId
+                                 -> (contactId, setDocId)
+                               ) $ Set.toList setDocIds
+                       )
+                $ Map.toList m
+
 
--- searchPairing
 
 ------------------------------------------------------------------------
 type ContactName = Text
@@ -140,9 +110,8 @@ projectionFrom ss f = fromList $ map (\s -> (s, f s)) (Set.toList ss)
 
 projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> Map Projected (Set DocAuthor)
 projectionTo ss f = fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss)
-------------------------------------------------------------------------
-
 
+------------------------------------------------------------------------
 lastName :: Terms -> Terms
 lastName texte = DT.toLower
                $ maybe texte (\x -> if DT.length x > 3 then x else texte)
@@ -151,13 +120,7 @@ lastName texte = DT.toLower
     lastName' = lastMay . DT.splitOn " "
 
 
-
-
-
-
 ------------------------------------------------------------------------
-
-
 align :: Map ContactName Projected
       -> Map Projected (Set DocAuthor)
       -> Map DocAuthor (Set DocId)
@@ -198,24 +161,6 @@ fusion mc md = undefined
 
        $ toList mc
 -}
-
-finalPairing :: AnnuaireId
-             -> (CorpusId, ListId, NgramsType)
-             -> (ContactName -> Projected)
-             -> (DocAuthor   -> Projected)
-             -> Cmd err (Map ContactId (Set DocId))
-finalPairing aId (cId, lId, ngt) fc fa = do
-  mc <- getNgramsContactId aId
-  md <- getNgramsDocId cId lId ngt
-
-  let
-    from = projectionFrom (Set.fromList $ Map.keys mc) fc
-    to   = projectionTo   (Set.fromList $ Map.keys md) fa
-
-  pure $ fusion mc $ align from to md
-
-
-
 ------------------------------------------------------------------------
 
 getNgramsContactId :: AnnuaireId

src/Gargantext/Database/Action/Share.hs

@@ -56,7 +56,7 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
         then errorWith "[G.D.A.S.shareNodeWith] Can share to others only"
         else do
           folderSharedId  <- getFolderId u NodeFolderShared
-          insertNodeNode [NodeNode Nothing folderSharedId n Nothing Nothing]
+          insertNodeNode [NodeNode folderSharedId n Nothing Nothing]
 
 shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
   nodeToCheck <- getNode n
@@ -66,7 +66,7 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
     else do
       folderToCheck <- getNode nId
       if hasNodeType folderToCheck NodeFolderPublic
-         then insertNodeNode [NodeNode Nothing nId n Nothing Nothing]
+         then insertNodeNode [NodeNode nId n Nothing Nothing]
          else errorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
 
 shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"

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

@@ -73,7 +73,7 @@ selectChildren :: ParentId
                -> Query NodeRead
 selectChildren parentId maybeNodeType = proc () -> do
     row@(Node nId typeName _ parent_id _ _ _) <- queryNodeTable -< ()
-    (NodeNode _ n1id n2id _ _) <- queryNodeNodeTable -< ()
+    (NodeNode n1id n2id _ _) <- queryNodeNodeTable -< ()
 
     let nodeType = maybe 0 nodeTypeId maybeNodeType
     restrict -< typeName  .== pgInt4 nodeType

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

@@ -100,9 +100,8 @@ insertNodeNode ns = mkCmd $ \conn -> runInsert_ conn
                           $ Insert nodeNodeTable ns' rCount Nothing
   where
     ns' :: [NodeNodeWrite]
-    ns' = map (\(NodeNode n n1 n2 x y)
-                -> NodeNode (pgInt4   <$> n)
-                            (pgNodeId n1)
+    ns' = map (\(NodeNode n1 n2 x y)
+                -> NodeNode (pgNodeId n1)
                             (pgNodeId n2)
                             (pgDouble <$> x)
                             (pgInt4   <$> y)
@@ -115,7 +114,7 @@ type Node2_Id = NodeId
 deleteNodeNode :: Node1_Id -> Node2_Id -> Cmd err Int
 deleteNodeNode n1 n2 = mkCmd $ \conn ->
   fromIntegral <$> runDelete conn nodeNodeTable
-                 (\(NodeNode _ n1_id n2_id _ _) -> n1_id .== pgNodeId n1
+                 (\(NodeNode n1_id n2_id _ _) -> n1_id .== pgNodeId n1
                                              .&& n2_id .== pgNodeId n2 )
 
 ------------------------------------------------------------------------

src/Gargantext/Database/Schema/NodeNode.hs

@@ -26,49 +26,44 @@ import Gargantext.Database.Schema.Prelude
 import Gargantext.Prelude
 
 
-data NodeNodePoly n node1_id node2_id score cat
-                   = NodeNode { _nn_id         :: !n
-                              , _nn_node1_id   :: !node1_id
+data NodeNodePoly node1_id node2_id score cat
+                   = NodeNode { _nn_node1_id   :: !node1_id
                               , _nn_node2_id   :: !node2_id
                               , _nn_score      :: !score
                               , _nn_category   :: !cat
                               } deriving (Show)
 
-type NodeNodeWrite     = NodeNodePoly (Maybe  (Column (PGInt4)))
-                                      (Column (PGInt4))
+type NodeNodeWrite     = NodeNodePoly (Column (PGInt4))
                                       (Column (PGInt4))
                                       (Maybe  (Column (PGFloat8)))
                                       (Maybe  (Column (PGInt4)))
 
 type NodeNodeRead      = NodeNodePoly (Column (PGInt4))
-                                      (Column (PGInt4))
                                       (Column (PGInt4))
                                       (Column (PGFloat8))
                                       (Column (PGInt4))
 
 type NodeNodeReadNull  = NodeNodePoly (Column (Nullable PGInt4))
-                                      (Column (Nullable PGInt4))
                                       (Column (Nullable PGInt4))
                                       (Column (Nullable PGFloat8))
                                       (Column (Nullable PGInt4))
 
-type NodeNode = NodeNodePoly (Maybe Int) NodeId NodeId (Maybe Double) (Maybe Int)
+type NodeNode = NodeNodePoly NodeId NodeId (Maybe Double) (Maybe Int)
 
 $(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
 makeLenses ''NodeNodePoly
 
 nodeNodeTable :: Table NodeNodeWrite NodeNodeRead
-nodeNodeTable  = Table "nodes_nodes" (pNodeNode
-                                NodeNode { _nn_id       = optional "id"
-                                         , _nn_node1_id = required "node1_id"
+nodeNodeTable  =
+  Table "nodes_nodes"
+         ( pNodeNode
+           NodeNode { _nn_node1_id = required "node1_id"
                     , _nn_node2_id = required "node2_id"
                     , _nn_score    = optional "score"
                     , _nn_category = optional "category"
                     }
                 )
 
-
-
 instance QueryRunnerColumnDefault (Nullable PGInt4)   Int            where
     queryRunnerColumnDefault = fieldQueryRunnerColumn