]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Learn.hs
Merge branch 'dev-phylo' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantex...
[gargantext.git] / src / Gargantext / Database / Learn.hs
1 {-|
2 Module : Gargantext.Database.Learn
3 Description : Learn Small Data Analytics with big data connection (DB)
4 opyright : (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 NoImplicitPrelude #-}
13 {-# LANGUAGE QuasiQuotes #-}
14 {-# LANGUAGE RankNTypes #-}
15 {-# LANGUAGE OverloadedStrings #-}
16 {-# LANGUAGE FlexibleContexts #-}
17 {-# LANGUAGE MonoLocalBinds #-}
18
19 module Gargantext.Database.Learn where
20
21 import Data.Text (Text)
22 import Data.Tuple (snd)
23 import Data.Maybe
24 import Gargantext.Database.Facet
25 import Gargantext.Database.Types.Node
26 import Gargantext.Prelude
27 import Gargantext.Text.Learn
28 import qualified Data.List as List
29 import qualified Data.Text as Text
30 --import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
31 import Gargantext.Database.Utils (Cmd)
32 import Gargantext.Core.Types (Offset, Limit)
33
34 data FavOrTrash = IsFav | IsTrash
35 deriving (Eq)
36
37
38 moreLike :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
39 -> FavOrTrash -> Cmd err [FacetDoc]
40 moreLike cId o l order ft = do
41 priors <- getPriors ft cId
42 moreLikeWith cId o l order ft priors
43
44 ---------------------------------------------------------------------------
45 getPriors :: FavOrTrash -> CorpusId -> Cmd err (Events Bool)
46 getPriors ft cId = do
47
48 docs_fav <- filter (\(FacetDoc _ _ _ _ f _) -> f == Just 2)
49 <$> runViewDocuments cId False Nothing Nothing Nothing
50
51 docs_trash <- List.take (List.length docs_fav)
52 <$> runViewDocuments cId True Nothing Nothing Nothing
53
54
55 let priors = priorEventsWith text (fav2bool ft) ( List.zip (repeat False) docs_fav
56 <> List.zip (repeat True ) docs_trash
57 )
58 pure priors
59
60
61 moreLikeWith :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
62 -> FavOrTrash -> Events Bool -> Cmd err [FacetDoc]
63 moreLikeWith cId o l order ft priors = do
64
65 docs_test <- filter (\(FacetDoc _ _ _ _ f _) -> f == Just 1)
66 <$> runViewDocuments cId False o Nothing order
67
68 let results = map fst
69 $ filter ((==) (Just $ not $ fav2bool ft) . snd)
70 $ map (\f -> (f, detectDefaultWithPriors text priors f)) docs_test
71
72 pure $ List.take (maybe 10 identity l) results
73
74 ---------------------------------------------------------------------------
75 fav2bool :: FavOrTrash -> Bool
76 fav2bool ft = if (==) ft IsFav then True else False
77
78
79 text :: FacetDoc -> Text
80 text (FacetDoc _ _ _ h _ _) = title <> "" <> Text.take 100 abstr
81 where
82 title = maybe "" identity (_hyperdataDocument_title h)
83 abstr = maybe "" identity (_hyperdataDocument_abstract h)
84
85 ---------------------------------------------------------------------------
86
87 {-
88 apply :: (FlowCmdM env e m) => FavOrTrash -> CorpusId -> [NodeId] -> m [Int]
89 apply favTrash cId ns = case favTrash of
90 IsFav -> nodeNodesCategory $ map (\n -> (cId, n, 2)) ns
91 IsTrash -> nodeNodesCategory $ map (\n -> (cId, n, 0)) ns
92
93 moreLikeAndApply :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m [Int]
94 moreLikeAndApply ft cId = do
95 priors <- getPriors ft cId
96 moreLikeWithAndApply priors ft cId
97
98 moreLikeWithAndApply :: FlowCmdM DevEnv GargError m => Events Bool -> FavOrTrash -> CorpusId -> m [Int]
99 moreLikeWithAndApply priors ft cId = do
100 ids <- map facetDoc_id <$> moreLikeWith cId ft priors
101 apply ft cId ids
102 -}