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