Skip to content

H
haskell-gargantext
Commit 254e5d36 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FEAT] Annuaire <-> Corpus pairing (WIP)

parent d435ae39
Hide whitespace changes
Inline Side-by-side
Showing with 374 additions and 219 deletions
devops/postgres/schema.sql
View file @ 254e5d36
......@@ -135,16 +135,27 @@ CREATE TABLE public.nodes_nodes (
ALTER TABLE public.nodes_nodes OWNER TO gargantua;
-- To attach contexts to a Corpus
CREATE TABLE public.nodes_contexts (
id SERIAL ,
node_id INTEGER NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
context_id INTEGER NOT NULL REFERENCES public.contexts(id) ON DELETE CASCADE,
score REAL ,
category INTEGER ,
PRIMARY KEY (node_id, context_id)
PRIMARY KEY (id)
);
ALTER TABLE public.nodes_contexts OWNER TO gargantua;
CREATE TABLE public.nodescontexts_nodescontexts (
nodescontexts1 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
nodescontexts2 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
PRIMARY KEY (nodescontexts1, nodescontexts2)
);
ALTER TABLE public.nodescontexts_nodescontexts OWNER TO gargantua;
---------------------------------------------------------------
CREATE TABLE public.context_node_ngrams (
context_id INTEGER NOT NULL REFERENCES public.contexts (id) ON DELETE CASCADE,
......@@ -157,7 +168,7 @@ CREATE TABLE public.context_node_ngrams (
ALTER TABLE public.context_node_ngrams OWNER TO gargantua;
CREATE TABLE public.context_node_ngrams2 (
context_id INTEGER NOT NULL REFERENCES public.contexts (id) ON DELETE CASCADE,
context_id INTEGER NOT NULL REFERENCES public.contexts (id) ON DELETE CASCADE,
nodengrams_id INTEGER NOT NULL REFERENCES public.node_ngrams (id) ON DELETE CASCADE,
weight double precision,
PRIMARY KEY (context_id, nodengrams_id)
......@@ -185,8 +196,6 @@ PRIMARY KEY (node_id, nodengrams_id)
ALTER TABLE public.node_node_ngrams2 OWNER TO gargantua;
--------------------------------------------------------------
--CREATE TABLE public.nodes_ngrams_repo (
......@@ -230,7 +239,7 @@ CREATE INDEX ON public.contexts USING btree (id, typename, date DESC);
CREATE INDEX ON public.contexts USING btree (typename, id);
CREATE UNIQUE INDEX ON public.contexts USING btree (hash_id);
CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2);
-- CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqId'::text)));
-- CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqIdBdd'::text)));
-- CREATE UNIQUE INDEX ON public.nodes USING btree (typename, parent_id, ((hyperdata ->> 'uniqId'::text)));
......@@ -249,6 +258,7 @@ CREATE UNIQUE INDEX ON public.node_ngrams USING btree (node_id,node_subtype, ngr
CREATE UNIQUE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id);
CREATE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id, category);
-- To make the links between Corpus Node and its contexts
CREATE UNIQUE INDEX ON public.nodes_contexts USING btree (node_id, context_id);
CREATE INDEX ON public.nodes_contexts USING btree (node_id, context_id, category);
......
devops/postgres/upgrade/0.0.5.7.5.sql 0 → 100644
View file @ 254e5d36
ALTER TABLE nodes_contexts DROP CONSTRAINT nodes_contexts_pkey;
ALTER TABLE nodes_contexts ADD COLUMN id SERIAL PRIMARY KEY ;
CREATE TABLE public.nodescontexts_nodescontexts (
nodescontexts1 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
nodescontexts2 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
PRIMARY KEY (nodescontexts1, nodescontexts2)
);
ALTER TABLE public.nodescontexts_nodescontexts OWNER TO gargantua;
CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2)
src/Gargantext/API/Client.hs
View file @ 254e5d36
......@@ -116,7 +116,7 @@ postNodeSearch :: Token -> NodeId -> SearchQuery -> Maybe Int -> Maybe Int -> Ma
postNodeShare :: Token -> NodeId -> ShareNodeParams -> ClientM Int
postNodePairCorpusAnnuaire :: Token -> NodeId -> AnnuaireId -> Maybe ListId -> ClientM Int
postNodePairCorpusAnnuaire :: Token -> NodeId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
getNodePairs :: Token -> NodeId -> ClientM [AnnuaireId]
getNodePairings :: Token -> NodeId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
......@@ -205,7 +205,7 @@ postCorpusSearch :: Token -> CorpusId -> SearchQuery -> Maybe Int -> Maybe Int -
postCorpusShare :: Token -> CorpusId -> ShareNodeParams -> ClientM Int
postCorpusPairCorpusAnnuaire :: Token -> CorpusId -> AnnuaireId -> Maybe ListId -> ClientM Int
postCorpusPairCorpusAnnuaire :: Token -> CorpusId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
getCorpusPairs :: Token -> CorpusId -> ClientM [AnnuaireId]
getCorpusPairings :: Token -> CorpusId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
......@@ -299,7 +299,7 @@ putAnnuaireScore :: Token -> AnnuaireId -> NodesToScore -> ClientM [Int]
postAnnuaireSearch :: Token -> AnnuaireId -> SearchQuery -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM SearchResult
postAnnuaireShare :: Token -> AnnuaireId -> ShareNodeParams -> ClientM Int
postAnnuairePairCorpusAnnuaire :: Token -> AnnuaireId -> AnnuaireId -> Maybe ListId -> ClientM Int
postAnnuairePairCorpusAnnuaire :: Token -> AnnuaireId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
getAnnuairePairs :: Token -> AnnuaireId -> ClientM [AnnuaireId]
getAnnuairePairings :: Token -> AnnuaireId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
......
src/Gargantext/API/Ngrams/Tools.hs
View file @ 254e5d36
......@@ -135,16 +135,16 @@ filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
Just (l',_) -> l' == lt
filterListWithRoot :: ListType
filterListWithRoot :: [ListType]
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (Maybe RootTerm)
filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
where
isMapTerm (l, maybeRoot) = case maybeRoot of
Nothing -> l == lt
Nothing -> elem l lt
Just r -> case HM.lookup r m of
Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
Just (l',_) -> l' == lt
Just (l',_) -> elem l' lt
groupNodesByNgrams :: ( At root_map
, Index root_map ~ NgramsTerm
......
src/Gargantext/API/Node.hs
View file @ 254e5d36
......@@ -312,7 +312,7 @@ pairs cId = do
type PairWith = Summary "Pair a Corpus with an Annuaire"
:> "annuaire" :> Capture "annuaire_id" AnnuaireId
:> QueryParam "list_id" ListId
:> Post '[JSON] Int
:> Post '[JSON] [Int]
pairWith :: CorpusId -> GargServer PairWith
pairWith cId aId lId = do
......
src/Gargantext/API/Node/Corpus/Export.hs
View file @ 254e5d36
......@@ -95,7 +95,7 @@ getContextNgrams cId lId listType nt repo = do
-- Just l -> pure l
lIds <- selectNodesWithUsername NodeList userMaster
let ngs = filterListWithRoot listType $ mapTermListRoot [lId] nt repo
let ngs = filterListWithRoot [listType] $ mapTermListRoot [lId] nt repo
-- TODO HashMap
r <- getNgramsByContextOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
pure r
......
src/Gargantext/Core/Viz/Chart.hs
View file @ 254e5d36
......@@ -61,7 +61,7 @@ chartData cId nt lt = do
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt <$> getRepo' ls
let
dico = filterListWithRoot lt ts
dico = filterListWithRoot [lt] ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
group dico' x = case HashMap.lookup x dico' of
Nothing -> x
......@@ -86,7 +86,7 @@ treeData cId nt lt = do
ts <- mapTermListRoot ls nt <$> getRepo' ls
let
dico = filterListWithRoot lt ts
dico = filterListWithRoot [lt] ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
cs' <- getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 254e5d36
......@@ -174,7 +174,7 @@ computeGraph cId method d nt repo = do
lId <- defaultList cId
lIds <- selectNodesWithUsername NodeList userMaster
let ngs = filterListWithRoot MapTerm
let ngs = filterListWithRoot [MapTerm]
$ mapTermListRoot [lId] nt repo
myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
......
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ 254e5d36
......@@ -16,15 +16,18 @@ module Gargantext.Database.Action.Flow.Pairing
-- (pairing)
where
import Debug.Trace (trace)
import Control.Lens (_Just, (^.))
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (catMaybes, fromMaybe)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Set (Set)
import Data.Text (Text)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Core
import Gargantext.Core.Text.Metrics.CharByChar (levenshtein)
import Gargantext.Core.Types (TableResult(..))
import Gargantext.Core.Types.Main
import Gargantext.Database
......@@ -33,18 +36,21 @@ 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.Query.Prelude (leftJoin2, returnA, queryNodeNodeTable)
import Gargantext.Database.Query.Table.Node (defaultList)
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.NodeContext_NodeContext (insertNodeContext_NodeContext)
import Gargantext.Database.Query.Table.NodeNode (insertNodeNode)
import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
import Gargantext.Database.Schema.Node
-- import Gargantext.Database.Schema.Context
import qualified Data.HashMap.Strict as HM
import Gargantext.Prelude hiding (sum)
import Opaleye
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Text as DT
import qualified Data.Text as Text
-- | isPairedWith
-- All NodeAnnuaire paired with a Corpus of NodeId nId:
......@@ -65,120 +71,117 @@ isPairedWith nId nt = runOpaQuery (selectQuery nt nId)
cond (node, node_node) = node^.node_id .== node_node^. nn_node2_id
-----------------------------------------------------------------------
pairing :: AnnuaireId -> CorpusId -> Maybe ListId -> GargNoServer Int
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
_ <- insertNodeNode [ NodeNode { _nn_node1_id = c
, _nn_node2_id = a
, _nn_score = Nothing
, _nn_category = Nothing }]
pure r
dataPaired <- dataPairing a (c,l,Authors)
_ <- insertNodeNode [ NodeNode c a Nothing Nothing]
insertNodeContext_NodeContext $ prepareInsert c a dataPaired
dataPairing :: AnnuaireId
-> (CorpusId, ListId, NgramsType)
-> (ContactName -> Projected)
-> (DocAuthor -> Projected)
-> GargNoServer (HashMap ContactId (Set DocId))
dataPairing aId (cId, lId, ngt) fc fa = do
dataPairing aId (cId, lId, ngt) = do
-- mc :: HM.HashMap ContactName (Set ContactId)
mc <- getNgramsContactId aId
md <- getNgramsDocId cId lId ngt
printDebug "ngramsContactId" mc
printDebug "ngramsDocId" md
let
from = projectionFrom (Set.fromList $ HM.keys mc) fc
to = projectionTo (Set.fromList $ HM.keys md) fa
pure $ fusion mc $ align from to md
prepareInsert :: HashMap ContactId (Set DocId) -> [NodeNode]
prepareInsert m = map (\(n1,n2) -> NodeNode { _nn_node1_id = n1
, _nn_node2_id = n2
, _nn_score = Nothing
, _nn_category = Nothing })
$ List.concat
$ map (\(contactId, setDocIds)
-> map (\setDocId
-> (contactId, setDocId)
) $ Set.toList setDocIds
)
$ HM.toList m
-- md :: HM.HashMap DocAuthor (Set DocId)
md <- getNgramsDocId cId lId ngt
-- printDebug "dataPairing authors" (HM.keys md)
let result = fusion mc md
-- printDebug "dataPairing" (length $ HM.keys result)
pure result
prepareInsert :: CorpusId -> AnnuaireId -> HashMap ContactId (Set DocId)
-> [(CorpusId, AnnuaireId, DocId, ContactId)]
prepareInsert corpusId annuaireId mapContactDocs =
map (\(contactId,docId) -> (corpusId, docId, annuaireId, contactId))
$ List.concat
$ map (\(contactId, setDocIds)
-> map (\setDocId
-> (contactId, setDocId)
) $ Set.toList setDocIds
)
$ HM.toList mapContactDocs
------------------------------------------------------------------------
type ContactName = NgramsTerm
type DocAuthor = NgramsTerm
type Projected = NgramsTerm
projectionFrom :: Set ContactName -> (ContactName -> Projected) -> HashMap ContactName Projected
projectionFrom ss f = HM.fromList $ map (\s -> (s, f s)) (Set.toList ss) -- use HS.toMap
fusion :: HashMap ContactName (Set ContactId)
-> HashMap DocAuthor (Set DocId)
-> HashMap ContactId (Set DocId)
fusion mc md = HM.fromListWith (<>)
$ List.concat
$ map (\(docAuthor, docs)
-> case (getClosest Text.toLower docAuthor (HM.keys mc)) of
Nothing -> []
Just author -> case HM.lookup author mc of
Nothing -> []
Just contactIds -> map (\contactId -> (contactId, docs))
$ Set.toList contactIds
)
$ HM.toList md
fusion'' :: HashMap ContactName (Set ContactId)
-> HashMap DocAuthor (Set DocId)
-> HashMap ContactId (Set DocId)
fusion'' mc md = hashmapReverse $ fusion' mc (hashmapReverse md)
projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> HashMap Projected (Set DocAuthor)
projectionTo ss f = HM.fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss) -- use HS.toMap
------------------------------------------------------------------------
takeName :: NgramsTerm -> NgramsTerm
takeName (NgramsTerm texte) = NgramsTerm $ DT.toLower texte'
fusion' :: HashMap ContactName (Set ContactId)
-> HashMap DocId (Set DocAuthor)
-> HashMap DocId (Set ContactId)
fusion' mc md = HM.fromListWith (<>)
$ map (\(docId, setAuthors) -> (docId, getContactIds mc $ getClosest' setAuthors (HM.keys mc)))
$ HM.toList md
getContactIds :: HashMap ContactName (Set ContactId) -> Set ContactName -> Set ContactId
getContactIds mapContactNames contactNames =
if Set.null contactNames
then Set.empty
else Set.unions $ catMaybes $ map (\contactName -> HM.lookup contactName mapContactNames) $ Set.toList contactNames
getClosest' :: Set DocAuthor -> [ContactName] -> Set ContactName
getClosest' setAuthors contactNames = trace (show (setAuthors, setContactNames)) $ setContactNames
where
texte' = maybe texte (\x -> if DT.length x > 3 then x else texte)
(lastName' texte)
lastName' = lastMay . DT.splitOn " "
setContactNames = if Set.null xs then ys else xs
xs = Set.fromList $ catMaybes $ map (\author -> getClosest Text.toLower author contactNames) $ Set.toList setAuthors
ys = Set.fromList $ catMaybes $ map (\(NgramsTerm author) -> case ((lastMay . (Text.splitOn " ")) author) of
Nothing -> Nothing
Just authorReduced -> getClosest Text.toLower (NgramsTerm authorReduced) contactNames)
$ Set.toList setAuthors
------------------------------------------------------------------------
align :: HashMap ContactName Projected
-> HashMap Projected (Set DocAuthor)
-> HashMap DocAuthor (Set DocId)
-> HashMap ContactName (Set DocId)
align mc ma md = HM.fromListWith (<>)
$ map (\c -> (c, getProjection md $ testProjection c mc ma))
$ HM.keys mc
getClosest :: (Text -> Text) -> NgramsTerm -> [NgramsTerm] -> Maybe NgramsTerm
getClosest f (NgramsTerm from) candidates = fst <$> head scored
where
getProjection :: HashMap DocAuthor (Set DocId) -> Set DocAuthor -> Set DocId
getProjection ma' sa' =
if Set.null sa'
then Set.empty
else Set.unions $ sets ma' sa'
where
sets ma'' sa'' = Set.map (\s -> lookup s ma'') sa''
lookup s' ma''= fromMaybe Set.empty (HM.lookup s' ma'')
testProjection :: ContactName
-> HashMap ContactName Projected
-> HashMap Projected (Set DocAuthor)
-> Set DocAuthor
testProjection cn' mc' ma' = case HM.lookup cn' mc' of
Nothing -> Set.empty
Just c -> case HM.lookup c ma' of
Nothing -> Set.empty
Just a -> a
scored = List.sortOn snd
$ List.filter (\(_,score) -> score <= 2)
$ map (\cand@(NgramsTerm candidate) -> (cand, levenshtein (f from) (f candidate))) candidates
fusion :: HashMap ContactName (Set ContactId)
-> HashMap ContactName (Set DocId)
-> HashMap ContactId (Set DocId)
fusion mc md = HM.fromListWith (<>)
$ catMaybes
$ [ (,) <$> Just cId <*> HM.lookup cn md
| (cn, setContactId) <- HM.toList mc
, cId <- Set.toList setContactId
]
------------------------------------------------------------------------
------------------------------------------------------------------------
getNgramsContactId :: AnnuaireId
-> Cmd err (HashMap ContactName (Set NodeId))
getNgramsContactId aId = do
contacts <- getAllContacts aId
pure $ HM.fromListWith (<>)
$ catMaybes
$ map (\contact -> (,) <$> (NgramsTerm <$> contact^.(node_hyperdata . hc_who . _Just . cw_lastName))
<*> Just ( Set.singleton (contact^.node_id))
-- printDebug "getAllContexts" (tr_count contacts)
let paired= HM.fromListWith (<>)
$ map (\contact -> (toName contact, Set.singleton (contact^.node_id))
) (tr_docs contacts)
-- printDebug "paired" (HM.keys paired)
pure paired
-- POC here, should be a probabilistic function (see the one used to find lang)
toName :: Node HyperdataContact -> NgramsTerm
toName contact = NgramsTerm $ (Text.toTitle $ Text.take 1 firstName) <> ". " <> (Text.toTitle lastName)
where
firstName = fromMaybe "" $ contact^.(node_hyperdata . hc_who . _Just . cw_firstName)
lastName = fromMaybe "" $ contact^.(node_hyperdata . hc_who . _Just . cw_lastName)
getNgramsDocId :: CorpusId
-> ListId
......@@ -186,8 +189,15 @@ getNgramsDocId :: CorpusId
-> GargNoServer (HashMap DocAuthor (Set NodeId))
getNgramsDocId cId lId nt = do
lIds <- selectNodesWithUsername NodeList userMaster
repo <- getRepo' lIds
let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
groupNodesByNgrams ngs
<$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
repo <- getRepo' (lId:lIds)
let ngs = filterListWithRoot [MapTerm, CandidateTerm] $ mapTermListRoot (lId:lIds) nt repo
-- printDebug "getNgramsDocId" ngs
groupNodesByNgrams ngs <$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
hashmapReverse :: (Ord a, Eq b, Hashable b)
=> HashMap a (Set b) -> HashMap b (Set a)
hashmapReverse m = HM.fromListWith (<>)
$ List.concat
$ map (\(k,vs) -> [ (v, Set.singleton k) | v <- Set.toList vs])
$ HM.toList m
src/Gargantext/Database/Action/Metrics.hs
View file @ 254e5d36
......@@ -234,8 +234,9 @@ getNgrams :: (HasMail env, HasNodeStory env err m)
getNgrams lId tabType = do
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo' [lId]
-- TODO filterListWithRoot [MapTerm, StopTerm, CandidateTerm] lists
let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
[MapTerm, StopTerm, CandidateTerm]
[[MapTerm], [StopTerm], [CandidateTerm]]
pure (lists, maybeSyn)
-- Some useful Tools
......
src/Gargantext/Database/Action/Metrics/NgramsByContext.hs
View file @ 254e5d36
......@@ -172,7 +172,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt tms =
queryNgramsOccurrencesOnlyByContextUser_withSample :: DPS.Query
queryNgramsOccurrencesOnlyByContextUser_withSample = [sql|
WITH nodes_sample AS (SELECT id FROM contexts n TABLESAMPLE SYSTEM_ROWS (?)
WITH nodes_sample AS (SELECT n.id FROM contexts n TABLESAMPLE SYSTEM_ROWS (?)
JOIN nodes_contexts nn ON n.id = nn.context_id
WHERE n.typename = ?
AND nn.node_id = ?),
......
src/Gargantext/Database/Action/Search.hs
View file @ 254e5d36
......@@ -26,8 +26,8 @@ import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Join (leftJoin5)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Context
import Gargantext.Database.Query.Table.NodeNode
import Gargantext.Database.Query.Table.NodeContext
import Gargantext.Database.Query.Table.NodeContext_NodeContext
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Context
import Gargantext.Prelude
......@@ -41,11 +41,11 @@ searchDocInDatabase :: HasDBid NodeType
=> ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
searchDocInDatabase _p t = runOpaQuery (queryDocInDatabase t)
searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
where
-- | Global search query where ParentId is Master Node Corpus Id
queryDocInDatabase :: Text -> O.Select (Column SqlInt4, Column SqlJsonb)
queryDocInDatabase q = proc () -> do
queryDocInDatabase :: ParentId -> Text -> O.Select (Column SqlInt4, Column SqlJsonb)
queryDocInDatabase _p q = proc () -> do
row <- queryNodeSearchTable -< ()
restrict -< (_ns_search row) @@ (sqlTSQuery (unpack q))
restrict -< (_ns_typename row) .== (sqlInt4 $ toDBid NodeDocument)
......@@ -118,11 +118,22 @@ searchInCorpusWithContacts
searchInCorpusWithContacts cId aId q o l _order =
runOpaQuery $ limit' l
$ offset' o
$ orderBy ( desc _fp_score)
$ orderBy (desc _fp_score)
$ selectGroup cId aId
$ intercalate " | "
$ map stemIt q
selectGroup :: HasDBid NodeType
=> CorpusId
-> AnnuaireId
-> Text
-> Select FacetPairedReadNull
selectGroup cId aId q = proc () -> do
(a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
(selectContactViaDoc cId aId q) -< ()
returnA -< FacetPaired a b c d
selectContactViaDoc
:: HasDBid NodeType
=> CorpusId
......@@ -134,81 +145,68 @@ selectContactViaDoc
, Column (Nullable SqlJsonb)
, Column (Nullable SqlInt4)
)
selectContactViaDoc cId aId q = proc () -> do
(doc, (corpus_doc, (_contact_doc, (annuaire_contact, contact)))) <- queryContactViaDoc -< ()
restrict -< (doc^.ns_search) @@ (sqlTSQuery $ unpack q )
restrict -< (doc^.ns_typename) .== (sqlInt4 $ toDBid NodeDocument)
restrict -< (corpus_doc^.nn_node1_id) .== (toNullable $ pgNodeId cId)
restrict -< (annuaire_contact^.nn_node1_id) .== (toNullable $ pgNodeId aId)
restrict -< (contact^.node_typename) .== (toNullable $ sqlInt4 $ toDBid NodeContact)
returnA -< ( contact^.node_id
, contact^.node_date
, contact^.node_hyperdata
selectContactViaDoc cId aId query = proc () -> do
(doc, (corpus, (_nodeContext_nodeContext, (annuaire, contact)))) <- queryContactViaDoc -< ()
restrict -< (doc^.cs_search) @@ (sqlTSQuery $ unpack query )
restrict -< (doc^.cs_typename) .== (sqlInt4 $ toDBid NodeDocument )
restrict -< (corpus^.nc_node_id) .== (toNullable $ pgNodeId cId )
restrict -< (annuaire^.nc_node_id) .== (toNullable $ pgNodeId aId )
restrict -< (contact^.context_typename) .== (toNullable $ sqlInt4 $ toDBid NodeContact)
returnA -< ( contact^.context_id
, contact^.context_date
, contact^.context_hyperdata
, toNullable $ sqlInt4 1
)
selectGroup :: HasDBid NodeType
=> NodeId
-> NodeId
-> Text
-> Select FacetPairedReadNull
selectGroup cId aId q = proc () -> do
(a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
(selectContactViaDoc cId aId q) -< ()
returnA -< FacetPaired a b c d
queryContactViaDoc :: O.Select ( NodeSearchRead
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, NodeReadNull
queryContactViaDoc :: O.Select ( ContextSearchRead
, ( NodeContextReadNull
, ( NodeContext_NodeContextReadNull
, ( NodeContextReadNull
, ContextReadNull
)
)
)
)
queryContactViaDoc =
leftJoin5
queryNodeTable
queryNodeNodeTable
queryNodeNodeTable
queryNodeNodeTable
queryNodeSearchTable
queryContextTable
queryNodeContextTable
queryNodeContext_NodeContextTable
queryNodeContextTable
queryContextSearchTable
cond12
cond23
cond34
cond45
where
cond12 :: (NodeNodeRead, NodeRead) -> Column SqlBool
cond12 (annuaire_contact, contact) = contact^.node_id .== annuaire_contact^.nn_node2_id
cond12 :: (NodeContextRead, ContextRead) -> Column SqlBool
cond12 (annuaire, contact) = contact^.context_id .== annuaire^.nc_context_id
cond23 :: ( NodeNodeRead
, ( NodeNodeRead
, NodeReadNull
cond23 :: ( NodeContext_NodeContextRead
, ( NodeContextRead
, ContextReadNull
)
) -> Column SqlBool
cond23 (contact_doc, (annuaire_contact, _)) = contact_doc^.nn_node1_id .== annuaire_contact^.nn_node2_id
cond23 (nodeContext_nodeContext, (annuaire, _)) = nodeContext_nodeContext^.ncnc_nodecontext2 .== annuaire^.nc_id
cond34 :: ( NodeNodeRead
, ( NodeNodeRead
, ( NodeNodeReadNull
, NodeReadNull
cond34 :: ( NodeContextRead
, ( NodeContext_NodeContextRead
, ( NodeContextReadNull
, ContextReadNull
)
)
) -> Column SqlBool
cond34 (corpus_doc, (contact_doc, (_,_))) = corpus_doc^.nn_node2_id .== contact_doc^.nn_node2_id
cond34 (corpus, (nodeContext_nodeContext, (_,_))) = nodeContext_nodeContext^.ncnc_nodecontext1 .== corpus^.nc_id
cond45 :: ( NodeSearchRead
, ( NodeNodeRead
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, NodeReadNull
cond45 :: ( ContextSearchRead
, ( NodeContextRead
, ( NodeContext_NodeContextReadNull
, ( NodeContextReadNull
, ContextReadNull
)
)
)
) -> Column SqlBool
cond45 (doc, (corpus_doc, (_,(_,_)))) = doc^.ns_id .== corpus_doc^.nn_node2_id
cond45 (doc, (corpus, (_,(_,_)))) = doc^.cs_id .== corpus^.nc_context_id
------------------------------------------------------------------------
src/Gargantext/Database/Admin/Types/Node.hs
View file @ 254e5d36
......@@ -187,13 +187,13 @@ instance (Arbitrary hyperdata
) where
--arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
arbitrary = ContextSearch <$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
......@@ -212,10 +212,13 @@ pgContextId = pgNodeId
newtype NodeId = NodeId Int
deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
-- TODO make another type?
-- TODO make another type
type ContextId = NodeId
newtype NodeContextId = NodeContextId Int
deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
instance GQLType NodeId
instance Show NodeId where
show (NodeId n) = "nodeId-" <> show n
......
src/Gargantext/Database/Query/Table/Context.hs
View file @ 254e5d36
{-|
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
Module : Gargantext.Database.Query.Table.Node
Description : Main Tools of Node to the database
Copyright : (c) CNRS, 2017-Present
......@@ -9,7 +8,6 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
......@@ -31,8 +29,8 @@ import Gargantext.Database.Query.Filter (limit', offset')
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Schema.Context
import Gargantext.Prelude hiding (sum, head)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)
getContextWith :: (HasNodeError err, JSONB a)
......
src/Gargantext/Database/Query/Table/Node/Children.hs
View file @ 254e5d36
......@@ -84,9 +84,9 @@ getChildrenNode pId _ maybeNodeType maybeOffset maybeLimit = do
selectChildrenNode :: HasDBid NodeType
=> ParentId
-> Maybe NodeType
-> Select NodeRead
=> ParentId
-> Maybe NodeType
-> Select NodeRead
selectChildrenNode parentId maybeNodeType = proc () -> do
row@(Node _ _ typeName _ parent_id _ _ _) <- queryNodeTable -< ()
let nodeType = maybe 0 toDBid maybeNodeType
......@@ -122,7 +122,7 @@ selectChildren' :: HasDBid NodeType
-> Select ContextRead
selectChildren' parentId maybeNodeType = proc () -> do
row@(Context cid _ typeName _ _ _ _ _) <- queryContextTable -< ()
(NodeContext nid cid' _ _) <- queryNodeContextTable -< ()
(NodeContext _ nid cid' _ _) <- queryNodeContextTable -< ()
let nodeType = maybe 0 toDBid maybeNodeType
restrict -< typeName .== sqlInt4 nodeType
......
src/Gargantext/Database/Query/Table/NodeContext.hs
View file @ 254e5d36
......@@ -77,8 +77,9 @@ insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
$ Insert nodeContextTable ns' rCount (Just DoNothing))
where
ns' :: [NodeContextWrite]
ns' = map (\(NodeContext n c x y)
-> NodeContext (pgNodeId n)
ns' = map (\(NodeContext i n c x y)
-> NodeContext (sqlInt4 <$> i)
(pgNodeId n)
(pgNodeId c)
(sqlDouble <$> x)
(sqlInt4 <$> y)
......@@ -93,7 +94,7 @@ deleteNodeContext :: Node_Id -> Context_Id -> Cmd err Int
deleteNodeContext n c = mkCmd $ \conn ->
fromIntegral <$> runDelete_ conn
(Delete nodeContextTable
(\(NodeContext n_id c_id _ _) -> n_id .== pgNodeId n
(\(NodeContext _ n_id c_id _ _) -> n_id .== pgNodeId n
.&& c_id .== pgNodeId c
)
rCount
......
src/Gargantext/Database/Query/Table/NodeContext_NodeContext.hs 0 → 100644
View file @ 254e5d36
{-|
Module : Gargantext.Database.Select.Table.NodeContext_NodeContext
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Query.Table.NodeContext_NodeContext
( module Gargantext.Database.Schema.NodeContext_NodeContext
-- , query_NodeContext_NodeContext_Table
, insertNodeContext_NodeContext
)
where
import Data.Text (Text)
import Gargantext.Core.Types
import Gargantext.Database.Prelude
import Gargantext.Database.Schema.NodeContext_NodeContext
import Gargantext.Database.Schema.Prelude hiding (sum)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as PGS
{-
queryNodeContext_NodeContextTable :: Select NodeContext_NodeContextRead
queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
-}
insertNodeContext_NodeContext :: [(CorpusId, DocId, AnnuaireId, ContactId)] -> Cmd err [Int]
insertNodeContext_NodeContext contexts = do
let
fields = map (\t -> QualifiedIdentifier Nothing t) $ snd fields_name
fields_name :: ( [Text], [Text])
fields_name = ( ["corpus_id", "doc_id", "annuaire_id", "contact_id"]
, ["int4" , "int4" , "int4" , "int4" ]
)
result <- map (\(PGS.Only a) -> a) <$> runPGSQuery queryInsert (PGS.Only $ Values fields contexts)
pure [sum result]
queryInsert :: PGS.Query
queryInsert = [sql|
WITH input(corpus_id, doc_id, annuaire_id, contact_id) AS (?)
INSERT into nodescontexts_nodescontexts (nodescontexts1, nodescontexts2)
SELECT context1.id, context2.id FROM input
INNER JOIN nodes_contexts context1 ON context1.node_id = input.corpus_id
INNER JOIN nodes_contexts context2 ON context2.node_id = input.annuaire_id
WHERE context1.context_id = input.doc_id
AND context2.context_id = input.contact_id
ON CONFLICT (nodescontexts1, nodescontexts2) DO Nothing
RETURNING 1
|]
src/Gargantext/Database/Schema/NodeContext.hs
View file @ 254e5d36
......@@ -26,29 +26,33 @@ import Gargantext.Database.Schema.NodeNode () -- Just importing some instances
import Gargantext.Prelude
data NodeContextPoly node_id context_id score cat
= NodeContext { _nc_node_id :: !node_id
data NodeContextPoly id node_id context_id score cat
= NodeContext { _nc_id :: !id
, _nc_node_id :: !node_id
, _nc_context_id :: !context_id
, _nc_score :: !score
, _nc_category :: !cat
} deriving (Show)
type NodeContextWrite = NodeContextPoly (Column (SqlInt4))
(Column (SqlInt4))
(Maybe (Column (SqlFloat8)))
(Maybe (Column (SqlInt4)))
type NodeContextWrite = NodeContextPoly (Maybe (Column (SqlInt4)))
(Column (SqlInt4))
(Column (SqlInt4))
(Maybe (Column (SqlFloat8)))
(Maybe (Column (SqlInt4)))
type NodeContextRead = NodeContextPoly (Column (SqlInt4))
(Column (SqlInt4))
(Column (SqlFloat8))
(Column (SqlInt4))
(Column (SqlInt4))
(Column (SqlInt4))
(Column (SqlFloat8))
(Column (SqlInt4))
type NodeContextReadNull = NodeContextPoly (Column (Nullable SqlInt4))
(Column (Nullable SqlInt4))
(Column (Nullable SqlFloat8))
(Column (Nullable SqlInt4))
(Column (Nullable SqlInt4))
(Column (Nullable SqlInt4))
(Column (Nullable SqlFloat8))
(Column (Nullable SqlInt4))
type NodeContext = NodeContextPoly NodeId NodeId (Maybe Double) (Maybe Int)
type NodeContext = NodeContextPoly (Maybe Int) NodeId NodeId (Maybe Double) (Maybe Int)
$(makeAdaptorAndInstance "pNodeContext" ''NodeContextPoly)
makeLenses ''NodeContextPoly
......@@ -57,7 +61,8 @@ nodeContextTable :: Table NodeContextWrite NodeContextRead
nodeContextTable =
Table "nodes_contexts"
( pNodeContext
NodeContext { _nc_node_id = requiredTableField "node_id"
NodeContext { _nc_id = optionalTableField "id"
, _nc_node_id = requiredTableField "node_id"
, _nc_context_id = requiredTableField "context_id"
, _nc_score = optionalTableField "score"
, _nc_category = optionalTableField "category"
......
src/Gargantext/Database/Schema/NodeContext_NodeContext.hs 0 → 100644
View file @ 254e5d36
{-|
Module : Gargantext.Database.Schema.ContextContext
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.NodeContext_NodeContext where
import Gargantext.Core.Types
import Gargantext.Database.Schema.Prelude
import Gargantext.Prelude
data NodeContext_NodeContextPoly nodecontext1 nodecontext2
= NodeContext_NodeContext { _ncnc_nodecontext1 :: !nodecontext1
, _ncnc_nodecontext2 :: !nodecontext2
} deriving (Show)
type NodeContext_NodeContextWrite = NodeContext_NodeContextPoly (Column (SqlInt4))
(Column (SqlInt4))
type NodeContext_NodeContextRead = NodeContext_NodeContextPoly (Column (SqlInt4))
(Column (SqlInt4))
type NodeContext_NodeContextReadNull = NodeContext_NodeContextPoly (Column (Nullable SqlInt4))
(Column (Nullable SqlInt4))
type NodeContext_NodeContext = NodeContext_NodeContextPoly NodeContextId NodeContextId
$(makeAdaptorAndInstance "pNodeContext_NodeContext" ''NodeContext_NodeContextPoly)
makeLenses ''NodeContext_NodeContextPoly
nodeContext_NodeContextTable :: Table NodeContext_NodeContextWrite NodeContext_NodeContextRead
nodeContext_NodeContextTable =
Table "nodescontexts_nodescontexts"
( pNodeContext_NodeContext
NodeContext_NodeContext { _ncnc_nodecontext1 = requiredTableField "nodescontexts1"
, _ncnc_nodecontext2 = requiredTableField "nodescontexts2"
}
)
queryNodeContext_NodeContextTable :: Query NodeContext_NodeContextRead
queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
src/Gargantext/Database/Schema/NodeNode.hs
View file @ 254e5d36
......@@ -11,8 +11,6 @@ Here is a longer description of this module, containing some
commentary with @some markup@.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
......@@ -63,18 +61,3 @@ nodeNodeTable =
}
)
instance DefaultFromField (Nullable SqlInt4) Int where
defaultFromField = fromPGSFromField
instance DefaultFromField (Nullable SqlFloat8) Int where
defaultFromField = fromPGSFromField
instance DefaultFromField (Nullable SqlFloat8) Double where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlFloat8 (Maybe Double) where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlInt4 (Maybe Int) where
defaultFromField = fromPGSFromField
src/Gargantext/Database/Types.hs
View file @ 254e5d36
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Types
......@@ -40,3 +41,19 @@ instance HasText a => HasText (Indexed i a)
hasText (Indexed _ a) = hasText a
instance (Hashable a, Hashable b) => Hashable (Indexed a b)
instance DefaultFromField (Nullable SqlInt4) Int where
defaultFromField = fromPGSFromField
instance DefaultFromField (Nullable SqlFloat8) Int where
defaultFromField = fromPGSFromField
instance DefaultFromField (Nullable SqlFloat8) Double where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlFloat8 (Maybe Double) where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlInt4 (Maybe Int) where
defaultFromField = fromPGSFromField
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