Skip to content

haskell-gargantext
haskell-gargantext
Commit 24e7808e authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

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

parent 9b208ef5
Hide whitespace changes
Inline Side-by-side
Showing with 61 additions and 121 deletions
src/Gargantext/API/Node.hs
View file @ 24e7808e
......@@ -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
View file @ 24e7808e
......@@ -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
View file @ 24e7808e
......@@ -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
View file @ 24e7808e
......@@ -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
View file @ 24e7808e
......@@ -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
View file @ 24e7808e
......@@ -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
View file @ 24e7808e
......@@ -26,48 +26,43 @@ 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"
, _nn_node2_id = required "node2_id"
, _nn_score = optional "score"
, _nn_category = optional "category"
}
)
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment