]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Facet.hs
fix the weightedlogjaccard
[gargantext.git] / src / Gargantext / Database / Facet.hs
1 {-|
2 Module : Gargantext.Database.Facet
3 Description : Main requests of Node to the database
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 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
13
14 {-# LANGUAGE Arrows #-}
15 {-# LANGUAGE DeriveGeneric #-}
16 {-# LANGUAGE FlexibleContexts #-}
17 {-# LANGUAGE FlexibleInstances #-}
18 {-# LANGUAGE FunctionalDependencies #-}
19 {-# LANGUAGE MultiParamTypeClasses #-}
20 {-# LANGUAGE QuasiQuotes #-}
21 {-# LANGUAGE NoImplicitPrelude #-}
22 {-# LANGUAGE NoMonomorphismRestriction #-}
23 {-# LANGUAGE OverloadedStrings #-}
24 {-# LANGUAGE RankNTypes #-}
25 {-# LANGUAGE TemplateHaskell #-}
26 {-# LANGUAGE TypeFamilies #-}
27 ------------------------------------------------------------------------
28 module Gargantext.Database.Facet
29 where
30 ------------------------------------------------------------------------
31 import Control.Arrow (returnA)
32 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
33 import Data.Aeson (FromJSON, ToJSON)
34 import Data.Aeson.TH (deriveJSON)
35 import Data.Either(Either(Left))
36 import Data.Maybe (Maybe)
37 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
38 import Data.Swagger
39 import Data.Text (Text)
40 import Data.Time (UTCTime)
41 import Data.Time.Segment (jour)
42 import GHC.Generics (Generic)
43 import Gargantext.Core.Types
44 import Gargantext.Core.Utils.Prefix (unPrefix)
45 import Gargantext.Database.Config (nodeTypeId)
46 import Gargantext.Database.Schema.Ngrams
47 import Gargantext.Database.Schema.Node
48 import Gargantext.Database.Schema.NodeNgram
49 import Gargantext.Database.Schema.NodeNode
50 import Gargantext.Database.Utils
51 import Gargantext.Database.Queries.Join
52 import Gargantext.Database.Queries.Filter
53 import Opaleye
54 import Prelude hiding (null, id, map, sum, not, read)
55 import Servant.API
56 import Test.QuickCheck (elements)
57 import Test.QuickCheck.Arbitrary
58 import qualified Opaleye.Internal.Unpackspec()
59
60 ------------------------------------------------------------------------
61 -- | DocFacet
62
63 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
64 -- deriving (Show, Generic)
65 --instance FromJSON Facet
66 --instance ToJSON Facet
67
68 type Favorite = Int
69 type Title = Text
70
71 -- TODO remove Title
72 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Favorite) (Maybe Double)
73 type FacetSources = FacetDoc
74 type FacetAuthors = FacetDoc
75 type FacetTerms = FacetDoc
76
77
78 data Facet id created title hyperdata favorite ngramCount =
79 FacetDoc { facetDoc_id :: id
80 , facetDoc_created :: created
81 , facetDoc_title :: title
82 , facetDoc_hyperdata :: hyperdata
83 , facetDoc_favorite :: favorite
84 , facetDoc_ngramCount :: ngramCount
85 } deriving (Show, Generic)
86 {- | TODO after demo
87 data Facet id date hyperdata score =
88 FacetDoc { facetDoc_id :: id
89 , facetDoc_date :: date
90 , facetDoc_hyperdata :: hyperdata
91 , facetDoc_score :: score
92 } deriving (Show, Generic)
93 -}
94
95 data Pair i l = Pair {_p_id :: i
96 ,_p_label :: l
97 } deriving (Show, Generic)
98 $(deriveJSON (unPrefix "_p_") ''Pair)
99 $(makeAdaptorAndInstance "pPair" ''Pair)
100
101 instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
102 declareNamedSchema =
103 genericDeclareNamedSchema
104 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
105 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
106 arbitrary = Pair <$> arbitrary <*> arbitrary
107
108 data FacetPaired id date hyperdata score pairs =
109 FacetPaired {_fp_id :: id
110 ,_fp_date :: date
111 ,_fp_hyperdata :: hyperdata
112 ,_fp_score :: score
113 ,_fp_pairs :: pairs
114 } deriving (Show, Generic)
115 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
116 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
117
118 instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
119 declareNamedSchema =
120 genericDeclareNamedSchema
121 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
122
123 instance ( Arbitrary id
124 , Arbitrary date
125 , Arbitrary hyperdata
126 , Arbitrary score
127 , Arbitrary pairs
128 ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
129 arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
130
131 --{-
132 type FacetPairedRead = FacetPaired (Column PGInt4 )
133 (Column PGTimestamptz)
134 (Column PGJsonb )
135 (Column PGInt4 )
136 (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
137 --}
138
139
140
141 -- | JSON instance
142 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
143
144 -- | Documentation instance
145 instance ToSchema FacetDoc
146
147 -- | Mock and Quickcheck instances
148 instance Arbitrary FacetDoc where
149 arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount)
150 | id' <- [1..10]
151 , year <- [1990..2000]
152 , t <- ["title", "another title"]
153 , hp <- arbitraryHyperdataDocuments
154 , cat <- [0..2]
155 , ngramCount <- [3..100]
156 ]
157
158 -- Facets / Views for the Front End
159 -- | Database instances
160 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
161 $(makeLensesWith abbreviatedFields ''Facet)
162
163 type FacetDocRead = Facet (Column PGInt4 )
164 (Column PGTimestamptz)
165 (Column PGText )
166 (Column PGJsonb )
167 (Column (Nullable PGInt4)) -- Category
168 (Column (Nullable PGFloat8)) -- Score
169
170 -----------------------------------------------------------------------
171 -----------------------------------------------------------------------
172 data OrderBy = DateAsc | DateDesc
173 | TitleAsc | TitleDesc
174 | ScoreDesc | ScoreAsc
175 | SourceAsc | SourceDesc
176 deriving (Generic, Enum, Bounded, Read, Show)
177
178 instance FromHttpApiData OrderBy
179 where
180 parseUrlPiece "DateAsc" = pure DateAsc
181 parseUrlPiece "DateDesc" = pure DateDesc
182 parseUrlPiece "TitleAsc" = pure TitleAsc
183 parseUrlPiece "TitleDesc" = pure TitleDesc
184 parseUrlPiece "ScoreAsc" = pure ScoreAsc
185 parseUrlPiece "ScoreDesc" = pure ScoreDesc
186 parseUrlPiece "SourceAsc" = pure SourceAsc
187 parseUrlPiece "SourceDesc" = pure SourceDesc
188 parseUrlPiece _ = Left "Unexpected value of OrderBy"
189
190 instance ToParamSchema OrderBy
191 instance FromJSON OrderBy
192 instance ToJSON OrderBy
193 instance ToSchema OrderBy
194 instance Arbitrary OrderBy
195 where
196 arbitrary = elements [minBound..maxBound]
197
198
199 runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
200 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
201 where
202 ntId = NodeDocument
203
204 -- TODO add delete ?
205 viewAuthorsDoc :: ContactId -> IsTrash -> NodeType -> Query FacetDocRead
206 viewAuthorsDoc cId _ nt = proc () -> do
207 (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc -< ()
208
209 {-nn <- queryNodeNodeTable -< ()
210 restrict -< nn_node1_id nn .== _node_id doc
211 -- restrict -< nn_delete nn .== (pgBool t)
212 -}
213
214 restrict -< _node_id contact .== (toNullable $ pgNodeId cId)
215 restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
216
217 returnA -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (toNullable $ pgInt4 1) (toNullable $ pgDouble 1)
218
219 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
220 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
221 where
222 cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
223 cond12 (nodeNgram, doc) = _node_id doc
224 .== nng_node_id nodeNgram
225
226 cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
227 cond23 (ngrams, (nodeNgram, _)) = ngrams_id ngrams
228 .== nng_ngrams_id nodeNgram
229
230 cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
231 cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== nng_ngrams_id nodeNgram2
232
233 cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
234 cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nng_node_id nodeNgram2
235
236
237 ------------------------------------------------------------------------
238
239 runViewDocuments :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
240 runViewDocuments cId t o l order =
241 runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
242 where
243 ntId = nodeTypeId NodeDocument
244
245 viewDocuments :: CorpusId -> IsTrash -> NodeTypeId -> Query FacetDocRead
246 viewDocuments cId t ntId = proc () -> do
247 n <- queryNodeTable -< ()
248 nn <- queryNodeNodeTable -< ()
249 restrict -< _node_id n .== nn_node2_id nn
250 restrict -< nn_node1_id nn .== (pgNodeId cId)
251 restrict -< _node_typename n .== (pgInt4 ntId)
252 restrict -< if t then nn_category nn .== (pgInt4 0)
253 else nn_category nn .>= (pgInt4 1)
254 returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (toNullable $ nn_category nn) (toNullable $ nn_score nn)
255
256
257 ------------------------------------------------------------------------
258 filterWith :: (PGOrd date, PGOrd title, PGOrd score, hyperdata ~ Column SqlJsonb) =>
259 Maybe Gargantext.Core.Types.Offset
260 -> Maybe Gargantext.Core.Types.Limit
261 -> Maybe OrderBy
262 -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
263 -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
264 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
265
266
267 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3)
268 => Maybe OrderBy
269 -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) score)
270 orderWith (Just DateAsc) = asc facetDoc_created
271 orderWith (Just DateDesc) = desc facetDoc_created
272
273 orderWith (Just TitleAsc) = asc facetDoc_title
274 orderWith (Just TitleDesc) = desc facetDoc_title
275
276 orderWith (Just ScoreAsc) = asc facetDoc_favorite
277 orderWith (Just ScoreDesc) = desc facetDoc_favorite
278
279 orderWith (Just SourceAsc) = asc facetDoc_source
280 orderWith (Just SourceDesc) = desc facetDoc_source
281
282 orderWith _ = asc facetDoc_created
283
284 facetDoc_source :: PGIsJson a
285 => Facet id created title (Column a) favorite ngramCount
286 -> Column (Nullable PGText)
287 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"