[PAIRING] pairing (quite tested but not roughly). Need to add list to the...

[PAIRING] pairing (quite tested but not roughly). Need to add list to the pairing flow (Annuaire creation).

src/Gargantext/Core/Types/Main.hs

@@ -32,7 +32,7 @@ import Data.Monoid ((<>))
 import Data.Text (Text)
 import Data.Swagger
 
-import Gargantext.Database.Types.Node
+import Gargantext.Database.Types.Node  -- (NodeType(..), Node, Hyperdata(..))
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Prelude
 
@@ -81,9 +81,23 @@ corpusTree nId t  = TreeN (NodeTree ("Corpus " <> t)  NodeCorpus nId) (  [ leafT
 
 --data Classification = Favorites | MyClassifcation
 
+type UserId   = Int
+type MasterUserId = Int
 
-type CorpusId = Int
-type ListId = Int
+type RootId   = Int
+type MasterCorpusId = Int
+
+type HashId   = Text
+
+type AnnuaireId = NodeId
+type ContactId  = NodeId
+
+type CorpusId   = NodeId
+type DocumentId = NodeId
+type DocId      = DocumentId -- todo: remove this
+
+type ListId     = NodeId
+type TypeId     = Int
 
 -- TODO multiple ListType declaration, remove it
 data ListType  =  StopList  | CandidateList | GraphList

src/Gargantext/Database/Flow.hs

@@ -23,14 +23,13 @@ import Data.Text (Text, splitOn)
 import Data.Map (Map, lookup)
 import Data.Tuple.Extra (both, second)
 import qualified Data.Map as DM
-
 import Gargantext.Core.Types (NodePoly(..), ListType(..), listTypeId)
 import Gargantext.Database.Bashql (runCmd') -- , del)
 import Gargantext.Database.Config (userMaster, userArbitrary, corpusMasterName)
-import Gargantext.Database.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, ngramsTypeId, NgramsType(..), text2ngrams)
+import Gargantext.Database.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT,  NgramsType(..), text2ngrams)
 import Gargantext.Database.Node (mkRoot, mkCorpus, Cmd(..), mkList, mkGraph, mkDashboard, mkAnnuaire)
 import Gargantext.Database.Root (getRootCmd)
-import Gargantext.Database.Types.Node (NodeType(..))
+import Gargantext.Database.Types.Node (NodeType(..), NodeId)
 import Gargantext.Database.Node.Document.Add    (add)
 import Gargantext.Database.Node.Document.Insert (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
 import Gargantext.Database.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
@@ -43,13 +42,8 @@ import Gargantext.Ext.IMT (toSchoolName)
 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
 import Gargantext.Prelude
 import Gargantext.Text.Parsers (parseDocs, FileFormat)
-
-type UserId   = Int
-type MasterUserId = Int
-
-type RootId   = Int
-type CorpusId = Int
-type MasterCorpusId = Int
+import Gargantext.Core.Types.Main
+import Gargantext.Database.Flow.Utils (insertToNodeNgrams)
 
 flowDatabase :: FileFormat -> FilePath -> CorpusName -> IO CorpusId
 flowDatabase ff fp cName = do
@@ -95,16 +89,11 @@ flowInsertAnnuaire name children = do
 
   pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
 
-
---}
-
---{-
 flowCorpus :: NodeType
                         -> [HyperdataDocument]
                         -> ([ReturnId], UserId, CorpusId, UserId, CorpusId)
                         -> IO CorpusId
 flowCorpus NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, userId,userCorpusId) = do
---}
 --------------------------------------------------
   -- List Ngrams Flow
   userListId <- runCmd' $ listFlowUser userId userCorpusId
@@ -195,11 +184,6 @@ subFlowAnnuaire username _cName = do
 
 
 ------------------------------------------------------------------------
-
-type HashId   = Text
-type NodeId   = Int
-type ListId   = Int
-
 toInsert :: [HyperdataDocument] -> Map HashId HyperdataDocument
 toInsert = DM.fromList . map (\d -> (maybe err identity (_hyperdataDocument_uniqId d), d))
   where
@@ -263,14 +247,6 @@ indexNgrams ng2nId = do
   pure $ DM.mapKeys (indexNgramsT terms2id) ng2nId
 
 
-insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd Int
-insertToNodeNgrams m = insertNodeNgrams [ NodeNgram Nothing nId  ((_ngramsId    . _ngramsT   ) ng)
-                                                (fromIntegral n) ((ngramsTypeId . _ngramsType) ng)
-                                          | (ng, nId2int) <- DM.toList m
-                                          , (nId, n)      <- DM.toList nId2int
-                                        ]
-
-
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 listFlow :: UserId -> CorpusId -> Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd ListId

