Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
158
Issues
158
List
Board
Labels
Milestones
Merge Requests
11
Merge Requests
11
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
0acb0a1c
Commit
0acb0a1c
authored
Nov 23, 2018
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[NGRAMS][TAB] Table working (need to fix the cases with Terms.
parent
ea808e49
Pipeline
#16
failed with stage
Changes
13
Pipelines
2
Hide whitespace changes
Inline
Side-by-side
Showing
13 changed files
with
145 additions
and
120 deletions
+145
-120
gargantext.ini
gargantext.ini
+3
-0
API.hs
src/Gargantext/API.hs
+5
-7
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+38
-8
Node.hs
src/Gargantext/API/Node.hs
+5
-6
Main.hs
src/Gargantext/Core/Types/Main.hs
+14
-7
Config.hs
src/Gargantext/Database/Config.hs
+14
-2
Flow.hs
src/Gargantext/Database/Flow.hs
+9
-8
Ngrams.hs
src/Gargantext/Database/Ngrams.hs
+45
-19
Node.hs
src/Gargantext/Database/Node.hs
+6
-1
NodeNgram.hs
src/Gargantext/Database/NodeNgram.hs
+1
-2
Tree.hs
src/Gargantext/Database/Tree.hs
+4
-3
Utils.hs
src/Gargantext/Database/Utils.hs
+1
-0
Types.hs
src/Gargantext/Text/List/Types.hs
+0
-57
No files found.
gargantext.ini
View file @
0acb0a1c
[gargantext]
MASTER_USER
=
gargantua
[django]
# SECURITY WARNING: don't run with debug turned on in production!
...
...
src/Gargantext/API.hs
View file @
0acb0a1c
...
...
@@ -154,7 +154,7 @@ makeMockApp env = do
pure
$
logStdoutDev
$
checkOriginAndHost
$
corsMiddleware
$
serverApp
--
makeDevApp
::
Env
->
IO
Application
makeDevApp
env
=
do
serverApp
<-
makeApp
env
...
...
@@ -187,8 +187,6 @@ makeDevApp env = do
--pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
pure
$
logStdoutDev
$
corsMiddleware
$
serverApp
--
---------------------------------------------------------------------
-- | API Global
...
...
@@ -209,9 +207,9 @@ auth conn ar = liftIO $ auth' conn ar
type
GargAPI'
=
-- Auth endpoint
"auth"
:>
Summary
"AUTH API"
:>
ReqBody
'[
J
SON
]
AuthRequest
:>
Post
'[
J
SON
]
AuthResponse
"auth"
:>
Summary
"AUTH API"
:>
ReqBody
'[
J
SON
]
AuthRequest
:>
Post
'[
J
SON
]
AuthResponse
-- Roots endpoint
:<|>
"user"
:>
Summary
"First user endpoint"
...
...
@@ -255,7 +253,7 @@ type GargAPI' =
-- /mv/<id>/<id>
-- /merge/<id>/<id>
-- /rename/<id>
-- :<|> "static"
-- :<|> "static"
-- :<|> "list" :> Capture "id" Int :> NodeAPI
-- :<|> "ngrams" :> Capture "id" Int :> NodeAPI
-- :<|> "auth" :> Capture "id" Int :> NodeAPI
...
...
src/Gargantext/API/Ngrams.hs
View file @
0acb0a1c
...
...
@@ -33,6 +33,7 @@ add get
module
Gargantext.API.Ngrams
where
import
Prelude
(
round
)
-- import Gargantext.Database.User (UserId)
import
Data.Patch.Class
(
Replace
,
replace
)
--import qualified Data.Map.Strict.Patch as PM
...
...
@@ -47,7 +48,7 @@ import Control.Lens (view, (.~))
import
Data.Aeson
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Either
(
Either
(
Left
))
import
Data.
List
(
concat
)
import
Data.
Map
(
lookup
)
import
qualified
Data.HashMap.Strict.InsOrd
as
InsOrdHashMap
import
Data.Swagger
import
Data.Text
(
Text
)
...
...
@@ -56,12 +57,11 @@ import GHC.Generics (Generic)
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.
Types.Node
(
NodeType
(
..
)
)
import
Gargantext.Database.Node
(
getListsWithParentId
)
import
Gargantext.Database.NodeNgram
-- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly)
import
Gargantext.Database.NodeNgramsNgrams
-- (NodeNgramsNgramsPoly(NodeNgramsNgrams))
import
qualified
Gargantext.Database.Ngrams
as
Ngrams
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
Servant
hiding
(
Patch
)
import
Test.QuickCheck
(
elements
)
...
...
@@ -109,7 +109,7 @@ instance Arbitrary NgramsElement where
------------------------------------------------------------------------
newtype
NgramsTable
=
NgramsTable
{
_ngramsTable
::
[
NgramsElement
]
}
deriving
(
Ord
,
Eq
,
Generic
,
ToJSON
,
FromJSON
)
deriving
(
Ord
,
Eq
,
Generic
,
ToJSON
,
FromJSON
,
Show
)
instance
Arbitrary
NgramsTable
where
arbitrary
=
elements
...
...
@@ -286,5 +286,35 @@ tableNgramsPatch conn corpusId maybeList patchs = do
pure (NgramsIdPatchs [])
-}
getTableNgramsPatch
::
Connection
->
CorpusId
->
Maybe
TabType
->
Maybe
ListId
->
IO
NgramsTable
getTableNgramsPatch
=
undefined
-- | TODO Errors management
-- 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
src/Gargantext/API/Node.hs
View file @
0acb0a1c
...
...
@@ -48,7 +48,7 @@ import Database.PostgreSQL.Simple (Connection)
import
GHC.Generics
(
Generic
)
import
Servant
import
Gargantext.API.Ngrams
(
TabType
(
..
),
TableNgramsApi
,
TableNgramsApiGet
,
tableNgramsPatch
,
getTableNgrams
Patch
,
NgramsIdPatchsFeed
,
NgramsIdPatchsBack
,
NgramsTable
)
import
Gargantext.API.Ngrams
(
TabType
(
..
),
TableNgramsApi
,
TableNgramsApiGet
,
tableNgramsPatch
,
getTableNgrams
,
NgramsIdPatchsFeed
,
NgramsIdPatchsBack
,
NgramsTable
)
import
Gargantext.Prelude
import
Gargantext.Database.Types.Node
import
Gargantext.Database.Node
(
runCmd
...
...
@@ -62,11 +62,10 @@ 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
)
import
Gargantext.Core.Types.Main
(
Tree
,
NodeTree
)
import
Gargantext.Core.Types.Main
(
Tree
,
NodeTree
,
ListId
)
import
Gargantext.Text.Terms
(
TermType
(
..
))
import
Test.QuickCheck
(
elements
)
...
...
@@ -143,7 +142,7 @@ nodeAPI conn p id
-- TODO gather it
:<|>
getTable
conn
id
:<|>
tableNgramsPatch'
conn
id
:<|>
getTableNgrams
Patch
'
conn
id
:<|>
getTableNgrams'
conn
id
:<|>
getChart
conn
id
:<|>
favApi
conn
id
...
...
@@ -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'
c
cId
mL
ns
=
liftIO
$
tableNgramsPatch
c
cId
mL
ns
getTableNgrams
Patch
'
::
Connection
->
CorpusId
->
Maybe
TabType
->
Maybe
ListId
->
Handler
NgramsTable
getTableNgrams
Patch'
c
cId
nType
mL
=
liftIO
$
getTableNgramsPatch
c
cId
nType
mL
getTableNgrams'
::
Connection
->
CorpusId
->
Maybe
TabType
->
Maybe
ListId
->
Handler
NgramsTable
getTableNgrams
'
c
cId
nType
mL
=
liftIO
$
getTableNgrams
c
cId
nType
mL
query
::
Text
->
Handler
Text
query
s
=
pure
s
...
...
src/Gargantext/Core/Types/Main.hs
View file @
0acb0a1c
...
...
@@ -81,20 +81,27 @@ corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT
--data Classification = Favorites | MyClassifcation
type
ListId
=
Int
-- TODO multiple ListType declaration, remove it
data
ListType
=
Stop
|
Candidate
|
Map
data
ListType
=
Stop
List
|
CandidateList
|
GraphList
deriving
(
Generic
,
Eq
,
Ord
,
Show
,
Enum
,
Bounded
)
instance
ToJSON
ListType
instance
FromJSON
ListType
instance
ToSchema
ListType
instance
Arbitrary
ListType
where
arbitrary
=
elements
[
minBound
..
maxBound
]
type
ListTypeId
=
Int
list
Id
::
ListType
->
Int
list
Id
Stop
=
0
list
Id
Candidate
=
1
list
Id
Map
=
2
list
TypeId
::
ListType
->
ListTypeId
list
TypeId
StopList
=
0
list
TypeId
CandidateList
=
1
list
TypeId
GraphList
=
2
fromListTypeId
::
Int
->
Maybe
ListType
fromListTypeId
i
=
lookup
i
$
fromList
[
(
listId
l
,
l
)
|
l
<-
[
minBound
..
maxBound
]]
fromListTypeId
::
ListTypeId
->
Maybe
ListType
fromListTypeId
i
=
lookup
i
$
fromList
[
(
list
Type
Id
l
,
l
)
|
l
<-
[
minBound
..
maxBound
]]
-- data Metrics = Occurrences | Cooccurrences | Specclusion | Genclusion | Cvalue
-- | TfidfCorpus | TfidfGlobal | TirankLocal | TirankGlobal
...
...
src/Gargantext/Database/Config.hs
View file @
0acb0a1c
...
...
@@ -14,12 +14,13 @@ TODO: configure nodes table in Haskell (Config typenames etc.)
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module
Gargantext.Database.Config
where
import
Data.Text
(
pack
)
import
Data.Text
(
Text
,
pack
)
import
Data.Tuple.Extra
(
swap
)
import
Data.Maybe
(
fromMaybe
)
import
Data.List
(
lookup
)
...
...
@@ -27,6 +28,17 @@ import Data.List (lookup)
import
Gargantext.Database.Types.Node
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
n
=
case
n
of
...
...
@@ -45,7 +57,7 @@ nodeTypeId n =
---- Scores
-- NodeOccurrences -> 10
NodeGraph
->
9
NodeDashboard
->
5
NodeDashboard
->
7
NodeChart
->
51
-- Cooccurrences -> 9
...
...
src/Gargantext/Database/Flow.hs
View file @
0acb0a1c
...
...
@@ -33,8 +33,8 @@ import Data.Map (Map)
import
Data.Tuple.Extra
(
both
,
second
)
import
qualified
Data.Map
as
DM
import
Gargantext.Core.Types
(
NodePoly
(
..
),
ListType
(
..
),
listId
)
import
Gargantext.Database.Bashql
(
runCmd'
,
del
)
import
Gargantext.Core.Types
(
NodePoly
(
..
),
ListType
(
..
),
list
Type
Id
)
import
Gargantext.Database.Bashql
(
runCmd'
)
--
, del)
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.Document.Add
(
add
)
...
...
@@ -43,6 +43,7 @@ import Gargantext.Database.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
import
Gargantext.Database.NodeNgramsNgrams
(
NodeNgramsNgramsPoly
(
..
),
insertNodeNgramsNgramsNew
)
import
Gargantext.Database.Types.Node
(
HyperdataDocument
(
..
))
import
Gargantext.Database.User
(
getUser
,
UserLight
(
..
),
Username
)
import
Gargantext.Database.Config
(
userMaster
,
userArbitrary
,
corpusMasterName
)
import
Gargantext.Prelude
import
Gargantext.Text.Parsers
(
parseDocs
,
FileFormat
)
import
Gargantext.Ext.IMT
(
toSchoolName
)
...
...
@@ -51,11 +52,11 @@ type UserId = Int
type
RootId
=
Int
type
CorpusId
=
Int
--flowDatabase :: FileFormat -> FilePath -> CorpusName -> Cmd
Int
flowDatabase
::
FileFormat
->
FilePath
->
CorpusName
->
IO
Int
flowDatabase
ff
fp
cName
=
do
-- Corus Flow
(
masterUserId
,
_
,
corpusId
)
<-
subFlow
"gargantua"
"Big Corpus"
(
masterUserId
,
_
,
corpusId
)
<-
subFlow
userMaster
corpusMasterName
-- Documents Flow
hyperdataDocuments
<-
map
addUniqIds
<$>
parseDocs
ff
fp
...
...
@@ -65,7 +66,7 @@ flowDatabase ff fp cName = do
ids
<-
runCmd'
$
insertDocuments
masterUserId
corpusId
hyperdataDocuments
--printDebug "Docs IDs : " (ids)
idsRepeat
<-
runCmd'
$
insertDocuments
masterUserId
corpusId
hyperdataDocuments
--printDebug "Repeated Docs IDs : " (length ids
)
printDebug
"Repeated Docs IDs : "
(
length
idsRepeat
)
-- Ngrams Flow
-- todo: flow for new documents only
...
...
@@ -92,7 +93,7 @@ flowDatabase ff fp cName = do
listId2
<-
runCmd'
$
listFlow
masterUserId
corpusId
indexedNgrams
printDebug
"list id : "
listId2
(
userId
,
_
,
corpusId2
)
<-
subFlow
"user1"
cName
(
userId
,
_
,
corpusId2
)
<-
subFlow
userArbitrary
cName
userListId
<-
runCmd'
$
listFlowUser
userId
corpusId2
printDebug
"UserList : "
userListId
...
...
@@ -246,12 +247,12 @@ insertGroups lId ngrs =
------------------------------------------------------------------------
-- TODO: verify NgramsT lost here
ngrams2list
::
Map
(
NgramsT
NgramsIndexed
)
(
Map
NodeId
Int
)
->
[(
ListType
,
NgramsIndexed
)]
ngrams2list
=
zip
(
repeat
Candidate
)
.
map
(
\
(
NgramsT
_lost_t
ng
)
->
ng
)
.
DM
.
keys
ngrams2list
=
zip
(
repeat
Candidate
List
)
.
map
(
\
(
NgramsT
_lost_t
ng
)
->
ng
)
.
DM
.
keys
-- | TODO: weight of the list could be a probability
insertLists
::
ListId
->
[(
ListType
,
NgramsIndexed
)]
->
Cmd
Int
insertLists
lId
lngs
=
insertNodeNgrams
[
NodeNgram
Nothing
lId
ngr
(
fromIntegral
$
list
Id
l
)
(
list
Id
l
)
insertNodeNgrams
[
NodeNgram
Nothing
lId
ngr
(
fromIntegral
$
list
TypeId
l
)
(
listType
Id
l
)
|
(
l
,
ngr
)
<-
map
(
second
_ngramsId
)
lngs
]
...
...
src/Gargantext/Database/Ngrams.hs
View file @
0acb0a1c
...
...
@@ -25,10 +25,11 @@ module Gargantext.Database.Ngrams where
-- import Opaleye
import
Prelude
(
Enum
,
Bounded
,
minBound
,
maxBound
)
import
Control.Lens
(
makeLenses
)
import
Control.Lens
(
makeLenses
,
view
)
import
Data.ByteString.Internal
(
ByteString
)
import
Data.Map
(
Map
,
fromList
,
lookup
,
fromListWith
)
import
Data.Set
(
Set
)
import
Data.Tuple.Extra
(
both
)
import
qualified
Data.Set
as
DS
import
Data.Text
(
Text
,
splitOn
)
import
Database.PostgreSQL.Simple.FromRow
(
fromRow
,
field
)
...
...
@@ -37,14 +38,15 @@ import Database.PostgreSQL.Simple.ToField (toField)
import
Database.PostgreSQL.Simple.ToRow
(
toRow
)
import
Database.PostgreSQL.Simple.Types
(
Values
(
..
),
QualifiedIdentifier
(
..
))
import
GHC.Generics
(
Generic
)
import
Gargantext.Core.Types
(
fromListTypeId
,
ListType
)
import
Gargantext.Database.Config
(
nodeTypeId
)
import
Gargantext.Core.Types
-- (fromListTypeId, ListType, NodePoly(Node)
)
import
Gargantext.Database.Config
(
nodeTypeId
,
userMaster
)
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
qualified
Database.PostgreSQL.Simple
as
DPS
--data NgramPoly id terms n = NgramDb { ngram_id :: id
-- , ngram_terms :: terms
-- , ngram_n :: n
...
...
@@ -82,14 +84,14 @@ import qualified Database.PostgreSQL.Simple as DPS
-- ngrams in source field of document has Sources Type
-- ngrams in authors field of document has Authors Type
-- ngrams in text (title or abstract) of documents has Terms Type
data
NgramsType
=
Authors
|
Institutes
|
Sources
|
Terms
data
NgramsType
=
Authors
|
Institutes
|
Sources
|
Ngrams
Terms
deriving
(
Eq
,
Show
,
Ord
,
Enum
,
Bounded
)
ngramsTypeId
::
NgramsType
->
Int
ngramsTypeId
Authors
=
1
ngramsTypeId
Institutes
=
2
ngramsTypeId
Sources
=
3
ngramsTypeId
Terms
=
4
ngramsTypeId
Authors
=
1
ngramsTypeId
Institutes
=
2
ngramsTypeId
Sources
=
3
ngramsTypeId
NgramsTerms
=
4
fromNgramsTypeId
::
Int
->
Maybe
NgramsType
fromNgramsTypeId
id
=
lookup
id
$
fromList
[(
ngramsTypeId
nt
,
nt
)
|
nt
<-
[
minBound
..
maxBound
]
::
[
NgramsType
]]
...
...
@@ -182,6 +184,26 @@ queryInsertNgrams = [sql|
-- | 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
=
NgramsTableParam
{
_nt_listId
::
Int
...
...
@@ -191,21 +213,24 @@ data NgramsTableParam =
type
NgramsTableParamUser
=
NgramsTableParam
type
NgramsTableParamMaster
=
NgramsTableParam
data
NgramsTableData
=
NgramsTableData
{
_ntd_
terms
::
Text
,
_ntd_n
::
Int
data
NgramsTableData
=
NgramsTableData
{
_ntd_
ngrams
::
Text
,
_ntd_n
::
Int
,
_ntd_listType
::
Maybe
ListType
,
_ntd_weight
::
Double
,
_ntd_weight
::
Double
}
deriving
(
Show
)
getTableNgrams
::
NodeType
->
NgramsType
->
NgramsTableParamUser
->
NgramsTableParamMaster
->
Cmd
[
NgramsTableData
]
getTableNgrams
nodeT
ngrmT
(
NgramsTableParam
ul
uc
)
(
NgramsTableParam
ml
mc
)
=
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
)
getNgramsTableData
::
DPS
.
Connection
->
NodeType
->
NgramsType
->
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
nodeTId
=
nodeTypeId
nodeT
ngrmTId
=
ngramsTypeId
ngrmT
querySelectTableNgrams
::
DPS
.
Query
querySelectTableNgrams
=
[
sql
|
...
...
@@ -240,13 +265,13 @@ type ListIdUser = Int
type
ListIdMaster
=
Int
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
conn
lu
lm
=
do
groups
<-
getNgramsGroup'
conn
lu
lm
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
)
getNgramsGroup'
::
DPS
.
Connection
->
ListIdUser
->
ListIdMaster
->
IO
[(
Text
,
Text
)]
...
...
@@ -275,3 +300,4 @@ querySelectNgramsGroup = [sql|
, COALESCE(gu.t2,gm.t2) AS ngram2_id
FROM groupUser gu RIGHT JOIN groupMaster gm ON gu.t1 = gm.t1
|]
src/Gargantext/Database/Node.hs
View file @
0acb0a1c
...
...
@@ -235,7 +235,9 @@ selectNodesWith :: ParentId -> Maybe NodeType
->
Maybe
Offset
->
Maybe
Limit
->
Query
NodeRead
selectNodesWith
parentId
maybeNodeType
maybeOffset
maybeLimit
=
--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
maybeNodeType
=
proc
()
->
do
...
...
@@ -535,3 +537,6 @@ mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
mkList
::
ParentId
->
UserId
->
Cmd
[
Int
]
mkList
p
u
=
insertNodesR'
[
nodeListW
Nothing
Nothing
p
u
]
-- | Default CorpusId Master and ListId Master
src/Gargantext/Database/NodeNgram.hs
View file @
0acb0a1c
...
...
@@ -34,8 +34,7 @@ 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.Core.Types.Main
(
ListId
,
ListTypeId
)
import
Gargantext.Database.Node
(
mkCmd
,
Cmd
(
..
))
import
Gargantext.Prelude
import
Opaleye
...
...
src/Gargantext/Database/Tree.hs
View file @
0acb0a1c
...
...
@@ -15,7 +15,7 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
{-# LANGUAGE NoImplicitPrelude #-}
{-# 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.Monad.Error.Class
(
MonadError
(
throwError
))
...
...
@@ -81,7 +81,8 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: Int
,
dt_name
::
Text
}
deriving
(
Show
)
-- | Main DB Tree function
-- TODO add typenames as parameters
dbTree
::
Connection
->
RootId
->
IO
[
DbTreeNode
]
dbTree
conn
rootId
=
map
(
\
(
nId
,
tId
,
pId
,
n
)
->
DbTreeNode
nId
tId
pId
n
)
<$>
query
conn
[
sql
|
WITH RECURSIVE
...
...
@@ -99,7 +100,7 @@ dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> q
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)
where n.typename in (2,3,30,31
,5
)
),
ancestors (id, typename, parent_id, name) AS
(
...
...
src/Gargantext/Database/Utils.hs
View file @
0acb0a1c
...
...
@@ -60,3 +60,4 @@ connectGargandb fp = databaseParameters fp >>= \params -> connect params
printSql
::
Default
Unpackspec
a
a
=>
Query
a
->
IO
()
printSql
=
putStrLn
.
maybe
"Empty query"
identity
.
showSqlForPostgres
src/Gargantext/Text/List/Types.hs
deleted
100644 → 0
View file @
ea808e49
{-|
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
])
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment