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
a37be465
Commit
a37be465
authored
Dec 10, 2020
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
[MERGE]
parents
167b8698
c02e87d8
Pipeline
#1290
failed with stage
Changes
5
Pipelines
2
Show whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
41 additions
and
35 deletions
+41
-35
Search.hs
src/Gargantext/API/Search.hs
+1
-1
Learn.hs
src/Gargantext/Database/Action/Learn.hs
+3
-3
Search.hs
src/Gargantext/Database/Action/Search.hs
+7
-6
Facet.hs
src/Gargantext/Database/Query/Facet.hs
+17
-11
Tree.hs
src/Gargantext/Database/Query/Tree.hs
+13
-14
No files found.
src/Gargantext/API/Search.hs
View file @
a37be465
...
@@ -191,7 +191,7 @@ class ToRow a where
...
@@ -191,7 +191,7 @@ class ToRow a where
toRow
::
a
->
Row
toRow
::
a
->
Row
instance
ToRow
FacetDoc
where
instance
ToRow
FacetDoc
where
toRow
(
FacetDoc
nId
utc
t
h
mc
md
)
=
Document
nId
utc
t
(
toHyperdataRow
h
)
(
fromMaybe
0
mc
)
(
round
$
fromMaybe
0
md
)
toRow
(
FacetDoc
nId
utc
t
h
mc
_md
sc
)
=
Document
nId
utc
t
(
toHyperdataRow
h
)
(
fromMaybe
0
mc
)
(
round
$
fromMaybe
0
sc
)
-- | TODO rename FacetPaired
-- | TODO rename FacetPaired
type
FacetContact
=
FacetPaired
Int
UTCTime
HyperdataContact
Int
type
FacetContact
=
FacetPaired
Int
UTCTime
HyperdataContact
Int
...
...
src/Gargantext/Database/Action/Learn.hs
View file @
a37be465
...
@@ -41,7 +41,7 @@ moreLike cId o _l order ft = do
...
@@ -41,7 +41,7 @@ moreLike cId o _l order ft = do
getPriors
::
FavOrTrash
->
CorpusId
->
Cmd
err
(
Events
Bool
)
getPriors
::
FavOrTrash
->
CorpusId
->
Cmd
err
(
Events
Bool
)
getPriors
ft
cId
=
do
getPriors
ft
cId
=
do
docs_fav
<-
filter
(
\
(
FacetDoc
_
_
_
_
f
_
)
->
f
==
Just
2
)
docs_fav
<-
filter
(
\
(
FacetDoc
_
_
_
_
f
_
_
)
->
f
==
Just
2
)
<$>
runViewDocuments
cId
False
Nothing
Nothing
Nothing
Nothing
<$>
runViewDocuments
cId
False
Nothing
Nothing
Nothing
Nothing
docs_trash
<-
List
.
take
(
List
.
length
docs_fav
)
docs_trash
<-
List
.
take
(
List
.
length
docs_fav
)
...
@@ -58,7 +58,7 @@ moreLikeWith :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
...
@@ -58,7 +58,7 @@ moreLikeWith :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
->
FavOrTrash
->
Events
Bool
->
Cmd
err
[
FacetDoc
]
->
FavOrTrash
->
Events
Bool
->
Cmd
err
[
FacetDoc
]
moreLikeWith
cId
o
l
order
ft
priors
=
do
moreLikeWith
cId
o
l
order
ft
priors
=
do
docs_test
<-
filter
(
\
(
FacetDoc
_
_
_
_
f
_
)
->
f
==
Just
1
)
docs_test
<-
filter
(
\
(
FacetDoc
_
_
_
_
f
_
_
)
->
f
==
Just
1
)
<$>
runViewDocuments
cId
False
o
Nothing
order
Nothing
<$>
runViewDocuments
cId
False
o
Nothing
order
Nothing
let
results
=
map
fst
let
results
=
map
fst
...
@@ -73,7 +73,7 @@ fav2bool ft = if (==) ft IsFav then True else False
...
@@ -73,7 +73,7 @@ fav2bool ft = if (==) ft IsFav then True else False
text
::
FacetDoc
->
Text
text
::
FacetDoc
->
Text
text
(
FacetDoc
_
_
_
h
_
_
)
=
title
<>
""
<>
Text
.
take
100
abstr
text
(
FacetDoc
_
_
_
h
_
_
_
)
=
title
<>
""
<>
Text
.
take
100
abstr
where
where
title
=
maybe
""
identity
(
_hd_title
h
)
title
=
maybe
""
identity
(
_hd_title
h
)
abstr
=
maybe
""
identity
(
_hd_abstract
h
)
abstr
=
maybe
""
identity
(
_hd_abstract
h
)
...
...
src/Gargantext/Database/Action/Search.hs
View file @
a37be465
...
@@ -91,8 +91,9 @@ queryInCorpus cId t q = proc () -> do
...
@@ -91,8 +91,9 @@ queryInCorpus cId t q = proc () -> do
returnA
-<
FacetDoc
(
n
^.
ns_id
)
returnA
-<
FacetDoc
(
n
^.
ns_id
)
(
n
^.
ns_date
)
(
n
^.
ns_date
)
(
n
^.
ns_name
)
(
n
^.
ns_name
)
(
n
^.
ns_hyperdata
)
(
n
^.
ns_hyperdata
)
(
nn
^.
nn_category
)
(
nn
^.
nn_category
)
(
nn
^.
nn_score
)
(
nn
^.
nn_score
)
(
nn
^.
nn_score
)
joinInCorpus
::
O
.
Query
(
NodeSearchRead
,
NodeNodeReadNull
)
joinInCorpus
::
O
.
Query
(
NodeSearchRead
,
NodeNodeReadNull
)
...
...
src/Gargantext/Database/Query/Facet.hs
View file @
a37be465
...
@@ -76,19 +76,20 @@ type Category = Int
...
@@ -76,19 +76,20 @@ type Category = Int
type
Title
=
Text
type
Title
=
Text
-- TODO remove Title
-- TODO remove Title
type
FacetDoc
=
Facet
NodeId
UTCTime
Title
HyperdataDocument
(
Maybe
Category
)
(
Maybe
Double
)
type
FacetDoc
=
Facet
NodeId
UTCTime
Title
HyperdataDocument
(
Maybe
Category
)
(
Maybe
Double
)
(
Maybe
Double
)
-- type FacetSources = FacetDoc
-- type FacetSources = FacetDoc
-- type FacetAuthors = FacetDoc
-- type FacetAuthors = FacetDoc
-- type FacetTerms = FacetDoc
-- type FacetTerms = FacetDoc
data
Facet
id
created
title
hyperdata
category
ngramCount
=
data
Facet
id
created
title
hyperdata
category
ngramCount
score
=
FacetDoc
{
facetDoc_id
::
id
FacetDoc
{
facetDoc_id
::
id
,
facetDoc_created
::
created
,
facetDoc_created
::
created
,
facetDoc_title
::
title
,
facetDoc_title
::
title
,
facetDoc_hyperdata
::
hyperdata
,
facetDoc_hyperdata
::
hyperdata
,
facetDoc_category
::
category
,
facetDoc_category
::
category
,
facetDoc_score
::
ngramCount
,
facetDoc_ngramCount
::
ngramCount
,
facetDoc_score
::
score
}
deriving
(
Show
,
Generic
)
}
deriving
(
Show
,
Generic
)
{- | TODO after demo
{- | TODO after demo
data Facet id date hyperdata score =
data Facet id date hyperdata score =
...
@@ -99,8 +100,9 @@ data Facet id date hyperdata score =
...
@@ -99,8 +100,9 @@ data Facet id date hyperdata score =
} deriving (Show, Generic)
} deriving (Show, Generic)
-}
-}
data
Pair
i
l
=
Pair
{
_p_id
::
i
data
Pair
i
l
=
Pair
{
,
_p_label
::
l
_p_id
::
i
,
_p_label
::
l
}
deriving
(
Show
,
Generic
)
}
deriving
(
Show
,
Generic
)
$
(
deriveJSON
(
unPrefix
"_p_"
)
''
P
air
)
$
(
deriveJSON
(
unPrefix
"_p_"
)
''
P
air
)
$
(
makeAdaptorAndInstance
"pPair"
''
P
air
)
$
(
makeAdaptorAndInstance
"pPair"
''
P
air
)
...
@@ -175,13 +177,14 @@ instance ToSchema FacetDoc where
...
@@ -175,13 +177,14 @@ instance ToSchema FacetDoc where
-- | Mock and Quickcheck instances
-- | Mock and Quickcheck instances
instance
Arbitrary
FacetDoc
where
instance
Arbitrary
FacetDoc
where
arbitrary
=
elements
[
FacetDoc
id'
(
jour
year
01
01
)
t
hp
(
Just
cat
)
(
Just
ngramCount
)
arbitrary
=
elements
[
FacetDoc
id'
(
jour
year
01
01
)
t
hp
(
Just
cat
)
(
Just
ngramCount
)
(
Just
score
)
|
id'
<-
[
1
..
10
]
|
id'
<-
[
1
..
10
]
,
year
<-
[
1990
..
2000
]
,
year
<-
[
1990
..
2000
]
,
t
<-
[
"title"
,
"another title"
]
,
t
<-
[
"title"
,
"another title"
]
,
hp
<-
arbitraryHyperdataDocuments
,
hp
<-
arbitraryHyperdataDocuments
,
cat
<-
[
0
..
2
]
,
cat
<-
[
0
..
2
]
,
ngramCount
<-
[
3
..
100
]
,
ngramCount
<-
[
3
..
100
]
,
score
<-
[
3
..
100
]
]
]
-- Facets / Views for the Front End
-- Facets / Views for the Front End
...
@@ -194,6 +197,7 @@ type FacetDocRead = Facet (Column PGInt4 )
...
@@ -194,6 +197,7 @@ type FacetDocRead = Facet (Column PGInt4 )
(
Column
PGText
)
(
Column
PGText
)
(
Column
PGJsonb
)
(
Column
PGJsonb
)
(
Column
(
Nullable
PGInt4
))
-- Category
(
Column
(
Nullable
PGInt4
))
-- Category
(
Column
(
Nullable
PGFloat8
))
-- Ngrams Count
(
Column
(
Nullable
PGFloat8
))
-- Score
(
Column
(
Nullable
PGFloat8
))
-- Score
-----------------------------------------------------------------------
-----------------------------------------------------------------------
...
@@ -252,6 +256,7 @@ viewAuthorsDoc cId _ nt = proc () -> do
...
@@ -252,6 +256,7 @@ viewAuthorsDoc cId _ nt = proc () -> do
(
_node_hyperdata
doc
)
(
_node_hyperdata
doc
)
(
toNullable
$
pgInt4
1
)
(
toNullable
$
pgInt4
1
)
(
toNullable
$
pgDouble
1
)
(
toNullable
$
pgDouble
1
)
(
toNullable
$
pgDouble
1
)
queryAuthorsDoc
::
Query
(
NodeRead
,
(
NodeNodeNgramsReadNull
,
(
NgramsReadNull
,
(
NodeNodeNgramsReadNull
,
NodeReadNull
))))
queryAuthorsDoc
::
Query
(
NodeRead
,
(
NodeNodeNgramsReadNull
,
(
NgramsReadNull
,
(
NodeNodeNgramsReadNull
,
NodeReadNull
))))
queryAuthorsDoc
=
leftJoin5
queryNodeTable
queryNodeNodeNgramsTable
queryNgramsTable
queryNodeNodeNgramsTable
queryNodeTable
cond12
cond23
cond34
cond45
queryAuthorsDoc
=
leftJoin5
queryNodeTable
queryNodeNodeNgramsTable
queryNgramsTable
queryNodeNodeNgramsTable
queryNodeTable
cond12
cond23
cond34
cond45
...
@@ -318,20 +323,21 @@ viewDocuments cId t ntId mQuery = proc () -> do
...
@@ -318,20 +323,21 @@ viewDocuments cId t ntId mQuery = proc () -> do
(
_node_hyperdata
n
)
(
_node_hyperdata
n
)
(
toNullable
$
nn
^.
nn_category
)
(
toNullable
$
nn
^.
nn_category
)
(
toNullable
$
nn
^.
nn_score
)
(
toNullable
$
nn
^.
nn_score
)
(
toNullable
$
nn
^.
nn_score
)
------------------------------------------------------------------------
------------------------------------------------------------------------
filterWith
::
(
PGOrd
date
,
PGOrd
title
,
PGOrd
score
,
hyperdata
~
Column
SqlJsonb
)
=>
filterWith
::
(
PGOrd
date
,
PGOrd
title
,
PGOrd
category
,
PGOrd
score
,
hyperdata
~
Column
SqlJsonb
)
=>
Maybe
Gargantext
.
Core
.
Types
.
Offset
Maybe
Gargantext
.
Core
.
Types
.
Offset
->
Maybe
Gargantext
.
Core
.
Types
.
Limit
->
Maybe
Gargantext
.
Core
.
Types
.
Limit
->
Maybe
OrderBy
->
Maybe
OrderBy
->
Select
(
Facet
id
(
Column
date
)
(
Column
title
)
hyperdata
(
Column
score
)
ngramCount
)
->
Select
(
Facet
id
(
Column
date
)
(
Column
title
)
hyperdata
(
Column
category
)
ngramCount
(
Column
score
)
)
->
Select
(
Facet
id
(
Column
date
)
(
Column
title
)
hyperdata
(
Column
score
)
ngramCount
)
->
Select
(
Facet
id
(
Column
date
)
(
Column
title
)
hyperdata
(
Column
category
)
ngramCount
(
Column
score
)
)
filterWith
o
l
order
q
=
limit'
l
$
offset'
o
$
orderBy
(
orderWith
order
)
q
filterWith
o
l
order
q
=
limit'
l
$
offset'
o
$
orderBy
(
orderWith
order
)
q
orderWith
::
(
PGOrd
b1
,
PGOrd
b2
,
PGOrd
b3
)
orderWith
::
(
PGOrd
b1
,
PGOrd
b2
,
PGOrd
b3
)
=>
Maybe
OrderBy
=>
Maybe
OrderBy
->
Order
(
Facet
id
(
Column
b1
)
(
Column
b2
)
(
Column
SqlJsonb
)
(
Column
b3
)
score
)
->
Order
(
Facet
id
(
Column
b1
)
(
Column
b2
)
(
Column
SqlJsonb
)
(
Column
b3
)
ngramCount
score
)
orderWith
(
Just
DateAsc
)
=
asc
facetDoc_created
orderWith
(
Just
DateAsc
)
=
asc
facetDoc_created
orderWith
(
Just
DateDesc
)
=
desc
facetDoc_created
orderWith
(
Just
DateDesc
)
=
desc
facetDoc_created
...
@@ -347,6 +353,6 @@ orderWith (Just SourceDesc) = desc facetDoc_source
...
@@ -347,6 +353,6 @@ orderWith (Just SourceDesc) = desc facetDoc_source
orderWith
_
=
asc
facetDoc_created
orderWith
_
=
asc
facetDoc_created
facetDoc_source
::
PGIsJson
a
facetDoc_source
::
PGIsJson
a
=>
Facet
id
created
title
(
Column
a
)
favorite
ngramCount
=>
Facet
id
created
title
(
Column
a
)
favorite
ngramCount
score
->
Column
(
Nullable
PGText
)
->
Column
(
Nullable
PGText
)
facetDoc_source
x
=
toNullable
(
facetDoc_hyperdata
x
)
.->>
pgString
"source"
facetDoc_source
x
=
toNullable
(
facetDoc_hyperdata
x
)
.->>
pgString
"source"
src/Gargantext/Database/Query/Tree.hs
View file @
a37be465
...
@@ -36,7 +36,7 @@ module Gargantext.Database.Query.Tree
...
@@ -36,7 +36,7 @@ module Gargantext.Database.Query.Tree
where
where
import
Control.Lens
(
view
,
toListOf
,
at
,
each
,
_Just
,
to
,
set
,
makeLenses
)
import
Control.Lens
(
view
,
toListOf
,
at
,
each
,
_Just
,
to
,
set
,
makeLenses
)
import
Control.Monad.E
xcept
(
MonadError
())
import
Control.Monad.E
rror.Class
(
MonadError
())
import
Data.List
(
tail
,
concat
,
nub
)
import
Data.List
(
tail
,
concat
,
nub
)
import
Data.Map
(
Map
,
fromListWith
,
lookup
)
import
Data.Map
(
Map
,
fromListWith
,
lookup
)
import
qualified
Data.Set
as
Set
import
qualified
Data.Set
as
Set
...
@@ -209,7 +209,6 @@ toTree m =
...
@@ -209,7 +209,6 @@ toTree m =
->
NodeTree
->
NodeTree
toNodeTree
(
DbTreeNode
nId
tId
_
n
)
=
NodeTree
n
(
fromNodeTypeId
tId
)
nId
toNodeTree
(
DbTreeNode
nId
tId
_
n
)
=
NodeTree
n
(
fromNodeTypeId
tId
)
nId
------------------------------------------------------------------------
------------------------------------------------------------------------
toTreeParent
::
[
DbTreeNode
]
toTreeParent
::
[
DbTreeNode
]
->
Map
(
Maybe
ParentId
)
[
DbTreeNode
]
->
Map
(
Maybe
ParentId
)
[
DbTreeNode
]
...
...
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