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
25e6254d
Commit
25e6254d
authored
Dec 04, 2020
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[FIX] Shared corpus in the same hierarchy for now
parent
4c6051cc
Pipeline
#1274
failed with stage
Changes
4
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
28 additions
and
13 deletions
+28
-13
List.hs
src/Gargantext/Core/Text/List.hs
+20
-9
Social.hs
src/Gargantext/Core/Text/List/Social.hs
+3
-3
Find.hs
src/Gargantext/Core/Text/List/Social/Find.hs
+4
-1
Prelude.hs
src/Gargantext/Core/Text/List/Social/Prelude.hs
+1
-0
No files found.
src/Gargantext/Core/Text/List.hs
View file @
25e6254d
...
@@ -56,7 +56,6 @@ isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
...
@@ -56,7 +56,6 @@ isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
-}
-}
-- | TODO improve grouping functions of Authors, Sources, Institutes..
-- | TODO improve grouping functions of Authors, Sources, Institutes..
buildNgramsLists
::
(
RepoCmdM
env
err
m
buildNgramsLists
::
(
RepoCmdM
env
err
m
,
CmdM
env
err
m
,
CmdM
env
err
m
...
@@ -95,17 +94,20 @@ buildNgramsOthersList user uCid groupParams (nt, MapListSize mapListSize) = do
...
@@ -95,17 +94,20 @@ buildNgramsOthersList user uCid groupParams (nt, MapListSize mapListSize) = do
allTerms
::
Map
Text
(
Set
NodeId
)
<-
getNodesByNgramsUser
uCid
nt
allTerms
::
Map
Text
(
Set
NodeId
)
<-
getNodesByNgramsUser
uCid
nt
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists
'
::
FlowCont
Text
FlowListScores
socialLists
::
FlowCont
Text
FlowListScores
<-
flowSocialList
'
MySelfFirst
user
nt
(
FlowCont
Map
.
empty
<-
flowSocialList
MySelfFirst
user
nt
(
FlowCont
Map
.
empty
$
Map
.
fromList
$
Map
.
fromList
$
List
.
zip
(
Map
.
keys
allTerms
)
$
List
.
zip
(
Map
.
keys
allTerms
)
(
List
.
cycle
[
mempty
])
(
List
.
cycle
[
mempty
])
)
)
let
let
groupedWithList
=
toGroupedTree
groupParams
socialLists
'
allTerms
groupedWithList
=
toGroupedTree
groupParams
socialLists
allTerms
let
let
(
stopTerms
,
tailTerms
)
=
Map
.
partition
((
==
Just
StopTerm
)
.
viewListType
)
$
view
flc_scores
groupedWithList
(
stopTerms
,
tailTerms
)
=
Map
.
partition
((
==
Just
StopTerm
)
.
viewListType
)
$
view
flc_scores
groupedWithList
(
mapTerms
,
tailTerms'
)
=
Map
.
partition
((
==
Just
MapTerm
)
.
viewListType
)
tailTerms
(
mapTerms
,
tailTerms'
)
=
Map
.
partition
((
==
Just
MapTerm
)
.
viewListType
)
tailTerms
listSize
=
mapListSize
-
(
List
.
length
mapTerms
)
listSize
=
mapListSize
-
(
List
.
length
mapTerms
)
...
@@ -140,17 +142,21 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
...
@@ -140,17 +142,21 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
allTerms
::
Map
Text
Double
<-
getTficf
uCid
mCid
nt
allTerms
::
Map
Text
Double
<-
getTficf
uCid
mCid
nt
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists
'
::
FlowCont
Text
FlowListScores
socialLists
::
FlowCont
Text
FlowListScores
<-
flowSocialList
'
MySelfFirst
user
nt
(
FlowCont
Map
.
empty
<-
flowSocialList
MySelfFirst
user
nt
(
FlowCont
Map
.
empty
$
Map
.
fromList
$
Map
.
fromList
$
List
.
zip
(
Map
.
keys
allTerms
)
$
List
.
zip
(
Map
.
keys
allTerms
)
(
List
.
cycle
[
mempty
])
(
List
.
cycle
[
mempty
])
)
)
let
groupedWithList
=
toGroupedTree
groupParams
socialLists'
allTerms
let
groupedWithList
=
toGroupedTree
groupParams
socialLists
allTerms
(
stopTerms
,
candidateTerms
)
=
Map
.
partition
((
==
Just
StopTerm
)
.
viewListType
)
(
stopTerms
,
candidateTerms
)
=
Map
.
partition
((
==
Just
StopTerm
)
.
viewListType
)
$
view
flc_scores
groupedWithList
$
view
flc_scores
groupedWithList
(
groupedMono
,
groupedMult
)
=
Map
.
partitionWithKey
(
\
t
_v
->
size
t
<
2
)
candidateTerms
(
groupedMono
,
groupedMult
)
=
Map
.
partitionWithKey
(
\
t
_v
->
size
t
<
2
)
candidateTerms
-- printDebug "stopTerms" stopTerms
-- splitting monterms and multiterms to take proportional candidates
-- splitting monterms and multiterms to take proportional candidates
let
let
-- use % of list if to big, or Int if too small
-- use % of list if to big, or Int if too small
...
@@ -206,7 +212,10 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
...
@@ -206,7 +212,10 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
let
let
groupedTreeScores_SpeGen
::
Map
Text
(
GroupedTreeScores
(
Scored
Text
))
groupedTreeScores_SpeGen
::
Map
Text
(
GroupedTreeScores
(
Scored
Text
))
groupedTreeScores_SpeGen
=
setScoresWithMap
(
mapScores
identity
)
(
groupedMonoHead
<>
groupedMultHead
)
groupedTreeScores_SpeGen
=
setScoresWithMap
(
mapScores
identity
)
(
groupedMonoHead
<>
groupedMultHead
)
let
let
-- sort / partition / split
-- sort / partition / split
...
@@ -267,4 +276,6 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
...
@@ -267,4 +276,6 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
)]
)]
]
]
-- printDebug "result" result
pure
result
pure
result
src/Gargantext/Core/Text/List/Social.hs
View file @
25e6254d
...
@@ -36,7 +36,7 @@ import Gargantext.Prelude
...
@@ -36,7 +36,7 @@ import Gargantext.Prelude
data
FlowSocialListPriority
=
MySelfFirst
|
OthersFirst
data
FlowSocialListPriority
=
MySelfFirst
|
OthersFirst
flowSocialListPriority
::
FlowSocialListPriority
->
[
NodeMode
]
flowSocialListPriority
::
FlowSocialListPriority
->
[
NodeMode
]
flowSocialListPriority
MySelfFirst
=
[
Private
,
Shared
{-
, Public -}
]
flowSocialListPriority
MySelfFirst
=
[
Private
{-, Shared
, Public -}
]
flowSocialListPriority
OthersFirst
=
reverse
$
flowSocialListPriority
MySelfFirst
flowSocialListPriority
OthersFirst
=
reverse
$
flowSocialListPriority
MySelfFirst
...
@@ -46,7 +46,7 @@ keepAllParents NgramsTerms = KeepAllParents False
...
@@ -46,7 +46,7 @@ keepAllParents NgramsTerms = KeepAllParents False
keepAllParents
_
=
KeepAllParents
True
keepAllParents
_
=
KeepAllParents
True
------------------------------------------------------------------------
------------------------------------------------------------------------
flowSocialList
'
::
(
RepoCmdM
env
err
m
flowSocialList
::
(
RepoCmdM
env
err
m
,
CmdM
env
err
m
,
CmdM
env
err
m
,
HasNodeError
err
,
HasNodeError
err
,
HasTreeError
err
,
HasTreeError
err
...
@@ -55,7 +55,7 @@ flowSocialList' :: ( RepoCmdM env err m
...
@@ -55,7 +55,7 @@ flowSocialList' :: ( RepoCmdM env err m
->
User
->
NgramsType
->
User
->
NgramsType
->
FlowCont
Text
FlowListScores
->
FlowCont
Text
FlowListScores
->
m
(
FlowCont
Text
FlowListScores
)
->
m
(
FlowCont
Text
FlowListScores
)
flowSocialList
'
flowPriority
user
nt
flc
=
flowSocialList
flowPriority
user
nt
flc
=
mconcat
<$>
mapM
(
flowSocialListByMode'
user
nt
flc
)
mconcat
<$>
mapM
(
flowSocialListByMode'
user
nt
flc
)
(
flowSocialListPriority
flowPriority
)
(
flowSocialListPriority
flowPriority
)
where
where
...
...
src/Gargantext/Core/Text/List/Social/Find.hs
View file @
25e6254d
...
@@ -38,7 +38,10 @@ findNodes' :: HasTreeError err
...
@@ -38,7 +38,10 @@ findNodes' :: HasTreeError err
=>
RootId
=>
RootId
->
NodeMode
->
NodeMode
->
Cmd
err
[
DbTreeNode
]
->
Cmd
err
[
DbTreeNode
]
findNodes'
r
Private
=
findNodes
r
Private
$
[
NodeFolderPrivate
]
<>
commonNodes
findNodes'
r
Private
=
do
pv
<-
(
findNodes
r
Private
$
[
NodeFolderPrivate
]
<>
commonNodes
)
sh
<-
(
findNodes'
r
Shared
)
pure
$
pv
<>
sh
findNodes'
r
Shared
=
findNodes
r
Shared
$
[
NodeFolderShared
,
NodeTeam
]
<>
commonNodes
findNodes'
r
Shared
=
findNodes
r
Shared
$
[
NodeFolderShared
,
NodeTeam
]
<>
commonNodes
findNodes'
r
Public
=
findNodes
r
Public
$
[
NodeFolderPublic
]
<>
commonNodes
findNodes'
r
Public
=
findNodes
r
Public
$
[
NodeFolderPublic
]
<>
commonNodes
...
...
src/Gargantext/Core/Text/List/Social/Prelude.hs
View file @
25e6254d
...
@@ -36,6 +36,7 @@ data FlowCont a b =
...
@@ -36,6 +36,7 @@ data FlowCont a b =
FlowCont
{
_flc_scores
::
Map
a
b
FlowCont
{
_flc_scores
::
Map
a
b
,
_flc_cont
::
Map
a
b
,
_flc_cont
::
Map
a
b
}
}
deriving
(
Show
)
instance
(
Ord
a
,
Eq
b
)
=>
Monoid
(
FlowCont
a
b
)
where
instance
(
Ord
a
,
Eq
b
)
=>
Monoid
(
FlowCont
a
b
)
where
mempty
=
FlowCont
mempty
mempty
mempty
=
FlowCont
mempty
mempty
...
...
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