]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Ngrams/NTree.hs
max cliques with apax to 2
[gargantext.git] / src / Gargantext / API / Ngrams / NTree.hs
1 {-|
2 Module : Gargantext.API.Ngrams.NTree
3 Description : Tree of Ngrams
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 NoImplicitPrelude #-}
13 {-# LANGUAGE OverloadedStrings #-}
14 {-# LANGUAGE RankNTypes #-}
15 {-# LANGUAGE DeriveGeneric #-}
16 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
17 {-# LANGUAGE TemplateHaskell #-}
18
19 module Gargantext.API.Ngrams.NTree
20 where
21
22 import Data.Text (Text)
23 import Gargantext.Prelude
24 import GHC.Generics (Generic)
25 import Data.Aeson.TH (deriveJSON)
26 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
27 import Gargantext.Core.Types (ListType(..), NodeId)
28 import Gargantext.API.Ngrams
29 import Data.Tree
30 import Data.Maybe (catMaybes)
31 import Data.Map (Map)
32 import Data.Set (Set)
33 import Data.Swagger
34 import qualified Data.Set as Set
35 import qualified Data.Map as Map
36 import qualified Data.List as List
37 import Test.QuickCheck
38
39 type Children = Text
40 type Root = Text
41
42 data MyTree = MyTree { mt_label :: Text
43 , mt_value :: Double
44 , mt_children :: [MyTree]
45 } deriving (Generic, Show)
46
47 toMyTree :: Tree (Text,Double) -> MyTree
48 toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs)
49
50 deriveJSON (unPrefix "mt_") ''MyTree
51
52 instance ToSchema MyTree where
53 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
54 instance Arbitrary MyTree
55 where
56 arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
57
58 toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
59 toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
60 where
61 buildNode r = maybe ((r, value r),[]) (\x -> ((r, value r), mSetToList $ _nre_children x)) (Map.lookup r m)
62
63 value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs
64
65 rootsCandidates = catMaybes
66 $ List.nub
67 $ map (\(c,c') -> case _nre_root c' of
68 Nothing -> Just c
69 _ -> _nre_root c' ) (Map.toList m)
70
71 roots = map fst
72 $ filter (\(_,l) -> l == lt)
73 $ catMaybes
74 $ map (\c -> (,) <$> Just c <*> (_nre_list <$> Map.lookup c m)) rootsCandidates
75
76