src/Gargantext/API/Ngrams/NgramsTree.hs

   1 {-|
   2 Module      : Gargantext.API.Ngrams.NgramsTree
   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.NgramsTree
  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.Types
  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 NgramsTree = NgramsTree { mt_label :: Text
  40                              , mt_value :: Double
  41                              , mt_children :: [NgramsTree]
  42                              }
  43     deriving (Generic, Show)
  44
  45 toNgramsTree :: Tree (Text,Double) -> NgramsTree
  46 toNgramsTree (Node (l,v) xs) = NgramsTree l v (map toNgramsTree xs)
  47
  48 deriveJSON (unPrefix "mt_") ''NgramsTree
  49
  50 instance ToSchema NgramsTree where
  51   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
  52 instance Arbitrary NgramsTree
  53   where
  54     arbitrary = NgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
  55
  56 toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [NgramsTree]
  57 toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots
  58   where
  59     buildNode r = maybe ((r, value r),[])
  60                         (\x -> ((r, value r), unNgramsTerm <$> (mSetToList $ _nre_children x)))
  61                         (Map.lookup r m)
  62
  63     value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs
  64
  65     rootsCandidates :: [NgramsTerm]
  66     rootsCandidates = catMaybes
  67                     $ List.nub
  68                     $ map (\(c, c') -> case _nre_root c' of
  69                                        Nothing -> Just $ NgramsTerm c
  70                                        _ -> _nre_root c') (Map.toList m)
  71
  72     roots = map fst
  73           $ filter (\(_,l) -> l == lt)
  74           $ catMaybes
  75           $ map (\c -> (,) <$> Just c <*> (_nre_list <$> Map.lookup c m))
  76           $ (unNgramsTerm <$> rootsCandidates)