Skip to content

haskell-gargantext
haskell-gargantext
Commit 0ee7da5d authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[API][NGRAMS] Table routes to patch (group and typeList).

parent cbc7f171
Show whitespace changes
Inline Side-by-side
Showing with 240 additions and 63 deletions
src/Gargantext/API/Ngrams.hs
View file @ 0ee7da5d
......@@ -30,35 +30,35 @@ add get
module Gargantext.API.Ngrams
where
import Prelude (Enum, Bounded, minBound, maxBound)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON)
import Data.Either(Either(Left))
import Data.Aeson.TH (deriveJSON)
import Database.PostgreSQL.Simple (Connection)
import Data.Map.Strict (Map)
import GHC.Generics (Generic)
--import qualified Data.Map.Strict as DM
-- import Gargantext.Database.User (UserId)
--import Data.Map.Strict.Patch (Patch, replace, fromList)
import Data.Text (Text)
--import Data.Maybe (catMaybes)
import Data.Set (Set)
--import qualified Data.Map.Strict as DM
--import qualified Data.Set as Set
import Control.Lens (view)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left))
import Data.List (concat)
import Data.Set (Set)
import Data.Swagger (ToSchema, ToParamSchema)
import Data.Text (Text)
import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
import Gargantext.Database.Ngram (NgramsId)
import Gargantext.Database.NodeNgram (updateNodeNgrams)
import Gargantext.Database.User (UserId)
import Gargantext.Text.List.Types (ListType(..))
import Gargantext.Core.Types (node_id)
import Gargantext.Core.Types.Main (Tree(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Ngrams (NgramsId)
import Gargantext.Database.Node (getListsWithParentId)
import Gargantext.Database.NodeNgram -- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly)
import Gargantext.Database.NodeNgramsNgrams -- (NodeNgramsNgramsPoly(NodeNgramsNgrams))
import Gargantext.Prelude
import Gargantext.Text.List.Types (ListType(..), listTypeId, ListId, ListTypeId)
import Prelude (Enum, Bounded, minBound, maxBound)
import Servant hiding (Patch)
import Data.Swagger (ToSchema, ToParamSchema)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.Set as Set
------------------------------------------------------------------------
--data FacetFormat = Table | Chart
......@@ -108,7 +108,7 @@ instance ToJSON (Tree NgramsElement)
-- | SetListType NgramsId ListType
data NgramsPatch =
NgramsPatch { _np_list_types :: Map UserId ListType
NgramsPatch { _np_list_types :: ListType -- TODO Map UserId ListType
, _np_add_children :: Set NgramsId
, _np_rem_children :: Set NgramsId
}
......@@ -178,7 +178,6 @@ ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ n
------------------------------------------------------------------------
------------------------------------------------------------------------
type CorpusId = Int
type ListId = Int
type TableNgramsApi = Summary " Table Ngrams API"
:> QueryParam "list" ListId
:> ReqBody '[JSON] NgramsIdPatchs
......@@ -188,27 +187,35 @@ type NgramsIdPatchsFeed = NgramsIdPatchs
type NgramsIdPatchsBack = NgramsIdPatchs
getDefaultList :: Connection -> CorpusId -> IO ListId
getDefaultList = undefined
defaultList :: Connection -> CorpusId -> IO ListId
defaultList c cId = view node_id <$> maybe (panic errorMessage) identity
<$> head
<$> getListsWithParentId c cId
where
errorMessage = "Gargantext.API.Ngrams.defaultList: no list found"
toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
toLists lId np = map (toList lId) (_nip_ngramsIdPatchs np)
type NgramsIdParent = Int
type NgramsIdChild = Int
toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
toList lId (NgramsIdPatch ngId (NgramsPatch lt _ _)) = (lId,ngId,listTypeId lt)
data Action = Del | Add
toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
doNgramsGroup :: Connection -> ListId -> Action -> [(NgramsIdParent, NgramsIdChild)] -> IO [Int]
doNgramsGroup = undefined
toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
toGroup lId addOrRem (NgramsIdPatch ngId patch) =
map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
tableNgramsPatch conn corpusId maybeList patchs = do
listId <- case maybeList of
Nothing -> getDefaultList conn corpusId
Nothing -> defaultList conn corpusId
Just listId' -> pure listId'
--_ <- doNgramsGroups conn listId Add $
--_ <- delNgramsGroups conn listId
--_ <- updateNodeNgrams conn
_ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
_ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
_ <- updateNodeNgrams conn (toLists listId patchs)
pure (NgramsIdPatchs [])
src/Gargantext/API/Node.hs
View file @ 0ee7da5d
......@@ -48,7 +48,7 @@ import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
import Servant
import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, tableNgramsPatch, NgramsIdPatchsFeed, NgramsIdPatchsBack, ListId)
import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, tableNgramsPatch, NgramsIdPatchsFeed, NgramsIdPatchsBack)
import Gargantext.Prelude
import Gargantext.Database.Types.Node
import Gargantext.Database.Node ( runCmd
......@@ -62,6 +62,7 @@ import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
import Gargantext.Database.NodeNode (nodesToFavorite, nodesToTrash)
-- Graph
import Gargantext.Text.Flow
import Gargantext.Text.List.Types (ListId)
import Gargantext.Viz.Graph (Graph)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types (Offset, Limit)
......
src/Gargantext/Database/Flow.hs
View file @ 0ee7da5d
......@@ -40,10 +40,10 @@ import Gargantext.Database.User (getUser, UserLight(..), Username)
import Gargantext.Database.Node.Document.Insert (insertDocuments, ReturnId(..), addUniqIds)
import Gargantext.Database.Node.Document.Add (add)
import Gargantext.Database.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
import Gargantext.Database.NodeNgramNgram (NodeNgramNgramPoly(..), insertNodeNgramNgram)
import Gargantext.Database.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
import Gargantext.Text.Parsers (parseDocs, FileFormat(WOS))
import Gargantext.Database.Ngram (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, ngramsTypeId)
import Gargantext.Database.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, ngramsTypeId)
type UserId = Int
type RootId = Int
......@@ -162,7 +162,7 @@ groupNgramsBy = undefined
insertGroups :: ListId -> Map NgramsIndexed NgramsIndexed -> Cmd Int
insertGroups lId ngrs =
insertNodeNgramNgram $ [ NodeNgramNgram lId ng1 ng2 (Just 1)
insertNodeNgramsNgramsNew $ [ NodeNgramsNgrams lId ng1 ng2 (Just 1)
| (ng1, ng2) <- map (both _ngramsId) $ DM.toList ngrs
]
......
src/Gargantext/Database/Ngram.hs → src/Gargantext/Database/Ngrams.hs
View file @ 0ee7da5d
{-|
Module : Gargantext.Database.Ngram
Module : Gargantext.Database.Ngrams
Description : Ngram connection to the Database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -21,7 +21,7 @@ Ngrams connection to the Database.
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Ngram where
module Gargantext.Database.Ngrams where
-- import Opaleye
import Control.Lens (makeLenses)
......
src/Gargantext/Database/Node.hs
View file @ 0ee7da5d
......@@ -66,6 +66,7 @@ import Opaleye hiding (FromField)
import Opaleye.Internal.QueryArr (Query)
import qualified Data.Profunctor.Product as PP
------------------------------------------------------------------------
------------------------------------------------------------------------
{- | Reader Monad reinvented here:
......@@ -110,6 +111,9 @@ instance FromField HyperdataDocumentV3 where
instance FromField HyperdataUser where
fromField = fromField'
instance FromField HyperdataList where
fromField = fromField'
instance FromField HyperdataAnnuaire where
fromField = fromField'
------------------------------------------------------------------------
......@@ -128,6 +132,9 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus where
instance QueryRunnerColumnDefault PGJsonb HyperdataUser where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataList where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire where
queryRunnerColumnDefault = fieldQueryRunnerColumn
------------------------------------------------------------------------
......@@ -275,20 +282,18 @@ getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just Nod
getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
------------------------------------------------------------------------
getListsWithParentId :: Connection -> Int -> IO [Node HyperdataList]
getListsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeList)
------------------------------------------------------------------------
selectNodesWithParentID :: Int -> Query NodeRead
selectNodesWithParentID n = proc () -> do
row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
restrict -< if n > 0
then
parent_id .== (toNullable $ pgInt4 n)
else
isNull parent_id
then parent_id .== (toNullable $ pgInt4 n)
else isNull parent_id
returnA -< row
selectNodesWithType :: Column PGInt4 -> Query NodeRead
selectNodesWithType type_id = proc () -> do
row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
......@@ -301,12 +306,10 @@ getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
getNode conn id _ = do
fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
getNodesWithType conn type_id = do
runQuery conn $ selectNodesWithType type_id
------------------------------------------------------------------------
-- WIP
-- TODO Classe HasDefault where
......
src/Gargantext/Database/NodeNgram.hs
View file @ 0ee7da5d
{-|
Module : Gargantext.Database.NodeNgram
Module : Gargantext.Database.NodeNgrams
Description : NodeNgram for Ngram indexation or Lists
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -21,16 +21,20 @@ if Node is a List then it is listing (either Stop, Candidate or Map)
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
-- TODO NodeNgrams
module Gargantext.Database.NodeNgram where
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Database.Ngrams (NgramsId)
import Gargantext.Text.List.Types (ListId, ListTypeId)
import Gargantext.Database.Node (mkCmd, Cmd(..))
import Gargantext.Prelude
import Opaleye
......@@ -94,10 +98,6 @@ insertNodeNgramW nns =
mkCmd $ \c -> fromIntegral
<$> runInsertMany c nodeNgramTable nns
-- TODO: remove these type (duplicate with others)
type ListId = Int
type NgramsId = Int
type ListTypeId = Int
updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsId, ListTypeId)] -> IO [PGS.Only Int]
updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ input)
......@@ -111,5 +111,3 @@ updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ i
RETURNING new.ngram_id
|]
src/Gargantext/Database/NodeNgramNgram.hs → src/Gargantext/Database/NodeNgramsNgrams.hs
View file @ 0ee7da5d
{-|
Module : Gargantext.Database.NodeNgramNgram
Module : Gargantext.Database.NodeNgramsNgrams
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -7,7 +7,7 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
NodeNgramNgram table is used to group Ngrams
NodeNgramsNgrams table is used to group Ngrams
- NodeId :: List Id
- NgramId_1, NgramId_2 where all NgramId_2 will be added to NgramId_1
- weight: probability of the relation (TODO, fixed to 1 for simple stemming)
......@@ -18,75 +18,79 @@ Next Step benchmark:
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.NodeNgramNgram
module Gargantext.Database.NodeNgramsNgrams
where
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Gargantext.Database.Node (mkCmd, Cmd(..))
import Gargantext.Prelude
import Opaleye
import qualified Database.PostgreSQL.Simple as PGS
import qualified Database.PostgreSQL.Simple as DPS
data NodeNgramNgramPoly node_id ngram1_id ngram2_id weight =
NodeNgramNgram { nng_NodeId :: node_id
, nng_Ngram1Id :: ngram1_id
, nng_Ngram2Id :: ngram2_id
, nng_Weight :: weight
data NodeNgramsNgramsPoly node_id ngram1_id ngram2_id weight =
NodeNgramsNgrams { _nng_NodeId :: node_id
, _nng_Ngram1Id :: ngram1_id
, _nng_Ngram2Id :: ngram2_id
, _nng_Weight :: weight
} deriving (Show)
type NodeNgramNgramWrite =
NodeNgramNgramPoly (Column PGInt4 )
type NodeNgramsNgramsWrite =
NodeNgramsNgramsPoly (Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Maybe (Column PGFloat8))
type NodeNgramNgramRead =
NodeNgramNgramPoly (Column PGInt4 )
type NodeNgramsNgramsRead =
NodeNgramsNgramsPoly (Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGFloat8)
type NodeNgramNgram =
NodeNgramNgramPoly Int
type NodeNgramsNgrams =
NodeNgramsNgramsPoly Int
Int
Int
(Maybe Double)
$(makeAdaptorAndInstance "pNodeNgramNgram"
''NodeNgramNgramPoly)
$(makeAdaptorAndInstance "pNodeNgramsNgrams"
''NodeNgramsNgramsPoly)
$(makeLensesWith abbreviatedFields
''NodeNgramNgramPoly)
''NodeNgramsNgramsPoly)
nodeNgramNgramTable :: Table NodeNgramNgramWrite NodeNgramNgramRead
nodeNgramNgramTable =
nodeNgramsNgramsTable :: Table NodeNgramsNgramsWrite NodeNgramsNgramsRead
nodeNgramsNgramsTable =
Table "nodes_ngrams_ngrams"
( pNodeNgramNgram NodeNgramNgram
{ nng_NodeId = required "node_id"
, nng_Ngram1Id = required "ngram1_id"
, nng_Ngram2Id = required "ngram2_id"
, nng_Weight = optional "weight"
( pNodeNgramsNgrams NodeNgramsNgrams
{ _nng_NodeId = required "node_id"
, _nng_Ngram1Id = required "ngram1_id"
, _nng_Ngram2Id = required "ngram2_id"
, _nng_Weight = optional "weight"
}
)
queryNodeNgramNgramTable :: Query NodeNgramNgramRead
queryNodeNgramNgramTable = queryTable nodeNgramNgramTable
queryNodeNgramsNgramsTable :: Query NodeNgramsNgramsRead
queryNodeNgramsNgramsTable = queryTable nodeNgramsNgramsTable
-- | Select NodeNgramNgram
-- | Select NodeNgramsNgrams
-- TODO not optimized (get all ngrams without filters)
nodeNgramNgram :: PGS.Connection -> IO [NodeNgramNgram]
nodeNgramNgram conn = runQuery conn queryNodeNgramNgramTable
nodeNgramsNgrams :: DPS.Connection -> IO [NodeNgramsNgrams]
nodeNgramsNgrams conn = runQuery conn queryNodeNgramsNgramsTable
instance QueryRunnerColumnDefault PGInt4 (Maybe Int) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......@@ -95,19 +99,62 @@ instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
insertNodeNgramNgram :: [NodeNgramNgram] -> Cmd Int
insertNodeNgramNgram = insertNodeNgramNgramW
. map (\(NodeNgramNgram n ng1 ng2 maybeWeight) ->
NodeNgramNgram (pgInt4 n)
-- TODO: Add option on conflict
insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd Int
insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
. map (\(NodeNgramsNgrams n ng1 ng2 maybeWeight) ->
NodeNgramsNgrams (pgInt4 n )
(pgInt4 ng1)
(pgInt4 ng2)
(pgDouble <$> maybeWeight)
)
insertNodeNgramNgramW :: [NodeNgramNgramWrite] -> Cmd Int
insertNodeNgramNgramW ns =
insertNodeNgramsNgramsW :: [NodeNgramsNgramsWrite] -> Cmd Int
insertNodeNgramsNgramsW ns =
mkCmd $ \c -> fromIntegral
<$> runInsertMany c nodeNgramNgramTable ns
<$> runInsertMany c nodeNgramsNgramsTable ns
------------------------------------------------------------------------
data Action = Del | Add
ngramsGroup :: Action -> [NodeNgramsNgrams] -> Cmd [Int]
ngramsGroup a ngs = mkCmd $ \c -> ngramsGroup' c a ngs
-- TODO: remove this function (use Reader Monad only)
ngramsGroup' :: DPS.Connection -> Action -> [NodeNgramsNgrams] -> IO [Int]
ngramsGroup' c action ngs = runNodeNgramsNgrams c q ngs
where
q = case action of
Del -> queryDelNodeNgramsNgrams
Add -> queryInsertNodeNgramsNgrams
runNodeNgramsNgrams :: DPS.Connection -> DPS.Query -> [NodeNgramsNgrams] -> IO [Int]
runNodeNgramsNgrams c q ngs = map (\(DPS.Only a) -> a) <$> DPS.query c q (DPS.Only $ Values fields ngs' )
where
ngs' = map (\(NodeNgramsNgrams n ng1 ng2 w) -> (n,ng1,ng2,maybe 0 identity w)) ngs
fields = map (\t -> QualifiedIdentifier Nothing t)
["int4","int4","int4","double"]
--------------------------------------------------------------------
-- TODO: on conflict update weight
queryInsertNodeNgramsNgrams :: DPS.Query
queryInsertNodeNgramsNgrams = [sql|
WITH input_rows(nId,ng1,ng2,w) AS (?)
, ins AS (
INSERT INTO nodes_ngrams_ngrams (node_id,ngram1_id,ngram2_id,weight)
SELECT * FROM input_rows
ON CONFLICT (node_id,ngram1_id,ngram2_id) DO NOTHING -- unique index created here
)
|]
queryDelNodeNgramsNgrams :: DPS.Query
queryDelNodeNgramsNgrams = [sql|
WITH input(nId,ng1,ng2,w) AS (?)
, DELETE FROM nodes_ngrams_ngrams
WHERE node_id = input.nId
AND ngram1_id = input.ng1
AND ngram2_id = input.ng2
;)
|]
src/Gargantext/Text/List/Types.hs
View file @ 0ee7da5d
......@@ -40,6 +40,14 @@ instance Arbitrary ListType where
type Lists = Map ListType (Map Text [Text])
type ListId = Int
type ListTypeId = Int
listTypeId :: ListType -> ListTypeId
listTypeId GraphList = 1
listTypeId StopList = 2
listTypeId CandidateList = 3
emptyLists :: Lists
emptyLists = fromList $ map (\lt -> (lt, empty))
......
src/Gargantext/Viz/Phylo.hs
View file @ 0ee7da5d
......@@ -33,7 +33,7 @@ import Data.Maybe (Maybe)
import Data.Text (Text)
import Data.Time.Clock.POSIX (POSIXTime)
import GHC.Generics (Generic)
import Gargantext.Database.Ngram (NgramsId)
import Gargantext.Database.Ngrams (NgramsId)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Prelude
......
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