]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Core/Text/List/Social.hs
Merge branch 'dev-social-list' into dev
[gargantext.git] / src / Gargantext / Core / Text / List / Social.hs
1 {-|
2 Module : Gargantext.Core.Text.List.Social
3 Description :
4 Copyright : (c) CNRS, 2018-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9 -}
10
11 module Gargantext.Core.Text.List.Social
12 where
13
14 import Data.Map (Map)
15 import Data.Maybe (fromMaybe)
16 import Data.Semigroup (Semigroup(..))
17 import Data.Set (Set)
18 import Data.Text (Text)
19 import Gargantext.API.Ngrams.Tools -- (getListNgrams)
20 import Gargantext.API.Ngrams.Types
21 import Gargantext.Core.Text.List.Social.Find
22 import Gargantext.Core.Text.List.Social.ListType
23 import Gargantext.Core.Text.List.Social.Scores
24 import Gargantext.Core.Types.Individu
25 import Gargantext.Core.Types.Main
26 import Gargantext.Database.Admin.Types.Node
27 import Gargantext.Database.Prelude
28 import Gargantext.Database.Query.Table.Node.Error
29 import Gargantext.Database.Query.Tree
30 import Gargantext.Database.Schema.Ngrams
31 import Gargantext.Prelude
32 import qualified Data.Map as Map
33 import qualified Data.Set as Set
34
35 ------------------------------------------------------------------------
36 flowSocialList :: ( RepoCmdM env err m
37 , CmdM env err m
38 , HasNodeError err
39 , HasTreeError err
40 )
41 => User -> NgramsType -> Set Text
42 -> m (Map ListType (Set Text))
43 flowSocialList user nt ngrams' = do
44 -- Here preference to privateLists (discutable: let user choice)
45 privateListIds <- findListsId user Private
46 privateLists <- flowSocialListByMode privateListIds nt ngrams'
47 -- printDebug "* privateLists *: \n" privateLists
48
49 sharedListIds <- findListsId user Shared
50 sharedLists <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
51 -- printDebug "* sharedLists *: \n" sharedLists
52
53 -- TODO publicMapList:
54 -- Note: if both produce 3 identic repetition => refactor mode
55 -- publicListIds <- findListsId Public user
56 -- publicLists <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
57
58 let result = parentUnionsExcl
59 [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
60 , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
61 -- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
62 ]
63 -- printDebug "* socialLists *: results \n" result
64 pure result
65
66 ------------------------------------------------------------------------
67 ------------------------------------------------------------------------
68 -- | FlowSocialListPriority
69 -- Sociological assumption: either private or others (public) first
70 -- This parameter depends on the user choice
71 data FlowSocialListPriority = MySelfFirst | OthersFirst
72
73 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
74 flowSocialListPriority MySelfFirst = [Private, Shared{-, Public -}]
75 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
76
77 ------------------------------------------------------------------------
78 flowSocialList' :: ( RepoCmdM env err m
79 , CmdM env err m
80 , HasNodeError err
81 , HasTreeError err
82 )
83 => FlowSocialListPriority
84 -> User -> NgramsType -> Set Text
85 -> m (Map Text FlowListScores)
86 flowSocialList' flowPriority user nt ngrams' =
87 parentUnionsExcl <$> mapM (flowSocialListByMode' user nt ngrams')
88 (flowSocialListPriority flowPriority)
89
90 ------------------------------------------------------------------------
91 flowSocialListByMode :: ( RepoCmdM env err m
92 , CmdM env err m
93 , HasNodeError err
94 , HasTreeError err
95 )
96 => [NodeId]-> NgramsType -> Set Text
97 -> m (Map (Maybe ListType) (Set Text))
98 flowSocialListByMode [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
99 flowSocialListByMode listIds nt ngrams' = do
100 counts <- countFilterList ngrams' nt listIds Map.empty
101 let r = toSocialList counts ngrams'
102 pure r
103
104
105 flowSocialListByMode' :: ( RepoCmdM env err m
106 , CmdM env err m
107 , HasNodeError err
108 , HasTreeError err
109 )
110 => User -> NgramsType -> Set Text -> NodeMode
111 -> m (Map Text FlowListScores)
112 flowSocialListByMode' user nt st mode =
113 findListsId user mode
114 >>= flowSocialListByModeWith nt st
115
116
117 flowSocialListByModeWith :: ( RepoCmdM env err m
118 , CmdM env err m
119 , HasNodeError err
120 , HasTreeError err
121 )
122 => NgramsType -> Set Text -> [NodeId]
123 -> m (Map Text FlowListScores)
124 flowSocialListByModeWith nt st ns =
125 mapM (\l -> getListNgrams [l] nt) ns
126 >>= pure
127 . toFlowListScores (keepAllParents nt) st Map.empty
128
129
130 -- | We keep the parents for all ngrams but terms
131 keepAllParents :: NgramsType -> KeepAllParents
132 keepAllParents NgramsTerms = KeepAllParents False
133 keepAllParents _ = KeepAllParents True
134
135 ------------------------------------------------------------------------
136 -- TODO: maybe use social groups too
137 -- | TODO what if equality ?
138 -- choice depends on Ord instance of ListType
139 -- for now : data ListType = StopTerm | CandidateTerm | MapTerm
140 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
141 -- (we minimize errors on MapTerms if doubt)
142 toSocialList :: Map Text (Map ListType Int)
143 -> Set Text
144 -> Map (Maybe ListType) (Set Text)
145 toSocialList m = Map.fromListWith (<>)
146 . Set.toList
147 . Set.map (toSocialList1 m)
148
149 toSocialList1 :: Map Text (Map ListType Int)
150 -> Text
151 -> (Maybe ListType, Set Text)
152 toSocialList1 m t = case Map.lookup t m of
153 Nothing -> (Nothing, Set.singleton t)
154 Just m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
155 , Set.singleton t
156 )
157
158 toSocialList1_testIsTrue :: Bool
159 toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
160 where
161 result = toSocialList1 (Map.fromList [(token, m)]) token
162 token = "token"
163 m = Map.fromList [ (CandidateTerm, 1)
164 , (MapTerm , 2)
165 , (StopTerm , 3)
166 ]
167
168 ------------------------------------------------------------------------
169 -- | Tools
170 ------------------------------------------------------------------------
171 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
172 termsByList CandidateTerm m = Set.unions
173 $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
174 [ Nothing, Just CandidateTerm ]
175 termsByList l m =
176 fromMaybe Set.empty $ Map.lookup (Just l) m
177
178 ------------------------------------------------------------------------
179 unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
180 => [Map a (Set b)] -> Map a (Set b)
181 unions = invertBack . Map.unionsWith (<>) . map invertForw
182
183 invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
184 invertForw = Map.unionsWith (<>)
185 . (map (\(k,sets) -> Map.fromSet (\_ -> k) sets))
186 . Map.toList
187
188 invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
189 invertBack = Map.fromListWith (<>)
190 . (map (\(b,a) -> (a, Set.singleton b)))
191 . Map.toList
192
193 unions_test :: Map ListType (Set Text)
194 unions_test = unions [m1, m2]
195 where
196 m1 = Map.fromList [ (StopTerm , Set.singleton "Candidate")]
197 m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
198 , (MapTerm , Set.singleton "Candidate")
199 ]