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