[Community Pairing] contacts WIP

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

@@ -38,7 +38,7 @@ if isSame ngramsId ngramsId'
 -- {-# LANGUAGE Arrows #-}
 
 module Gargantext.Database.Action.Flow.Pairing
-  (pairing)
+  -- (pairing)
     where
 
 import Data.Set (Set)
@@ -49,11 +49,12 @@ import Data.Text (Text, toLower)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Core.Types (TableResult(..))
 import Gargantext.Database.Action.Flow.Utils
-import Gargantext.Database.Admin.Types.Node (AnnuaireId, CorpusId, ListId{-, DocId, ContactId-})
+import Gargantext.Database.Admin.Types.Hyperdata -- (HyperdataContact(..))
+import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
 import Gargantext.Database.Prelude (Cmd, runPGSQuery)
 import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
-import Gargantext.Database.Admin.Types.Hyperdata -- (HyperdataContact(..))
 import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
+import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (sum)
 import Safe (lastMay)
 import qualified Data.Map  as DM
@@ -154,38 +155,52 @@ getNgramsTindexed corpusId ngramsType' = fromList
 ------------------------------------------------------------------------
 
 
--- resultPairing ::
+finalPairing :: CorpusId    -> ListId
+             -> CommunityId -> ListId
+             -> Map ContactId (Set DocId)
+finalPairing = undefined
+
+
+-- savePairing
+-- insert ContactId_DocId as NodeNode
+-- then each ContactId could become a corpus with its DocIds
 
+-- searchPairing
+
+------------------------------------------------------------------------
 type ContactName = Text
 type DocAuthor   = Text
 
 data ToProject = ContactName | DocAuthor
+instance Ord ToProject
+instance Eq  ToProject
 
 type Projected  = Text
-
-
 type Projection a = Map a Projected
 
 
 projection :: Set ToProject -> (ToProject -> Projected) -> Projection ToProject
-projection = undefined
+projection ss f = fromList $ map (\s -> (s, f s)) (Set.toList ss)
 
-align :: Projection ContactName      -> Projection DocAuthor
-      -> Map ContactName [ContactId] -> Map DocAuthor [DocId]
+align :: Projection ContactName          -> Projection DocAuthor
+      -> Map ContactName (Set ContactId) -> Map DocAuthor (Set DocId)
       -> Map ContactId (Set DocId)
 align = undefined
 
--- insert ContactId_DocId as NodeNode
--- then each ContactId could become a corpus with its DocIds
-
 
 ------------------------------------------------------------------------
 
+
+
 getNgramsContactId :: AnnuaireId
-                   -> ListId
-                   -- -> ContactType
-                   -> Cmd err (Map Text [Int])
-getNgramsContactId = undefined
+                   -> Cmd err (Map Text (Set NodeId))
+getNgramsContactId aId = do
+  contacts <- getAllContacts aId
+  pure $ fromListWith (<>)
+       $ catMaybes
+       $ map (\contact -> (,) <$> contact^.(node_hyperdata . hc_who . _Just . cw_lastName)
+                              <*> Just ( Set.singleton (contact^.node_id))
+              ) (tr_docs contacts)
 
 -- | TODO
 -- filter Trash / map Authors
@@ -193,10 +208,10 @@ getNgramsContactId = undefined
 getNgramsDocId :: CorpusId
                   -> ListId
                   -> NgramsType
-                  -> Cmd err (Map Text [Int])
+                  -> Cmd err (Map Text (Set Int))
 getNgramsDocId corpusId listId ngramsType
   = fromListWith (<>)
-  <$> map (\(t,nId) -> (t,[nId]))
+  <$> map (\(t,nId) -> (t, Set.singleton nId))
   <$> selectNgramsDocId corpusId listId ngramsType
 
 selectNgramsDocId :: CorpusId

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

@@ -156,7 +156,8 @@ instance Arbitrary NodeId where
   arbitrary = NodeId <$> arbitrary
 
 type ParentId = NodeId
-type CorpusId = NodeId
+type CorpusId    = NodeId
+type CommunityId = NodeId
 type ListId   = NodeId
 type DocumentId = NodeId
 type DocId      = NodeId

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

@@ -30,10 +30,13 @@ import Gargantext.Database.Schema.Node
 import Opaleye
 import Protolude
 
+
+-- TODO getAllTableDocuments
 getAllDocuments :: ParentId -> Cmd err (TableResult (Node HyperdataDocument))
 getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
                                          (Just NodeDocument)
 
+-- TODO getAllTableContacts
 getAllContacts :: ParentId -> Cmd err (TableResult (Node HyperdataContact))
 getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
                                         (Just NodeContact)

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

@@ -70,6 +70,30 @@ getNodeNode n = runOpaQuery (selectNodeNode $ pgNodeId n)
       restrict -< _nn_node1_id ns .== n'
       returnA -< ns
 
+------------------------------------------------------------------------
+-- TODO (refactor with Children)
+{-
+getNodeNodeWith :: NodeId -> proxy a -> Maybe NodeType -> Cmd err [a]
+getNodeNodeWith pId _ maybeNodeType = runOpaQuery query
+  where
+    query = selectChildren pId maybeNodeType
+
+    selectChildren :: ParentId
+                   -> Maybe NodeType
+                   -> Query NodeRead
+    selectChildren parentId maybeNodeType = proc () -> do
+        row@(Node nId typeName _ parent_id _ _ _) <- queryNodeTable -< ()
+        (NodeNode _ n1id n2id _ _) <- queryNodeNodeTable -< ()
+
+        let nodeType = maybe 0 nodeTypeId maybeNodeType
+        restrict -< typeName  .== pgInt4 nodeType
+
+        restrict -< (.||) (parent_id .== (pgNodeId parentId))
+                          ( (.&&) (n1id .== pgNodeId parentId)
+                                  (n2id .== nId))
+        returnA -< row
+-}
+
 ------------------------------------------------------------------------
 insertNodeNode :: [NodeNode] -> Cmd err Int64
 insertNodeNode ns = mkCmd $ \conn -> runInsert_ conn

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

-{-|
-Module      : Gargantext.Database.Query.Table.NodeNode_NodeNode
-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.Query.Table.NodeNode
-  where
-
-import Control.Arrow (returnA)
-import Control.Lens (view, (^.))
-import Data.Maybe (catMaybes)
-import Data.Text (Text, splitOn)
-import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
-import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
-import qualified Opaleye as O
-import Opaleye
-
-import Gargantext.Core.Types
-import Gargantext.Database.Schema.NodeNode_NodeNode
-import Gargantext.Database.Admin.Config (nodeTypeId)
-import Gargantext.Database.Admin.Types.Hyperdata
-import Gargantext.Database.Admin.Types.Node (CorpusId, DocId, pgNodeId)
-import Gargantext.Database.Prelude
-import Gargantext.Database.Schema.Node
-import Gargantext.Prelude
-
-
-queryNodeNode_NodeNodeTable :: Query NodeNode_NodeNodeRead
-queryNodeNode_NodeNodeTable = queryTable nodeNode_NodeNodeTable
-
-------------------------------------------------------------------------
-insertNodeNode_NodeNode :: [NodeNode_NodeNode] -> Cmd err Int64
-insertNodeNode_NodeNode ns = mkCmd $ \conn -> runInsert_ conn
-                          $ Insert nodeNode_NodeNodeTable ns' rCount Nothing
-  where
-    ns' :: [NodeNode_NodeNodeWrite]
-    ns' = map (\(NodeNode_NodeNode nn1 nn2 w)
-                -> NodeNode_NodeNode (pgInt4 nn1)
-                                     (pgInt4 nn1)
-                                     (pgDouble <$> x)
-              ) ns
-
-------------------------------------------------------------------------
--- | TODO delete
---
-
-------------------------------------------------------------------------

src/Gargantext/Database/Schema/NodeNode_NodeNode.hs

-{-|
-Module      : Gargantext.Database.Schema.NodeNode_NodeNode
-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.NodeNode where
-
-import Data.Maybe (Maybe)
-import Gargantext.Core.Types
-import Gargantext.Database.Schema.Prelude
-import Gargantext.Prelude
-
-
-data NodeNode_NodeNodePoly nn1 nn2 weight
-  = NodeNode_NodeNode { _nnnn_nn1_id   :: !nn1
-                      , _nnnn_nn2_id   :: !nn2
-                      , _nnnn_weight   :: !weight
-                      } deriving (Show)
-
-type NodeNodeWrite     = NodeNodePoly (Column (PGInt4))
-                                      (Column (PGInt4))
-                                      (Maybe  (Column (PGFloat8)))
-
-type NodeNodeRead      = NodeNodePoly (Column (PGInt4))
-                                      (Column (PGInt4))
-                                      (Maybe  (Column (PGFloat8)))
-
-type NodeNodeReadNull  = NodeNodePoly (Column (Nullable PGInt4))
-                                      (Column (Nullable PGInt4))
-                                      (Column (Nullable PGFloat8))
-
-type NodeNode_NodeNode = NodeNode_NodeNodePoly Int Int (Maybe Double)
-
-$(makeAdaptorAndInstance "pNodeNode_NodeNode" ''NodeNode_NodeNodePoly)
-makeLenses ''NodeNode_NodeNodePoly
-
-nodeNode_NodeNodeTable :: Table NodeNode_NodeNodeWrite NodeNode_NodeNodeRead
-nodeNode_NodeNodeTable  =
-  Table "nodesnodes_nodesnodes"
-        ( pNodeNode_NodeNode
-          NodeNode_NodeNode { _nnnn_nn1_id = required "nn1_id"
-                            , _nnnn_nn2_id = required "nn2_id"
-                            , _nnnn_weight = optional "weight"
-                            }
-        )