-}
-{-# LANGUAGE QuasiQuotes #-}
--- {-# LANGUAGE Arrows #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE Arrows #-}
module Gargantext.Database.Action.Flow.Pairing
-- (pairing)
where
-import Data.Set (Set)
import Control.Lens (_Just, (^.))
import Data.Map (Map, fromList, fromListWith)
import Data.Maybe (catMaybes, fromMaybe)
-import Data.Text (Text, toLower)
-import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Gargantext.Core.Types (TableResult(..))
+import Data.Set (Set)
+import Data.Text (Text)
+import Gargantext.API.Ngrams.Tools
+import Gargantext.API.Prelude (GargNoServer)
+import Gargantext.Core.Types (TableResult(..), Term)
+import Gargantext.Core.Types.Main
import Gargantext.Database
-import Gargantext.Database.Action.Flow.Utils
+import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+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.Prelude (Cmd, runPGSQuery)
+import Gargantext.Database.Query.Prelude (leftJoin2, returnA, queryNodeNodeTable)
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.NodeNode (insertNodeNode)
import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (sum)
-import Safe (lastMay)
+import Opaleye
import qualified Data.List as List
-import qualified Data.Map as DM
import qualified Data.Map as Map
-import qualified Data.Text as DT
import qualified Data.Set as Set
-
--- TODO mv this type in Types Main
-type Terms = Text
-
-
-
-{-
-pairingPolicy :: (Terms -> Terms)
- -> NgramsT Ngrams
- -> NgramsT Ngrams
-pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
+import qualified Data.Text as DT
-pairMaps :: Map (NgramsT Ngrams) a
- -> Map (NgramsT Ngrams) NgramsId
- -> Map NgramsIndexed (Map NgramsType a)
-pairMaps m1 m2 =
- DM.fromList
- [ (NgramsIndexed ng nId, DM.singleton nt n2i)
- | (k@(NgramsT nt ng),n2i) <- DM.toList m1
- , Just nId <- [DM.lookup k m2]
- ]
--}
+-- | isPairedWith
+-- All NodeAnnuaire paired with a Corpus of NodeId nId:
+-- isPairedWith NodeAnnuaire corpusId
+isPairedWith :: NodeId -> NodeType -> Cmd err [NodeId]
+isPairedWith nId nt = runOpaQuery (selectQuery nt nId)
+ where
+ selectQuery :: NodeType -> NodeId -> Query (Column PGInt4)
+ selectQuery nt' nId' = proc () -> do
+ (node, node_node) <- queryJoin -< ()
+ restrict -< (node^.node_typename) .== (pgInt4 $ nodeTypeId nt')
+ restrict -< (node_node^.nn_node1_id) .== (toNullable $ pgNodeId nId')
+ returnA -< node^.node_id
+
+ queryJoin :: Query (NodeRead, NodeNodeReadNull)
+ queryJoin = leftJoin2 queryNodeTable queryNodeNodeTable cond
+ where
+ cond (node, node_node) = node^.node_id .== node_node^. nn_node2_id
-----------------------------------------------------------------------
-
-pairing :: AnnuaireId -> CorpusId -> ListId -> Cmd err Int
-pairing a c l = do
- dataPaired <- dataPairing a (c,l,Authors) lastName toLower
+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
- pure (fromIntegral r)
+ _ <- insertNodeNode [ NodeNode c a Nothing Nothing]
+ pure r
dataPairing :: AnnuaireId
-> (CorpusId, ListId, NgramsType)
-> (ContactName -> Projected)
-> (DocAuthor -> Projected)
- -> Cmd err (Map ContactId (Set DocId))
+ -> GargNoServer (Map ContactId (Set DocId))
dataPairing aId (cId, lId, ngt) fc fa = do
mc <- getNgramsContactId aId
md <- getNgramsDocId cId lId ngt
+ printDebug "ngramsContactId" mc
+ printDebug "ngramsDocId" md
let
from = projectionFrom (Set.fromList $ Map.keys mc) fc
to = projectionTo (Set.fromList $ Map.keys md) fa
)
$ Map.toList m
-
-
------------------------------------------------------------------------
type ContactName = Text
type DocAuthor = Text
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)
- (lastName' texte)
+takeName :: Term -> Term
+takeName texte = DT.toLower texte'
where
+ texte' = maybe texte (\x -> if DT.length x > 3 then x else texte)
+ (lastName' texte)
lastName' = lastMay . DT.splitOn " "
Nothing -> Set.empty
Just a -> a
-
fusion :: Map ContactName (Set ContactId)
-> Map ContactName (Set DocId)
-> Map ContactId (Set DocId)
-fusion mc md = undefined
-{- fromListWith (<>)
- $ catMaybes
- $ map (\c -> case Map.lookup c mc of
- Nothing -> Nothing
- Just x -> map (\
-
- $ toList mc
--}
+fusion mc md = Map.fromListWith (<>)
+ $ catMaybes
+ $ [ (,) <$> Just cId <*> Map.lookup cn md
+ | (cn, setContactId) <- Map.toList mc
+ , cId <- Set.toList setContactId
+ ]
------------------------------------------------------------------------
getNgramsContactId :: AnnuaireId
<*> Just ( Set.singleton (contact^.node_id))
) (tr_docs contacts)
--- | TODO
--- filter Trash / map Authors
--- Indexing all ngramsType like Authors
-getNgramsDocId :: CorpusId
- -> ListId
- -> NgramsType
- -> Cmd err (Map DocAuthor (Set NodeId))
-getNgramsDocId corpusId listId ngramsType
- = fromListWith (<>)
- <$> map (\(t,nId) -> (t, Set.singleton (NodeId nId)))
- <$> selectNgramsDocId corpusId listId ngramsType
-
-
-selectNgramsDocId :: CorpusId
- -> ListId
- -> NgramsType
- -> Cmd err [(Text, Int)]
-selectNgramsDocId corpusId' listId' ngramsType' =
- runPGSQuery selectQuery (corpusId', listId', ngramsTypeId ngramsType')
- where
- selectQuery = [sql| SELECT ng.terms,nnng.node2_id from ngrams ng
- JOIN node_node_ngrams nnng ON nnng.ngrams_id = ng.id
- JOIN nodes_nodes nn ON nn.node2_id = nnng.node2_id
-
- WHERE nn.node1_id = ?
- AND nnng.node1_id = ?
- AND nnng.ngrams_type = ?
- ;
- |]
+getNgramsDocId :: CorpusId
+ -> ListId
+ -> NgramsType
+ -> GargNoServer (Map DocAuthor (Set NodeId))
+getNgramsDocId cId lId nt = do
+ repo <- getRepo
+ lIds <- selectNodesWithUsername NodeList userMaster
+ let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
+
+ groupNodesByNgrams ngs
+ <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)