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)
  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 qualified Data.Set as Set
  34 import qualified Data.Map as Map
  35 import qualified Data.List as List
  36
  37 type Children = Text
  38 type Root = Text
  39
  40 data MyTree = MyTree { mt_label :: Text
  41                      , mt_value :: Double
  42                      , mt_children :: [MyTree]
  43                   } deriving (Generic, Show)
  44
  45 toMyTree :: Tree (Text,Double) -> MyTree
  46 toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs)
  47
  48 deriveJSON (unPrefix "mt_") ''MyTree
  49
  50
  51 toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
  52 toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
  53   where
  54     buildNode r = maybe ((r, value r),[]) (\x -> ((r, value r), mSetToList $ _nre_children x)) (Map.lookup r m)
  55
  56     value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs
  57
  58     rootsCandidates = catMaybes
  59                     $ List.nub
  60                     $ map (\(c,c') -> case _nre_root c' of
  61                                        Nothing -> Just c
  62                                        _ -> _nre_root c' ) (Map.toList m)
  63
  64     roots = map fst
  65           $ filter (\(_,l) -> l == lt)
  66           $ catMaybes
  67           $ map (\c -> (,) <$> Just c <*> (_nre_list <$> Map.lookup c m)) rootsCandidates
  68
  69