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