Commit 0acb0a1c authored by Alexandre Delanoë's avatar Alexandre Delanoë

[NGRAMS][TAB] Table working (need to fix the cases with Terms.

parent ea808e49
[gargantext]
MASTER_USER = gargantua
[django] [django]
# SECURITY WARNING: don't run with debug turned on in production! # SECURITY WARNING: don't run with debug turned on in production!
......
...@@ -154,7 +154,7 @@ makeMockApp env = do ...@@ -154,7 +154,7 @@ makeMockApp env = do
pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
--
makeDevApp :: Env -> IO Application makeDevApp :: Env -> IO Application
makeDevApp env = do makeDevApp env = do
serverApp <- makeApp env serverApp <- makeApp env
...@@ -187,8 +187,6 @@ makeDevApp env = do ...@@ -187,8 +187,6 @@ makeDevApp env = do
--pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp) --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
pure $ logStdoutDev $ corsMiddleware $ serverApp pure $ logStdoutDev $ corsMiddleware $ serverApp
--
--------------------------------------------------------------------- ---------------------------------------------------------------------
-- | API Global -- | API Global
...@@ -209,9 +207,9 @@ auth conn ar = liftIO $ auth' conn ar ...@@ -209,9 +207,9 @@ auth conn ar = liftIO $ auth' conn ar
type GargAPI' = type GargAPI' =
-- Auth endpoint -- Auth endpoint
"auth" :> Summary "AUTH API" "auth" :> Summary "AUTH API"
:> ReqBody '[JSON] AuthRequest :> ReqBody '[JSON] AuthRequest
:> Post '[JSON] AuthResponse :> Post '[JSON] AuthResponse
-- Roots endpoint -- Roots endpoint
:<|> "user" :> Summary "First user endpoint" :<|> "user" :> Summary "First user endpoint"
...@@ -255,7 +253,7 @@ type GargAPI' = ...@@ -255,7 +253,7 @@ type GargAPI' =
-- /mv/<id>/<id> -- /mv/<id>/<id>
-- /merge/<id>/<id> -- /merge/<id>/<id>
-- /rename/<id> -- /rename/<id>
-- :<|> "static" -- :<|> "static"
-- :<|> "list" :> Capture "id" Int :> NodeAPI -- :<|> "list" :> Capture "id" Int :> NodeAPI
-- :<|> "ngrams" :> Capture "id" Int :> NodeAPI -- :<|> "ngrams" :> Capture "id" Int :> NodeAPI
-- :<|> "auth" :> Capture "id" Int :> NodeAPI -- :<|> "auth" :> Capture "id" Int :> NodeAPI
......
...@@ -33,6 +33,7 @@ add get ...@@ -33,6 +33,7 @@ add get
module Gargantext.API.Ngrams module Gargantext.API.Ngrams
where where
import Prelude (round)
-- import Gargantext.Database.User (UserId) -- import Gargantext.Database.User (UserId)
import Data.Patch.Class (Replace, replace) import Data.Patch.Class (Replace, replace)
--import qualified Data.Map.Strict.Patch as PM --import qualified Data.Map.Strict.Patch as PM
...@@ -47,7 +48,7 @@ import Control.Lens (view, (.~)) ...@@ -47,7 +48,7 @@ import Control.Lens (view, (.~))
import Data.Aeson import Data.Aeson
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left)) import Data.Either(Either(Left))
import Data.List (concat) import Data.Map (lookup)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Swagger import Data.Swagger
import Data.Text (Text) import Data.Text (Text)
...@@ -56,12 +57,11 @@ import GHC.Generics (Generic) ...@@ -56,12 +57,11 @@ import GHC.Generics (Generic)
import Gargantext.Core.Types (node_id) import Gargantext.Core.Types (node_id)
--import Gargantext.Core.Types.Main (Tree(..)) --import Gargantext.Core.Types.Main (Tree(..))
import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Ngrams (NgramsId) import Gargantext.Database.Types.Node (NodeType(..))
import Gargantext.Database.Node (getListsWithParentId) import Gargantext.Database.Node (getListsWithParentId)
import Gargantext.Database.NodeNgram -- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly) import qualified Gargantext.Database.Ngrams as Ngrams
import Gargantext.Database.NodeNgramsNgrams -- (NodeNgramsNgramsPoly(NodeNgramsNgrams))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Text.List.Types (ListType(..), ListId, ListTypeId) -- ,listTypeId ) import Gargantext.Core.Types (ListType(..), ListId)
import Prelude (Enum, Bounded, minBound, maxBound) import Prelude (Enum, Bounded, minBound, maxBound)
import Servant hiding (Patch) import Servant hiding (Patch)
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
...@@ -109,7 +109,7 @@ instance Arbitrary NgramsElement where ...@@ -109,7 +109,7 @@ instance Arbitrary NgramsElement where
------------------------------------------------------------------------ ------------------------------------------------------------------------
newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] } newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
deriving (Ord, Eq, Generic, ToJSON, FromJSON) deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
instance Arbitrary NgramsTable where instance Arbitrary NgramsTable where
arbitrary = elements arbitrary = elements
...@@ -286,5 +286,35 @@ tableNgramsPatch conn corpusId maybeList patchs = do ...@@ -286,5 +286,35 @@ tableNgramsPatch conn corpusId maybeList patchs = do
pure (NgramsIdPatchs []) pure (NgramsIdPatchs [])
-} -}
getTableNgramsPatch :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable -- | TODO Errors management
getTableNgramsPatch = undefined -- TODO: polymorphic for Annuaire or Corpus or ...
getTableNgrams :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
getTableNgrams c cId maybeTabType maybeListId = do
let lieu = "Garg.API.Ngrams: " :: Text
let ngramsType = 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.Sources
_ -> panic $ lieu <> "No Ngrams for this tab"
listId <- case maybeListId of
Nothing -> defaultList c cId
Just lId -> pure lId
(ngramsTableDatas, mapToParent, mapToChildren) <-
Ngrams.getNgramsTableDb c NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId)
printDebug "ngramsTableDatas" ngramsTableDatas
pure $ 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
...@@ -48,7 +48,7 @@ import Database.PostgreSQL.Simple (Connection) ...@@ -48,7 +48,7 @@ import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Servant import Servant
import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet,tableNgramsPatch, getTableNgramsPatch, NgramsIdPatchsFeed, NgramsIdPatchsBack, NgramsTable) import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet,tableNgramsPatch, getTableNgrams, NgramsIdPatchsFeed, NgramsIdPatchsBack, NgramsTable)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Database.Types.Node import Gargantext.Database.Types.Node
import Gargantext.Database.Node ( runCmd import Gargantext.Database.Node ( runCmd
...@@ -62,11 +62,10 @@ import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..)) ...@@ -62,11 +62,10 @@ import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
import Gargantext.Database.NodeNode (nodesToFavorite, nodesToTrash) import Gargantext.Database.NodeNode (nodesToFavorite, nodesToTrash)
-- Graph -- Graph
import Gargantext.Text.Flow import Gargantext.Text.Flow
import Gargantext.Text.List.Types (ListId)
import Gargantext.Viz.Graph (Graph) import Gargantext.Viz.Graph (Graph)
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Core.Types (Offset, Limit) import Gargantext.Core.Types (Offset, Limit)
import Gargantext.Core.Types.Main (Tree, NodeTree) import Gargantext.Core.Types.Main (Tree, NodeTree, ListId)
import Gargantext.Text.Terms (TermType(..)) import Gargantext.Text.Terms (TermType(..))
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
...@@ -143,7 +142,7 @@ nodeAPI conn p id ...@@ -143,7 +142,7 @@ nodeAPI conn p id
-- TODO gather it -- TODO gather it
:<|> getTable conn id :<|> getTable conn id
:<|> tableNgramsPatch' conn id :<|> tableNgramsPatch' conn id
:<|> getTableNgramsPatch' conn id :<|> getTableNgrams' conn id
:<|> getChart conn id :<|> getChart conn id
:<|> favApi conn id :<|> favApi conn id
...@@ -289,8 +288,8 @@ getNodesWith' conn id p nodeType offset limit = liftIO (getNodesWith conn id p ...@@ -289,8 +288,8 @@ getNodesWith' conn id p nodeType offset limit = liftIO (getNodesWith conn id p
tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
getTableNgramsPatch' :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> Handler NgramsTable getTableNgrams' :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> Handler NgramsTable
getTableNgramsPatch' c cId nType mL = liftIO $ getTableNgramsPatch c cId nType mL getTableNgrams' c cId nType mL = liftIO $ getTableNgrams c cId nType mL
query :: Text -> Handler Text query :: Text -> Handler Text
query s = pure s query s = pure s
......
...@@ -81,20 +81,27 @@ corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT ...@@ -81,20 +81,27 @@ corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT
--data Classification = Favorites | MyClassifcation --data Classification = Favorites | MyClassifcation
type ListId = Int
-- TODO multiple ListType declaration, remove it -- TODO multiple ListType declaration, remove it
data ListType = Stop | Candidate | Map data ListType = StopList | CandidateList | GraphList
deriving (Generic, Eq, Ord, Show, Enum, Bounded) deriving (Generic, Eq, Ord, Show, Enum, Bounded)
instance ToJSON ListType instance ToJSON ListType
instance FromJSON ListType instance FromJSON ListType
instance ToSchema ListType
instance Arbitrary ListType where
arbitrary = elements [minBound..maxBound]
type ListTypeId = Int
listId :: ListType -> Int listTypeId :: ListType -> ListTypeId
listId Stop = 0 listTypeId StopList = 0
listId Candidate = 1 listTypeId CandidateList = 1
listId Map = 2 listTypeId GraphList = 2
fromListTypeId :: Int -> Maybe ListType fromListTypeId :: ListTypeId -> Maybe ListType
fromListTypeId i = lookup i $ fromList [ (listId l, l) | l <- [minBound..maxBound]] fromListTypeId i = lookup i $ fromList [ (listTypeId l, l) | l <- [minBound..maxBound]]
-- data Metrics = Occurrences | Cooccurrences | Specclusion | Genclusion | Cvalue -- data Metrics = Occurrences | Cooccurrences | Specclusion | Genclusion | Cvalue
-- | TfidfCorpus | TfidfGlobal | TirankLocal | TirankGlobal -- | TfidfCorpus | TfidfGlobal | TirankLocal | TirankGlobal
......
...@@ -14,12 +14,13 @@ TODO: configure nodes table in Haskell (Config typenames etc.) ...@@ -14,12 +14,13 @@ TODO: configure nodes table in Haskell (Config typenames etc.)
-} -}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Config module Gargantext.Database.Config
where where
import Data.Text (pack) import Data.Text (Text,pack)
import Data.Tuple.Extra (swap) import Data.Tuple.Extra (swap)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List (lookup) import Data.List (lookup)
...@@ -27,6 +28,17 @@ import Data.List (lookup) ...@@ -27,6 +28,17 @@ import Data.List (lookup)
import Gargantext.Database.Types.Node import Gargantext.Database.Types.Node
import Gargantext.Prelude import Gargantext.Prelude
-- TODO put this in config.ini file
corpusMasterName :: Text
corpusMasterName = "Main"
userMaster :: Text
userMaster = "gargantua"
userArbitrary :: Text
userArbitrary = "user1"
nodeTypeId :: NodeType -> NodeTypeId nodeTypeId :: NodeType -> NodeTypeId
nodeTypeId n = nodeTypeId n =
case n of case n of
...@@ -45,7 +57,7 @@ nodeTypeId n = ...@@ -45,7 +57,7 @@ nodeTypeId n =
---- Scores ---- Scores
-- NodeOccurrences -> 10 -- NodeOccurrences -> 10
NodeGraph -> 9 NodeGraph -> 9
NodeDashboard -> 5 NodeDashboard -> 7
NodeChart -> 51 NodeChart -> 51
-- Cooccurrences -> 9 -- Cooccurrences -> 9
......
...@@ -33,8 +33,8 @@ import Data.Map (Map) ...@@ -33,8 +33,8 @@ import Data.Map (Map)
import Data.Tuple.Extra (both, second) import Data.Tuple.Extra (both, second)
import qualified Data.Map as DM import qualified Data.Map as DM
import Gargantext.Core.Types (NodePoly(..), ListType(..), listId) import Gargantext.Core.Types (NodePoly(..), ListType(..), listTypeId)
import Gargantext.Database.Bashql (runCmd', del) import Gargantext.Database.Bashql (runCmd') -- , del)
import Gargantext.Database.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, ngramsTypeId, NgramsType(..), text2ngrams) import Gargantext.Database.Ngrams (insertNgrams, Ngrams(..), NgramsT(..), NgramsIndexed(..), indexNgramsT, ngramsTypeId, NgramsType(..), text2ngrams)
import Gargantext.Database.Node (getRoot, mkRoot, mkCorpus, Cmd(..), mkList) import Gargantext.Database.Node (getRoot, mkRoot, mkCorpus, Cmd(..), mkList)
import Gargantext.Database.Node.Document.Add (add) import Gargantext.Database.Node.Document.Add (add)
...@@ -43,6 +43,7 @@ import Gargantext.Database.NodeNgram (NodeNgramPoly(..), insertNodeNgrams) ...@@ -43,6 +43,7 @@ import Gargantext.Database.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
import Gargantext.Database.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew) import Gargantext.Database.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
import Gargantext.Database.Types.Node (HyperdataDocument(..)) import Gargantext.Database.Types.Node (HyperdataDocument(..))
import Gargantext.Database.User (getUser, UserLight(..), Username) import Gargantext.Database.User (getUser, UserLight(..), Username)
import Gargantext.Database.Config (userMaster, userArbitrary, corpusMasterName)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Text.Parsers (parseDocs, FileFormat) import Gargantext.Text.Parsers (parseDocs, FileFormat)
import Gargantext.Ext.IMT (toSchoolName) import Gargantext.Ext.IMT (toSchoolName)
...@@ -51,11 +52,11 @@ type UserId = Int ...@@ -51,11 +52,11 @@ type UserId = Int
type RootId = Int type RootId = Int
type CorpusId = Int type CorpusId = Int
--flowDatabase :: FileFormat -> FilePath -> CorpusName -> Cmd Int flowDatabase :: FileFormat -> FilePath -> CorpusName -> IO Int
flowDatabase ff fp cName = do flowDatabase ff fp cName = do
-- Corus Flow -- Corus Flow
(masterUserId, _, corpusId) <- subFlow "gargantua" "Big Corpus" (masterUserId, _, corpusId) <- subFlow userMaster corpusMasterName
-- Documents Flow -- Documents Flow
hyperdataDocuments <- map addUniqIds <$> parseDocs ff fp hyperdataDocuments <- map addUniqIds <$> parseDocs ff fp
...@@ -65,7 +66,7 @@ flowDatabase ff fp cName = do ...@@ -65,7 +66,7 @@ flowDatabase ff fp cName = do
ids <- runCmd' $ insertDocuments masterUserId corpusId hyperdataDocuments ids <- runCmd' $ insertDocuments masterUserId corpusId hyperdataDocuments
--printDebug "Docs IDs : " (ids) --printDebug "Docs IDs : " (ids)
idsRepeat <- runCmd' $ insertDocuments masterUserId corpusId hyperdataDocuments idsRepeat <- runCmd' $ insertDocuments masterUserId corpusId hyperdataDocuments
--printDebug "Repeated Docs IDs : " (length ids) printDebug "Repeated Docs IDs : " (length idsRepeat)
-- Ngrams Flow -- Ngrams Flow
-- todo: flow for new documents only -- todo: flow for new documents only
...@@ -92,7 +93,7 @@ flowDatabase ff fp cName = do ...@@ -92,7 +93,7 @@ flowDatabase ff fp cName = do
listId2 <- runCmd' $ listFlow masterUserId corpusId indexedNgrams listId2 <- runCmd' $ listFlow masterUserId corpusId indexedNgrams
printDebug "list id : " listId2 printDebug "list id : " listId2
(userId, _, corpusId2) <- subFlow "user1" cName (userId, _, corpusId2) <- subFlow userArbitrary cName
userListId <- runCmd' $ listFlowUser userId corpusId2 userListId <- runCmd' $ listFlowUser userId corpusId2
printDebug "UserList : " userListId printDebug "UserList : " userListId
...@@ -246,12 +247,12 @@ insertGroups lId ngrs = ...@@ -246,12 +247,12 @@ insertGroups lId ngrs =
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- TODO: verify NgramsT lost here -- TODO: verify NgramsT lost here
ngrams2list :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> [(ListType,NgramsIndexed)] ngrams2list :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> [(ListType,NgramsIndexed)]
ngrams2list = zip (repeat Candidate) . map (\(NgramsT _lost_t ng) -> ng) . DM.keys ngrams2list = zip (repeat CandidateList) . map (\(NgramsT _lost_t ng) -> ng) . DM.keys
-- | TODO: weight of the list could be a probability -- | TODO: weight of the list could be a probability
insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd Int insertLists :: ListId -> [(ListType,NgramsIndexed)] -> Cmd Int
insertLists lId lngs = insertLists lId lngs =
insertNodeNgrams [ NodeNgram Nothing lId ngr (fromIntegral $ listId l) (listId l) insertNodeNgrams [ NodeNgram Nothing lId ngr (fromIntegral $ listTypeId l) (listTypeId l)
| (l,ngr) <- map (second _ngramsId) lngs | (l,ngr) <- map (second _ngramsId) lngs
] ]
......
...@@ -25,10 +25,11 @@ module Gargantext.Database.Ngrams where ...@@ -25,10 +25,11 @@ module Gargantext.Database.Ngrams where
-- import Opaleye -- import Opaleye
import Prelude (Enum, Bounded, minBound, maxBound) import Prelude (Enum, Bounded, minBound, maxBound)
import Control.Lens (makeLenses) import Control.Lens (makeLenses, view)
import Data.ByteString.Internal (ByteString) import Data.ByteString.Internal (ByteString)
import Data.Map (Map, fromList, lookup, fromListWith) import Data.Map (Map, fromList, lookup, fromListWith)
import Data.Set (Set) import Data.Set (Set)
import Data.Tuple.Extra (both)
import qualified Data.Set as DS import qualified Data.Set as DS
import Data.Text (Text, splitOn) import Data.Text (Text, splitOn)
import Database.PostgreSQL.Simple.FromRow (fromRow, field) import Database.PostgreSQL.Simple.FromRow (fromRow, field)
...@@ -37,14 +38,15 @@ import Database.PostgreSQL.Simple.ToField (toField) ...@@ -37,14 +38,15 @@ import Database.PostgreSQL.Simple.ToField (toField)
import Database.PostgreSQL.Simple.ToRow (toRow) import Database.PostgreSQL.Simple.ToRow (toRow)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..)) import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Gargantext.Core.Types (fromListTypeId, ListType) import Gargantext.Core.Types -- (fromListTypeId, ListType, NodePoly(Node))
import Gargantext.Database.Config (nodeTypeId) import Gargantext.Database.Config (nodeTypeId,userMaster)
import Gargantext.Database.Types.Node (NodeType) import Gargantext.Database.Types.Node (NodeType)
import Gargantext.Database.Node (mkCmd, Cmd(..)) import Gargantext.Database.Node (mkCmd, Cmd(..),getRootUsername)
import Gargantext.Database.Tree (dbTree, toNodeTree)
import Gargantext.Core.Types.Main (NodeTree(..))
import Gargantext.Prelude import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS import qualified Database.PostgreSQL.Simple as DPS
--data NgramPoly id terms n = NgramDb { ngram_id :: id --data NgramPoly id terms n = NgramDb { ngram_id :: id
-- , ngram_terms :: terms -- , ngram_terms :: terms
-- , ngram_n :: n -- , ngram_n :: n
...@@ -82,14 +84,14 @@ import qualified Database.PostgreSQL.Simple as DPS ...@@ -82,14 +84,14 @@ import qualified Database.PostgreSQL.Simple as DPS
-- ngrams in source field of document has Sources Type -- ngrams in source field of document has Sources Type
-- ngrams in authors field of document has Authors Type -- ngrams in authors field of document has Authors Type
-- ngrams in text (title or abstract) of documents has Terms Type -- ngrams in text (title or abstract) of documents has Terms Type
data NgramsType = Authors | Institutes | Sources | Terms data NgramsType = Authors | Institutes | Sources | NgramsTerms
deriving (Eq, Show, Ord, Enum, Bounded) deriving (Eq, Show, Ord, Enum, Bounded)
ngramsTypeId :: NgramsType -> Int ngramsTypeId :: NgramsType -> Int
ngramsTypeId Authors = 1 ngramsTypeId Authors = 1
ngramsTypeId Institutes = 2 ngramsTypeId Institutes = 2
ngramsTypeId Sources = 3 ngramsTypeId Sources = 3
ngramsTypeId Terms = 4 ngramsTypeId NgramsTerms = 4
fromNgramsTypeId :: Int -> Maybe NgramsType fromNgramsTypeId :: Int -> Maybe NgramsType
fromNgramsTypeId id = lookup id $ fromList [(ngramsTypeId nt,nt) | nt <- [minBound .. maxBound] :: [NgramsType]] fromNgramsTypeId id = lookup id $ fromList [(ngramsTypeId nt,nt) | nt <- [minBound .. maxBound] :: [NgramsType]]
...@@ -182,6 +184,26 @@ queryInsertNgrams = [sql| ...@@ -182,6 +184,26 @@ queryInsertNgrams = [sql|
-- | Ngrams Table -- | Ngrams Table
-- TODO: the way we are getting main Master Corpus and List ID is not clean
-- TODO: if ids are not present -> create
-- TODO: Global Env State Monad to keep in memory the ids without retrieving it each time
getNgramsTableDb :: DPS.Connection
-> NodeType -> NgramsType
-> NgramsTableParamUser
-> IO ([NgramsTableData], MapToParent, MapToChildren)
getNgramsTableDb c nt ngrt ntp@(NgramsTableParam listIdUser _) = do
let lieu = "Garg.Db.Ngrams.getTableNgrams: "
maybeRoot <- head <$> getRootUsername userMaster c
let masterRootId = maybe (panic $ lieu <> "no userMaster Tree") (view node_id) maybeRoot
tree <- map toNodeTree <$> dbTree c masterRootId
let maybeCorpus = head $ filter (\n -> _nt_type n == NodeCorpus) tree
let maybeList = head $ filter (\n -> _nt_type n == NodeList) tree
let maybeIds = fmap (both _nt_id) $ (,) <$> maybeCorpus <*> maybeList
let (corpusMasterId, listMasterId) = maybe (panic $ lieu <> "no CorpusId or ListId") identity maybeIds
ngramsTableData <- getNgramsTableData c nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId)
(mapToParent,mapToChildren) <- getNgramsGroup c listIdUser listMasterId
pure (ngramsTableData, mapToParent,mapToChildren)
data NgramsTableParam = data NgramsTableParam =
NgramsTableParam { _nt_listId :: Int NgramsTableParam { _nt_listId :: Int
...@@ -191,21 +213,24 @@ data NgramsTableParam = ...@@ -191,21 +213,24 @@ data NgramsTableParam =
type NgramsTableParamUser = NgramsTableParam type NgramsTableParamUser = NgramsTableParam
type NgramsTableParamMaster = NgramsTableParam type NgramsTableParamMaster = NgramsTableParam
data NgramsTableData = NgramsTableData { _ntd_terms :: Text data NgramsTableData = NgramsTableData { _ntd_ngrams :: Text
, _ntd_n :: Int , _ntd_n :: Int
, _ntd_listType :: Maybe ListType , _ntd_listType :: Maybe ListType
, _ntd_weight :: Double , _ntd_weight :: Double
} deriving (Show) } deriving (Show)
getTableNgrams :: NodeType -> NgramsType -> NgramsTableParamUser -> NgramsTableParamMaster -> Cmd [NgramsTableData] getNgramsTableData :: DPS.Connection
getTableNgrams nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) = -> NodeType -> NgramsType
mkCmd $ \conn -> map (\(t,n,nt,w) -> NgramsTableData t n (fromListTypeId nt) w) <$> DPS.query conn querySelectTableNgrams (ul,uc,nodeTId,ngrmTId,ml,mc,nodeTId,ngrmTId) -> NgramsTableParamUser -> NgramsTableParamMaster
-> IO [NgramsTableData]
getNgramsTableData conn nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) =
map (\(t,n,nt,w) -> NgramsTableData t n (fromListTypeId nt) w)
<$> DPS.query conn querySelectTableNgrams (ul,uc,nodeTId,ngrmTId,ml,mc,nodeTId,ngrmTId)
where where
nodeTId = nodeTypeId nodeT nodeTId = nodeTypeId nodeT
ngrmTId = ngramsTypeId ngrmT ngrmTId = ngramsTypeId ngrmT
querySelectTableNgrams :: DPS.Query querySelectTableNgrams :: DPS.Query
querySelectTableNgrams = [sql| querySelectTableNgrams = [sql|
...@@ -240,13 +265,13 @@ type ListIdUser = Int ...@@ -240,13 +265,13 @@ type ListIdUser = Int
type ListIdMaster = Int type ListIdMaster = Int
type MapToChildren = Map Text (Set Text) type MapToChildren = Map Text (Set Text)
type MapToParent = Map Text (Set Text) type MapToParent = Map Text Text
getNgramsGroup :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO (MapToParent, MapToChildren) getNgramsGroup :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO (MapToParent, MapToChildren)
getNgramsGroup conn lu lm = do getNgramsGroup conn lu lm = do
groups <- getNgramsGroup' conn lu lm groups <- getNgramsGroup' conn lu lm
let mapChildren = fromListWith (<>) $ map (\(a,b) -> (a, DS.singleton b)) groups let mapChildren = fromListWith (<>) $ map (\(a,b) -> (a, DS.singleton b)) groups
let mapParent = fromListWith (<>) $ map (\(a,b) -> (b, DS.singleton a)) groups let mapParent = fromListWith (<>) $ map (\(a,b) -> (b, a)) groups
pure (mapParent, mapChildren) pure (mapParent, mapChildren)
getNgramsGroup' :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO [(Text,Text)] getNgramsGroup' :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO [(Text,Text)]
...@@ -275,3 +300,4 @@ querySelectNgramsGroup = [sql| ...@@ -275,3 +300,4 @@ querySelectNgramsGroup = [sql|
, COALESCE(gu.t2,gm.t2) AS ngram2_id , COALESCE(gu.t2,gm.t2) AS ngram2_id
FROM groupUser gu RIGHT JOIN groupMaster gm ON gu.t1 = gm.t1 FROM groupUser gu RIGHT JOIN groupMaster gm ON gu.t1 = gm.t1
|] |]
...@@ -235,7 +235,9 @@ selectNodesWith :: ParentId -> Maybe NodeType ...@@ -235,7 +235,9 @@ selectNodesWith :: ParentId -> Maybe NodeType
-> Maybe Offset -> Maybe Limit -> Query NodeRead -> Maybe Offset -> Maybe Limit -> Query NodeRead
selectNodesWith parentId maybeNodeType maybeOffset maybeLimit = selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
--offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
limit' maybeLimit $ offset' maybeOffset $ orderBy (asc _node_id) $ selectNodesWith' parentId maybeNodeType limit' maybeLimit $ offset' maybeOffset
$ orderBy (asc _node_id)
$ selectNodesWith' parentId maybeNodeType
selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' parentId maybeNodeType = proc () -> do selectNodesWith' parentId maybeNodeType = proc () -> do
...@@ -535,3 +537,6 @@ mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u] ...@@ -535,3 +537,6 @@ mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
mkList :: ParentId -> UserId -> Cmd [Int] mkList :: ParentId -> UserId -> Cmd [Int]
mkList p u = insertNodesR' [nodeListW Nothing Nothing p u] mkList p u = insertNodesR' [nodeListW Nothing Nothing p u]
-- | Default CorpusId Master and ListId Master
...@@ -34,8 +34,7 @@ import Control.Lens.TH (makeLensesWith, abbreviatedFields) ...@@ -34,8 +34,7 @@ import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance) import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..)) import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Database.Ngrams (NgramsId) import Gargantext.Core.Types.Main (ListId, ListTypeId)
import Gargantext.Text.List.Types (ListId, ListTypeId)
import Gargantext.Database.Node (mkCmd, Cmd(..)) import Gargantext.Database.Node (mkCmd, Cmd(..))
import Gargantext.Prelude import Gargantext.Prelude
import Opaleye import Opaleye
......
...@@ -15,7 +15,7 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph ...@@ -15,7 +15,7 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..)) where module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
import Control.Lens (Prism', (#), (^..), at, each, _Just, to) import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
import Control.Monad.Error.Class (MonadError(throwError)) import Control.Monad.Error.Class (MonadError(throwError))
...@@ -81,7 +81,8 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: Int ...@@ -81,7 +81,8 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: Int
, dt_name :: Text , dt_name :: Text
} deriving (Show) } deriving (Show)
-- | Main DB Tree function
-- TODO add typenames as parameters
dbTree :: Connection -> RootId -> IO [DbTreeNode] dbTree :: Connection -> RootId -> IO [DbTreeNode]
dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> query conn [sql| dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> query conn [sql|
WITH RECURSIVE WITH RECURSIVE
...@@ -99,7 +100,7 @@ dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> q ...@@ -99,7 +100,7 @@ dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> q
UNION ALL UNION ALL
SELECT n.id, n.typename, n.parent_id, n.name SELECT n.id, n.typename, n.parent_id, n.name
FROM nodes AS n JOIN descendants AS d ON n.parent_id = d.id FROM nodes AS n JOIN descendants AS d ON n.parent_id = d.id
where n.typename in (2,3,30,31) where n.typename in (2,3,30,31,5)
), ),
ancestors (id, typename, parent_id, name) AS ancestors (id, typename, parent_id, name) AS
( (
......
...@@ -60,3 +60,4 @@ connectGargandb fp = databaseParameters fp >>= \params -> connect params ...@@ -60,3 +60,4 @@ connectGargandb fp = databaseParameters fp >>= \params -> connect params
printSql :: Default Unpackspec a a => Query a -> IO () printSql :: Default Unpackspec a a => Query a -> IO ()
printSql = putStrLn . maybe "Empty query" identity . showSqlForPostgres printSql = putStrLn . maybe "Empty query" identity . showSqlForPostgres
{-|
Module : Gargantext.Text.List.Types
Description :
Copyright : (c) CNRS, 2018-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
CSV parser for Gargantext corpus files.
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Text.List.Types where
import Data.Aeson (FromJSON, ToJSON)
import Data.Map (Map, empty, fromList)
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.Prelude
import Prelude (Bounded, Enum, minBound, maxBound)
import Data.Swagger (ToSchema)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-------------------------------------------------------------------
-- TODO : clean multiples types declaration
data ListType = GraphList | StopList | CandidateList
deriving (Show, Eq, Ord, Enum, Bounded, Generic)
instance FromJSON ListType
instance ToJSON ListType
instance ToSchema ListType
instance Arbitrary ListType where
arbitrary = elements [minBound..maxBound]
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))
([minBound..maxBound] :: [ListType])
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