Skip to content

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

[NgramsTable][WIP] Get / Group / ungroup.

parent 46fafbe8
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 359 additions and 88 deletions
src/Gargantext/API/Ngrams.hs
View file @ 9187d327
......@@ -39,9 +39,10 @@ import Data.Monoid
--import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as Set
--import Data.Maybe (catMaybes)
import Data.Maybe (isJust)
import Data.Tuple.Extra (first)
-- import qualified Data.Map.Strict as DM
import Data.Map.Strict (Map)
import Data.Map.Strict (Map, mapKeys, fromListWith)
--import qualified Data.Set as Set
import Control.Lens (makeLenses, Prism', prism', (^..), (.~), (#), to, withIndex, folded, ifolded)
import Control.Monad (guard)
......@@ -57,7 +58,7 @@ import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Types.Node (NodeType(..))
import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId)
import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId, NgramsTableData'(..))
import qualified Gargantext.Database.Schema.Ngrams as Ngrams
import Gargantext.Database.Schema.NodeNgram
import Gargantext.Database.Schema.NodeNgramsNgrams
......@@ -119,6 +120,29 @@ instance Arbitrary NgramsElement where
newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
-- | TODO Check N and Weight
toNgramsElement :: [NgramsTableData'] -> [NgramsElement]
toNgramsElement ns = map toNgramsElement' ns
where
toNgramsElement' (NgramsTableData' _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
where
p' = case p of
Nothing -> Nothing
Just x -> lookup x mapParent
c' = maybe mempty identity $ lookup t mapChildren
lt' = maybe (panic "API.Ngrams: listypeId") identity lt
mapParent :: Map Int Text
mapParent = fromListWith (<>) $ map (\(NgramsTableData' i _ t _ _ _) -> (i,t)) ns
mapChildren :: Map Text (Set Text)
mapChildren = mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
$ fromListWith (<>)
$ map (first fromJust)
$ filter (isJust . fst)
$ map (\(NgramsTableData' _ p t _ _ _) -> (p, Set.singleton t)) ns
instance Arbitrary NgramsTable where
arbitrary = elements
[ NgramsTable
......@@ -277,12 +301,12 @@ mkListsUpdate lId nt patches =
, lt <- patch ^.. patch_list . new
]
mkChildrenGroups :: ListId
mkChildrenGroups :: ListId -> NgramsType
-> (PatchSet NgramsTerm -> Set NgramsTerm)
-> NgramsTablePatch
-> [(ListId, NgramsParent, NgramsChild, Maybe Double)]
mkChildrenGroups lId addOrRem patches =
[ (lId, parent, child, Just 1)
-> [(ListId, NgramsTypeId, NgramsParent, NgramsChild)]
mkChildrenGroups lId nt addOrRem patches =
[ (lId, ngramsTypeId nt, parent, child)
| (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
, child <- patch ^.. patch_children . to addOrRem . folded
]
......@@ -290,14 +314,14 @@ mkChildrenGroups lId addOrRem patches =
ngramsTypeFromTabType :: Maybe TabType -> NgramsType
ngramsTypeFromTabType maybeTabType =
let lieu = "Garg.API.Ngrams: " :: Text in
case maybeTabType of
Nothing -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
Just tab -> case tab of
Sources -> Ngrams.Sources
Authors -> Ngrams.Authors
Institutes -> Ngrams.Institutes
Terms -> Ngrams.NgramsTerms
_ -> panic $ lieu <> "No Ngrams for this tab"
case maybeTabType of
Nothing -> panic (lieu <> "Indicate the Table")
Just tab -> case tab of
Sources -> Ngrams.Sources
Authors -> Ngrams.Authors
Institutes -> Ngrams.Institutes
Terms -> Ngrams.NgramsTerms
_ -> panic $ lieu <> "No Ngrams for this tab"
-- Apply the given patch to the DB and returns the patch to be applied on the
......@@ -315,8 +339,8 @@ tableNgramsPatch corpusId maybeTabType maybeList (Versioned version patch) = do
listId <- maybe (defaultList corpusId) pure maybeList
updateNodeNgrams $ NodeNgramsUpdate
{ _nnu_lists_update = mkListsUpdate listId ngramsType patch
, _nnu_rem_children = mkChildrenGroups listId _rem patch
, _nnu_add_children = mkChildrenGroups listId _add patch
, _nnu_rem_children = mkChildrenGroups listId ngramsType _rem patch
, _nnu_add_children = mkChildrenGroups listId ngramsType _add patch
}
pure $ Versioned 1 emptyNgramsTablePatch
......@@ -327,7 +351,6 @@ getTableNgrams :: HasNodeError err
-> Maybe ListId -> Maybe Limit -> Maybe Offset
-> Cmd err (Versioned NgramsTable)
getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
let lieu = "Garg.API.Ngrams: " :: Text
let ngramsType = ngramsTypeFromTabType maybeTabType
listId <- maybe (defaultList cId) pure maybeListId
......@@ -336,18 +359,9 @@ getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
limit_ = maybe defaultLimit identity mlimit
offset_ = maybe 0 identity moffset
(ngramsTableDatas, mapToParent, mapToChildren) <-
ngramsTableDatas <-
Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
-- printDebug "ngramsTableDatas" ngramsTableDatas
pure $ Versioned 1 $
NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
NgramsElement ngs
(maybe (panic $ lieu <> "listType") identity lt)
(round w)
(lookup ngs mapToParent)
(maybe mempty identity $ lookup ngs mapToChildren)
) ngramsTableDatas
pure $ Versioned 1 $ NgramsTable (toNgramsElement ngramsTableDatas)
src/Gargantext/Database/Flow.hs
View file @ 9187d327
......@@ -309,7 +309,7 @@ ngrams2list = zip (repeat GraphList) . map (\(NgramsT ngt ng) -> (ngt, ng)) . DM
-- | TODO: weight of the list could be a probability
insertLists :: HasNodeError err => ListId -> [(ListType, (NgramsType, NgramsIndexed))] -> Cmd err Int
insertLists lId lngs = insertNodeNgrams [ NodeNgram lId (_ngramsId ng) (ngramsTypeId ngt) (fromIntegral $ listTypeId l) 1
insertLists lId lngs = insertNodeNgrams [ NodeNgram lId (_ngramsId ng) Nothing (ngramsTypeId ngt) (fromIntegral $ listTypeId l) 1
| (l,(ngt, ng)) <- lngs
]
------------------------------------------------------------------------
src/Gargantext/Database/Flow/Utils.hs
View file @ 9187d327
......@@ -56,7 +56,7 @@ data DocumentIdWithNgrams a =
-- | TODO for now, list Type is CandidateList, why ?
insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd err Int
insertToNodeNgrams m = insertNodeNgrams [ NodeNgram nId ((_ngramsId . _ngramsT) ng) ((ngramsTypeId . _ngramsType) ng) (listTypeId CandidateList) (fromIntegral n)
insertToNodeNgrams m = insertNodeNgrams [ NodeNgram nId ((_ngramsId . _ngramsT) ng) Nothing ((ngramsTypeId . _ngramsType) ng) (listTypeId CandidateList) (fromIntegral n)
| (ng, nId2int) <- DM.toList m
, (nId, n) <- DM.toList nId2int
]
......
src/Gargantext/Database/Schema/Ngrams.hs
View file @ 9187d327
This diff is collapsed.
src/Gargantext/Database/Schema/NodeNgram.hs
View file @ 9187d327
......@@ -16,15 +16,16 @@ if Node is a List then it is listing (either Stop, Candidate or Map)
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
-- TODO NodeNgrams
......@@ -32,26 +33,30 @@ module Gargantext.Database.Schema.NodeNgram where
import Data.ByteString (ByteString)
import Data.Text (Text)
import Debug.Trace (trace)
import Control.Lens.TH (makeLenses)
import Control.Monad (void)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core.Types.Main (ListTypeId)
import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
import Gargantext.Database.Types.Node (NodeId, ListId)
import Gargantext.Core.Types.Main (ListTypeId)
import Gargantext.Database.Types.Node (NodeId, ListId, NodeType(..))
import Gargantext.Database.Config (nodeTypeId, userMaster)
import Gargantext.Database.Schema.Node (pgNodeId)
import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId)
import Gargantext.Database.Schema.NodeNgramsNgrams (NgramsChild, NgramsParent, ngramsGroup, Action(..))
import Gargantext.Database.Schema.NodeNgramsNgrams (NgramsChild, NgramsParent, Action(..))
import Gargantext.Prelude
import Gargantext.Database.Utils (formatPGSQuery)
import Opaleye
import qualified Database.PostgreSQL.Simple as PGS (Only(..), Query)
-- | TODO : remove id
data NodeNgramPoly node_id ngrams_id ngrams_type list_type weight
data NodeNgramPoly node_id ngrams_id parent_id ngrams_type list_type weight
= NodeNgram { _nn_node_id :: node_id
, _nn_ngrams_id :: ngrams_id
, _nn_parent_id :: parent_id
, _nn_ngramsType :: ngrams_type
, _nn_listType :: list_type
, _nn_weight :: weight
......@@ -61,6 +66,8 @@ type NodeNgramWrite =
NodeNgramPoly
(Column PGInt4 )
(Column PGInt4 )
(Maybe (Column PGInt4))
(Column PGInt4 )
(Column PGInt4 )
(Column PGFloat8)
......@@ -69,6 +76,8 @@ type NodeNgramRead =
NodeNgramPoly
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGFloat8)
......@@ -77,12 +86,20 @@ type NodeNgramReadNull =
NodeNgramPoly
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGFloat8))
type NodeNgram =
NodeNgramPoly NodeId Int NgramsTypeId Int Double
NodeNgramPoly NodeId Int (Maybe NgramsParentId) NgramsTypeId Int Double
newtype NgramsParentId = NgramsParentId Int
deriving (Show, Eq, Num)
pgNgramsParentId :: NgramsParentId -> Column PGInt4
pgNgramsParentId (NgramsParentId n) = pgInt4 n
$(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
makeLenses ''NodeNgramPoly
......@@ -92,6 +109,7 @@ nodeNgramTable = Table "nodes_ngrams"
( pNodeNgram NodeNgram
{ _nn_node_id = required "node_id"
, _nn_ngrams_id = required "ngrams_id"
, _nn_parent_id = optional "parent_id"
, _nn_ngramsType = required "ngrams_type"
, _nn_listType = required "list_type"
, _nn_weight = required "weight"
......@@ -103,9 +121,10 @@ queryNodeNgramTable = queryTable nodeNgramTable
insertNodeNgrams :: [NodeNgram] -> Cmd err Int
insertNodeNgrams = insertNodeNgramW
. map (\(NodeNgram n g ngt lt w) ->
. map (\(NodeNgram n g p ngt lt w) ->
NodeNgram (pgNodeId n)
(pgInt4 g)
(pgNgramsParentId <$> p)
(pgNgramsTypeId ngt)
(pgInt4 lt)
(pgDouble w)
......@@ -150,17 +169,122 @@ UPDATE SET list_type = excluded.list_type
|]
ngramsGroup' :: Action -> [(ListId, NgramsTypeId, NgramsParent, NgramsChild)] -> Cmd err ()
ngramsGroup' _ [] = pure ()
ngramsGroup' a input = void $ trace (show input) $ execPGSQuery (ngramsGroupQuery a) (PGS.Only $ Values fields input')
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4","text","text"]
input' = map (\(lid,ntpid,p,c) -> (lid, nodeTypeId NodeList, userMaster, ntpid, p,c)) input
ngramsGroupQuery :: Action -> PGS.Query
ngramsGroupQuery a = case a of
Add -> [sql|
WITH input(lid,listTypeId,masterUsername,ntype,parent_terms,child_terms)
AS (?),
-- (VALUES (15::"int4",5::"int4",'gargantua'::"text",4::"int4",'input'::"text",'designer'::"text"))),
list_master AS (
SELECT n.id from nodes n
JOIN auth_user u ON n.user_id = u.id
JOIN input ON n.typename = input.listTypeId
WHERE u.username = input.masterUsername
LIMIT 1
),
list_user AS(
-- FIRST import parent from master to user list
INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
SELECT input.lid,nn.ngrams_id,nn.parent_id,nn.ngrams_type,nn.list_type, nn.weight
FROM INPUT
JOIN ngrams ng ON ng.terms = input.parent_terms
JOIN nodes_ngrams nn ON nn.ngrams_id = ng.id
JOIN list_master ON nn.node_id = list_master.id
WHERE
nn.ngrams_id = ng.id
ON CONFLICT (node_id,ngrams_id,ngrams_type) DO NOTHING
)
INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
SELECT input.lid, nc.id, nnpu.id, input.ntype, nnmaster.list_type, nnmaster.weight
FROM input
JOIN ngrams np ON np.terms = input.parent_terms
JOIN ngrams nc ON nc.terms = input.child_terms
JOIN nodes_ngrams nnpu ON nnpu.ngrams_id = np.id
JOIN nodes_ngrams nnmaster ON nnmaster.ngrams_id = nc.id
JOIN list_master ON nnmaster.node_id = list_master.id
WHERE
nnpu.node_id = input.lid
AND nnpu.ngrams_type = input.ntype
AND nnmaster.ngrams_id = nc.id
AND nnmaster.ngrams_type = ntype
ON CONFLICT (node_id,ngrams_id,ngrams_type) DO
UPDATE SET parent_id = excluded.parent_id
|]
Del -> [sql|
WITH input(lid,listTypeId,masterUsername,ntype,parent_terms,child_terms)
AS (?),
-- (VALUES (15::"int4",5::"int4",'gargantua'::"text",4::"int4",'input'::"text",'designer'::"text"))),
list_master AS (
SELECT n.id from nodes n
JOIN auth_user u ON n.user_id = u.id
JOIN input ON n.typename = input.listTypeId
WHERE u.username = input.masterUsername
LIMIT 1
),
list_user AS(
-- FIRST import parent from master to user list
INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
SELECT input.lid,nn.ngrams_id,nn.parent_id,nn.ngrams_type,nn.list_type, nn.weight
FROM INPUT
JOIN ngrams ng ON ng.terms = input.parent_terms
JOIN nodes_ngrams nn ON nn.ngrams_id = ng.id
JOIN list_master ON nn.node_id = list_master.id
WHERE
nn.ngrams_id = ng.id
ON CONFLICT (node_id,ngrams_id,ngrams_type) DO NOTHING
)
INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
SELECT input.lid, nc.id, NULL, input.ntype, nnmaster.list_type, nnmaster.weight
FROM input
JOIN ngrams np ON np.terms = input.parent_terms
JOIN ngrams nc ON nc.terms = input.child_terms
JOIN nodes_ngrams nnmaster ON nnmaster.ngrams_id = nc.id
JOIN list_master ON nnmaster.node_id = list_master.id
WHERE
nnmaster.ngrams_id = nc.id
AND nnmaster.ngrams_type = ntype
ON CONFLICT (node_id,ngrams_id,ngrams_type) DO
UPDATE SET parent_id = NULL
|]
data NodeNgramsUpdate = NodeNgramsUpdate
{ _nnu_lists_update :: [(ListId, NgramsTypeId, NgramsText, ListTypeId)]
, _nnu_add_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
, _nnu_rem_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
, _nnu_add_children :: [(ListId, NgramsTypeId, NgramsParent, NgramsChild)]
, _nnu_rem_children :: [(ListId, NgramsTypeId, NgramsParent, NgramsChild)]
}
-- TODO wrap these updates in a transaction.
updateNodeNgrams :: NodeNgramsUpdate -> Cmd err ()
updateNodeNgrams nnu = do
updateNodeNgrams' $ _nnu_lists_update nnu
ngramsGroup Del $ _nnu_rem_children nnu
ngramsGroup Add $ _nnu_add_children nnu
ngramsGroup' Add $ (trace $ show $ _nnu_add_children nnu) _nnu_add_children nnu
ngramsGroup' Del $ _nnu_rem_children nnu
src/Gargantext/Database/Schema/schema.sql
View file @ 9187d327
......@@ -54,12 +54,14 @@ CREATE TABLE public.nodes_ngrams (
id SERIAL,
node_id integer NOT NULL,
ngrams_id integer NOT NULL,
parent_id integer REFERENCES public.nodes_ngrams(id) ON DELETE SET NULL,
ngrams_type integer,
list_type integer,
weight double precision,
FOREIGN KEY (node_id) REFERENCES public.nodes(id) ON DELETE CASCADE,
FOREIGN KEY (ngrams_id) REFERENCES public.ngrams(id) ON DELETE CASCADE,
PRIMARY KEY (node_id,ngrams_id)
PRIMARY KEY (id)
-- PRIMARY KEY (node_id,ngrams_id)
);
ALTER TABLE public.nodes_ngrams OWNER TO gargantua;
......@@ -103,10 +105,10 @@ CREATE UNIQUE INDEX nodes_expr_idx2 ON public.nodes USING btree (((hyperdata ->>
CREATE UNIQUE INDEX nodes_typename_parent_id_expr_idx ON public.nodes USING btree (typename, parent_id, ((hyperdata ->> 'uniqId'::text)));
CREATE INDEX nodes_user_id_typename_parent_id_idx ON public.nodes USING btree (user_id, typename, parent_id);
CREATE UNIQUE INDEX ON public.ngrams(terms);
--CREATE UNIQUE INDEX ON public.ngrams(terms,n);
CREATE UNIQUE INDEX ON public.nodes_ngrams USING btree (node_id,ngrams_id);
CREATE INDEX nodes_ngrams_ngrams_id_idx ON public.nodes_ngrams USING btree (ngrams_id);
CREATE INDEX nodes_ngrams_ngrams_node_id_idx ON public.nodes_ngrams_ngrams USING btree (node_id);
CREATE UNIQUE INDEX ON public.nodes_ngrams USING btree (node_id,ngrams_id,ngrams_type);
......
src/Gargantext/Database/Tree.hs
View file @ 9187d327
......@@ -86,33 +86,24 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
dbTree :: RootId -> Cmd err [DbTreeNode]
dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
WITH RECURSIVE
-- starting node(s)
starting (id, typename, parent_id, name) AS
tree (id, typename, parent_id, name) AS
(
SELECT n.id, n.typename, n.parent_id, n.name
FROM nodes AS n
WHERE n.parent_id = ? -- this can be arbitrary
),
descendants (id, typename, parent_id, name) AS
(
SELECT id, typename, parent_id, name
FROM starting
UNION ALL
SELECT n.id, n.typename, n.parent_id, n.name
FROM nodes AS n JOIN descendants AS d ON n.parent_id = d.id
where n.typename in (2,3,30,31,5,7,9)
),
ancestors (id, typename, parent_id, name) AS
(
SELECT n.id, n.typename, n.parent_id, n.name
FROM nodes AS n
WHERE n.id IN (SELECT parent_id FROM starting)
UNION ALL
SELECT n.id, n.typename, n.parent_id, n.name
FROM nodes AS n JOIN ancestors AS a ON n.id = a.parent_id
SELECT p.id, p.typename, p.parent_id, p.name
FROM nodes AS p
WHERE p.id = ?
UNION
SELECT c.id, c.typename, c.parent_id, c.name
FROM nodes AS c
INNER JOIN tree AS s ON c.parent_id = s.id
WHERE c.typename IN (2,3,30,31,5,7,9)
)
TABLE ancestors
UNION ALL
TABLE descendants ;
SELECT * from tree;
|] (Only rootId)
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