src/Gargantext/Database/Flow/Pairing.hs

+{-|
+Module      : Gargantext.Database.Flow
+Description : Database Flow
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE QuasiQuotes            #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- {-# LANGUAGE Arrows #-}
+
+module Gargantext.Database.Flow.Pairing
+    where
+
+import Debug.Trace (trace)
+import Control.Lens (view,_Just)
+import Database.PostgreSQL.Simple (Connection, query)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+-- import Opaleye
+-- import Opaleye.Aggregate
+-- import Control.Arrow (returnA)
+import Data.Maybe (catMaybes)
+import Data.Map (Map, fromList)
+import Safe (lastMay)
+import qualified Data.Map as DM
+import Data.Text (Text, toLower)
+import qualified Data.Text as DT
+import Gargantext.Prelude hiding (sum)
+import Gargantext.Database.Ngrams -- (NgramsType(..))
+--import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
+--import Gargantext.Database.Types.Node -- (Hyperdata(..))
+import Gargantext.Database.Node.Contact
+import Gargantext.Database.Flow.Utils
+import Gargantext.Database.Node (Cmd, mkCmd)
+import Gargantext.Database.Node.Children
+import Gargantext.Core.Types.Main
+import Gargantext.Core.Types (NodeType(..))
+import Gargantext.Database.Bashql (runCmd')
+
+-- TODO mv this type in Types Main
+type Terms = Text
+
+-- | TODO : add paring policy as parameter
+pairing :: AnnuaireId -> CorpusId -> IO Int
+pairing aId cId = do
+  contacts' <- runCmd' $ getContacts aId (Just NodeContact)
+  let contactsMap = pairingPolicyToMap toLower $ toMaps extractNgramsT contacts'
+  
+  ngramsMap' <- runCmd' $ getNgramsTindexed cId Authors
+  let ngramsMap = pairingPolicyToMap lastName ngramsMap'
+
+  let indexedNgrams = pairMaps contactsMap ngramsMap
+  
+  runCmd' $ insertToNodeNgrams indexedNgrams
+  -- TODO add List
+
+lastName :: Terms -> Terms
+lastName texte = DT.toLower $ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
+  where
+    lastName' = lastMay . DT.splitOn " "
+
+-- TODO: this methods 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 [view (hc_who . _Just . cw_lastName) contact]
+--}
+
+
+pairMaps :: Map (NgramsT Ngrams) (Map ContactId Int)
+         -> Map (NgramsT Ngrams) NgramsId
+         -> Map (NgramsT NgramsIndexed) (Map ContactId Int)
+pairMaps m1 m2 = DM.fromList $ catMaybes $ map (\(k,n) -> (,) <$> lookup' k m2 <*> Just n) $ DM.toList m1
+  where
+    lookup' k@(NgramsT nt ng) m = case DM.lookup k m of
+        Nothing -> Nothing
+        Just nId -> Just $ NgramsT nt (NgramsIndexed ng nId)
+
+
+-----------------------------------------------------------------------
+getNgramsTindexed:: CorpusId -> NgramsType -> Cmd (Map (NgramsT Ngrams) NgramsId)
+getNgramsTindexed corpusId ngramsType' = mkCmd $ \c -> fromList
+    <$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
+    <$> selectNgramsTindexed c corpusId ngramsType'
+
+selectNgramsTindexed :: Connection -> CorpusId -> NgramsType -> IO [(NgramsId, Terms, Int)]
+selectNgramsTindexed c corpusId ngramsType'' = query c selectQuery (corpusId, ngramsTypeId ngramsType'')
+  where
+    selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
+                  JOIN nodes_ngrams occ ON occ.ngram_id = n.id
+                  JOIN nodes_nodes  nn  ON nn.node2_id = occ.node_id
+                  
+                  WHERE nn.node1_id     = ?
+                    AND occ.ngrams_type = ?
+                    AND occ.node_id = nn.node2_id
+                  GROUP BY n.id;
+                 |]
+
+{- | TODO more typed SQL queries
+selectNgramsTindexed :: CorpusId -> NgramsType -> Query NgramsRead
+selectNgramsTindexed corpusId ngramsType = proc () -> do
+    nodeNode   <- queryNodeNodeTable     -< ()
+    nodeNgrams <- queryNodesNgramsTable  -< ()
+    ngrams     <- queryNgramsTable       -< ()
+
+    restrict -< node1_id nodeNode .== pgInt4 corpusId
+    restrict -< node2_id nodeNode .== node_id nodeNgrams
+    restrict -< ngrams_id ngrams  .== node_ngrams nodeNgrams
+
+    result <- aggregate groupBy (ngrams_id ngrams)
+    returnA -< result
+--}
+
+

src/Gargantext/Database/Flow/Utils.hs

+{-|
+Module      : Gargantext.Database.Flow.Utils
+Description : Database Flow
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Database.Flow.Utils
+    where
+
+import Data.Map (Map)
+import qualified Data.Map as DM
+import Gargantext.Prelude
+import Gargantext.Database.Ngrams
+import Gargantext.Database.Types.Node (NodeId, Node, NodePoly(..), Hyperdata)
+import Gargantext.Database.Node  -- (Cmd)
+import Gargantext.Database.NodeNgram
+
+toMaps :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int) -> [Node a] -> Map (NgramsT Ngrams) (Map NodeId Int)
+toMaps fun ns = mapNodeIdNgrams $ documentIdWithNgrams fun ns'
+  where
+    ns' = map (\(Node nId _ _ _ _ _ json) -> DocumentWithId nId json) ns
+
+mapNodeIdNgrams :: Hyperdata a => [DocumentIdWithNgrams a] -> Map (NgramsT Ngrams) (Map NodeId Int)
+mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
+  where
+    xs  = [(ng, [(nId, i)]) | (nId, n2i') <- n2i ds, (ng, i) <- DM.toList n2i']
+    n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
+
+
+documentIdWithNgrams :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int)
+                                     -> [DocumentWithId a] -> [DocumentIdWithNgrams a]
+documentIdWithNgrams f = map (\d -> DocumentIdWithNgrams d ((f . documentData) d))
+
+
+data DocumentWithId a =
+     DocumentWithId { documentId   :: NodeId
+                    , documentData :: a
+                    } deriving (Show)
+
+
+data DocumentIdWithNgrams a =
+     DocumentIdWithNgrams
+     { documentWithId  :: DocumentWithId a
+     , document_ngrams :: Map (NgramsT Ngrams) Int
+     } deriving (Show)
+
+
+insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd Int
+insertToNodeNgrams m = insertNodeNgrams [ NodeNgram Nothing nId  ((_ngramsId    . _ngramsT   ) ng)
+                                                (fromIntegral n) ((ngramsTypeId . _ngramsType) ng)
+                                          | (ng, nId2int) <- DM.toList m
+                                          , (nId, n)      <- DM.toList nId2int
+                                        ]
+
+

src/Gargantext/Database/Ngrams.hs

@@ -23,6 +23,11 @@ Ngrams connection to the Database.
 
 module Gargantext.Database.Ngrams where
 
+
+import Database.PostgreSQL.Simple as DPS (Connection)
+--import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+--import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+--import Opaleye
 import Control.Lens (makeLenses, view)
 import Data.ByteString.Internal (ByteString)
 import Data.Map (Map, fromList, lookup, fromListWith)
@@ -46,36 +51,38 @@ import Prelude (Enum, Bounded, minBound, maxBound)
 import qualified Data.Set as DS
 import qualified Database.PostgreSQL.Simple as DPS
 
---data NgramPoly id terms n = NgramDb { ngram_id    :: id
---                                    , ngram_terms :: terms
---                                    , ngram_n     :: n
---                                    } deriving (Show)
---
---type NgramWrite = NgramPoly (Maybe (Column PGInt4))
---                                   (Column PGText)
---                                   (Column PGInt4)
---
---type NgramRead  = NgramPoly        (Column PGInt4)
---                                   (Column PGText)
---                                   (Column PGInt4)
---
-----type Ngram = NgramPoly Int Text Int
---
--- $(makeAdaptorAndInstance "pNgram"    ''NgramPoly)
--- $(makeLensesWith abbreviatedFields   ''NgramPoly)
---
---ngramTable :: Table NgramWrite NgramRead
---ngramTable = Table "ngrams" (pNgram NgramDb { ngram_id    = optional "id"
---                                            , ngram_terms = required "terms"
---                                            , ngram_n     = required "n"
---                                            }
---                                )
---
---queryNgramTable :: Query NgramRead
---queryNgramTable = queryTable ngramTable
---
---dbGetNgrams :: PGS.Connection -> IO [NgramDb]
---dbGetNgrams conn = runQuery conn queryNgramTable
+{-
+data NgramPoly id terms n = NgramDb { ngram_id    :: id
+                                    , ngram_terms :: terms
+                                    , ngram_n     :: n
+                                    } deriving (Show)
+
+type NgramWrite = NgramPoly (Maybe (Column PGInt4))
+                                   (Column PGText)
+                                   (Column PGInt4)
+
+type NgramRead  = NgramPoly        (Column PGInt4)
+                                   (Column PGText)
+                                   (Column PGInt4)
+
+--type Ngram = NgramPoly Int Text Int
+
+$(makeAdaptorAndInstance "pNgram"    ''NgramPoly)
+$(makeLensesWith abbreviatedFields   ''NgramPoly)
+
+ngramTable :: Table NgramWrite NgramRead
+ngramTable = Table "ngrams" (pNgram NgramDb { ngram_id    = optional "id"
+                                            , ngram_terms = required "terms"
+                                            , ngram_n     = required "n"
+                                            }
+                                )
+
+queryNgramTable :: Query NgramRead
+queryNgramTable = queryTable ngramTable
+
+dbGetNgrams :: DPS.Connection -> IO [NgramDb]
+dbGetNgrams conn = runQuery conn queryNgramTable
+-}
 
 -- | Main Ngrams Types
 -- | Typed Ngrams

src/Gargantext/Database/Node.hs

@@ -41,6 +41,7 @@ import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
 import Gargantext.Database.Queries
 import Gargantext.Database.Config (nodeTypeId)
 import Gargantext.Prelude hiding (sum)
+import Gargantext.Core.Types.Main (UserId)
 
 import Control.Applicative (Applicative)
 import Control.Arrow (returnA)
@@ -84,11 +85,6 @@ mkCmd :: (Connection -> IO a) -> Cmd a
 mkCmd = Cmd . ReaderT
 
 ------------------------------------------------------------------------
-type AnnuaireId = Int
-
-type DocId  = Int
-type UserId = Int
-type TypeId = Int
 ------------------------------------------------------------------------
 instance FromField HyperdataAny
   where

src/Gargantext/Database/Node/Children.hs

@@ -24,10 +24,15 @@ import Gargantext.Database.Node
 import Gargantext.Database.NodeNode
 import Gargantext.Database.Config (nodeTypeId)
 import Gargantext.Database.Queries
+import Gargantext.Database.Node.Contact (HyperdataContact)
 import Control.Arrow (returnA)
 
-getChildren :: JSONB a => Connection -> ParentId -> proxy a -> Maybe NodeType
-            -> Maybe Offset -> Maybe Limit -> IO [Node a]
+-- | TODO: use getChildren with Proxy ?
+getContacts :: ParentId -> Maybe NodeType -> Cmd [Node HyperdataContact]
+getContacts pId maybeNodeType = mkCmd $ \c -> runQuery c $ selectChildren pId maybeNodeType
+
+
+getChildren :: JSONB a => Connection -> ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [Node a]
 getChildren c pId _ maybeNodeType maybeOffset maybeLimit = runQuery c 
                   $ limit' maybeLimit $ offset' maybeOffset
                   $ orderBy (asc _node_id)

src/Gargantext/Database/Node/Contact.hs

@@ -28,7 +28,8 @@ import Data.Time (UTCTime)
 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 import GHC.Generics (Generic)
 import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.Node (NodeWrite', AnnuaireId, UserId, Name, node)
+import Gargantext.Core.Types.Main (AnnuaireId, UserId)
+import Gargantext.Database.Node (NodeWrite', Name, node)
 import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..))
 import Gargantext.Database.Utils (fromField')
 import Gargantext.Prelude

src/Gargantext/Database/NodeNode.hs

@@ -30,8 +30,8 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
 import Data.Maybe (Maybe)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Gargantext.Database.Node (Cmd(..), mkCmd, DocId)
-import Gargantext.Core.Types (CorpusId)
+import Gargantext.Database.Node (Cmd(..), mkCmd)
+import Gargantext.Core.Types.Main (CorpusId, DocId)
 import Gargantext.Prelude
 import Opaleye
 

src/Gargantext/Database/Types/Node.hs

@@ -56,6 +56,7 @@ import           Test.QuickCheck (elements)
 import           Gargantext.Prelude
 import           Gargantext.Core.Utils.Prefix (unPrefix)
 ------------------------------------------------------------------------
+type NodeId = Int
 
 type UTCTime' = UTCTime
 
@@ -327,7 +328,6 @@ type Node json   = NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) No
 
 -- type Node json   = NodePoly NodeId NodeTypeId UserId ParentId NodeName UTCTime json
 type NodeTypeId   = Int
-type NodeId       = Int
 type NodeParentId = Int
 type NodeUserId   = Int
 type NodeName     = Text