]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Text/List.hs
[GRAPH] adding type Ordering to sortTficf and others
[gargantext.git] / src / Gargantext / Text / List.hs
1 {-|
2 Module : Gargantext.Text.Ngrams.Lists
3 Description : Tools to build lists
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 -}
11
12 {-# LANGUAGE FlexibleContexts #-}
13 {-# LANGUAGE NoImplicitPrelude #-}
14 {-# LANGUAGE OverloadedStrings #-}
15 {-# LANGUAGE RankNTypes #-}
16
17 module Gargantext.Text.List
18 where
19
20 -- import Data.Either (partitionEithers, Either(..))
21 import Data.Map (Map)
22 import Data.Set (Set)
23 import Data.Text (Text)
24 import Gargantext.API.Ngrams (NgramsElement, mkNgramsElement, RootParent(..), mSetFromList)
25 -- import Gargantext.API.Ngrams.Tools (getCoocByNgrams', Diagonal(..))
26 import Gargantext.Core (Lang(..))
27 import Gargantext.Core.Types (ListType(..), MasterCorpusId, UserCorpusId, Ordering(..))
28 import Gargantext.Database.Action.Metrics.NgramsByNode (getTficf, sortTficf, ngramsGroup, getNodesByNgramsUser, groupNodesByNgramsWith)
29 import Gargantext.Database.Admin.Utils (Cmd)
30 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
31 import Gargantext.Prelude
32 import Gargantext.Text.List.Learn (Model(..))
33 -- import Gargantext.Text.Metrics (takeScored)
34 import qualified Data.Char as Char
35 import qualified Data.List as List
36 import qualified Data.Map as Map
37 import qualified Data.Set as Set
38 import qualified Data.Text as Text
39
40
41 data NgramsListBuilder = BuilderStepO { stemSize :: Int
42 , stemX :: Int
43 , stopSize :: Int
44 }
45 | BuilderStep1 { withModel :: Model }
46 | BuilderStepN { withModel :: Model }
47 | Tficf { nlb_lang :: Lang
48 , nlb_group1 :: Int
49 , nlb_group2 :: Int
50 , nlb_stopSize :: StopSize
51 , nlb_userCorpusId :: UserCorpusId
52 , nlb_masterCorpusId :: MasterCorpusId
53 }
54
55
56 data StopSize = StopSize {unStopSize :: Int}
57
58 -- | TODO improve grouping functions of Authors, Sources, Institutes..
59 buildNgramsLists :: Lang
60 -> Int
61 -> Int
62 -> StopSize
63 -> UserCorpusId
64 -> MasterCorpusId
65 -> Cmd err (Map NgramsType [NgramsElement])
66 buildNgramsLists l n m s uCid mCid = do
67 ngTerms <- buildNgramsTermsList l n m s uCid mCid
68 othersTerms <- mapM (buildNgramsOthersList uCid identity) [Authors, Sources, Institutes]
69 pure $ Map.unions $ othersTerms <> [ngTerms]
70
71
72 buildNgramsOthersList :: UserCorpusId
73 -> (Text -> Text)
74 -> NgramsType
75 -> Cmd err (Map NgramsType [NgramsElement])
76 buildNgramsOthersList uCid groupIt nt = do
77 ngs <- groupNodesByNgramsWith groupIt <$> getNodesByNgramsUser uCid nt
78
79 let
80 listSize = 9
81 all' = List.reverse $ List.sortOn (Set.size . snd . snd) $ Map.toList ngs
82
83 graphTerms = List.take listSize all'
84 candiTerms = List.drop listSize all'
85
86 pure $ Map.unionsWith (<>) [ toElements GraphTerm graphTerms
87 , toElements CandidateTerm candiTerms
88 ]
89 where
90 toElements nType x =
91 Map.fromList [(nt, [ mkNgramsElement t nType Nothing (mSetFromList [])
92 | (t,_ns) <- x
93 ]
94 )]
95
96 {-
97 buildNgramsTermsList' :: UserCorpusId
98 -> (Text -> Text)
99 -> ((Text, (Set Text, Set NodeId)) -> Bool)
100 -> Int
101 -> Int
102 -> Cmd err (Map NgramsType [NgramsElement])
103
104 buildNgramsTermsList' uCid groupIt stop gls is = do
105 ngs <- groupNodesByNgramsWith groupIt <$> getNodesByNgramsUser uCid NgramsTerms
106
107 let
108 (stops, candidates) = partitionEithers
109 $ map (\t -> if stop t then Left t else Right t)
110 $ Map.toList
111 $ Map.filter ((\s' -> Set.size s' > 1) . snd) ngs
112
113 (maps, candidates') = takeScored gls is
114 $ getCoocByNgrams' snd (Diagonal True)
115 $ Map.fromList candidates
116
117
118 toList' t = (fst t, (fromIntegral $ Set.size $ snd $ snd t, fst $ snd t))
119
120 (s,c,m) = (stops
121 , List.filter (\(k,_) -> List.elem k candidates') candidates
122 , List.filter (\(k,_) -> List.elem k maps) candidates
123 )
124
125 let ngs' = List.concat
126 $ map toNgramsElement
127 $ map (\t -> (StopTerm , toList' t)) s
128 <> map (\t -> (CandidateTerm, toList' t)) c
129 <> map (\t -> (GraphTerm , toList' t)) m
130
131 pure $ Map.fromList [(NgramsTerms, ngs')]
132 -}
133
134 buildNgramsTermsList :: Lang
135 -> Int
136 -> Int
137 -> StopSize
138 -> UserCorpusId
139 -> MasterCorpusId
140 -> Cmd err (Map NgramsType [NgramsElement])
141 buildNgramsTermsList l n m s uCid mCid = do
142 candidates <- sortTficf Up <$> getTficf uCid mCid NgramsTerms (ngramsGroup l n m)
143
144 let
145 candidatesSize = 400
146
147 {-
148 a = 50
149 b = 50
150 -}
151 candidatesHead = List.take candidatesSize candidates
152 candidatesTail = List.drop candidatesSize candidates
153
154 termList =
155 -- (toTermList a b ((isStopTerm s) . fst) candidatesHead)
156 (map (toList ((isStopTerm s) .fst) GraphTerm) candidatesHead)
157 <> (map (toList ((isStopTerm s) .fst) CandidateTerm) candidatesTail)
158
159 ngs = List.concat $ map toNgramsElement termList
160
161 pure $ Map.fromList [(NgramsTerms, ngs)]
162
163
164 toTermList :: Int
165 -> Int
166 -> (a -> Bool)
167 -> [a]
168 -> [(ListType, a)]
169 toTermList _ _ _ [] = []
170 toTermList a b stop ns = -- trace ("computing toTermList") $
171 map (toList stop CandidateTerm) xs
172 <> map (toList stop GraphTerm) ys
173 <> toTermList a b stop zs
174 where
175 xs = take a ns
176 xz = drop a ns
177
178 ys = take b xz
179 zs = drop b xz
180
181
182 toNgramsElement :: (ListType, (Text, (Double, Set Text))) -> [NgramsElement]
183 toNgramsElement (listType, (_stem, (_score, setNgrams))) =
184 case Set.toList setNgrams of
185 [] -> []
186 (parent:children) -> [parentElem] <> childrenElems
187 where
188 parentElem = mkNgramsElement parent
189 listType
190 Nothing
191 (mSetFromList children)
192 childrenElems = map (\t -> mkNgramsElement t listType
193 (Just $ RootParent parent parent)
194 (mSetFromList [])
195 ) children
196
197
198 toList :: (b -> Bool) -> ListType -> b -> (ListType, b)
199 toList stop l n = case stop n of
200 True -> (StopTerm, n)
201 False -> (l, n)
202
203
204
205 isStopTerm :: StopSize -> Text -> Bool
206 isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
207 where
208 isStopChar c = not (c `elem` ("- /()%" :: [Char]) || Char.isAlpha c)