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