[FEAT] toTermList function

src/Gargantext/API/Ngrams/List.hs

@@ -17,29 +17,27 @@ module Gargantext.API.Ngrams.List
 
 import Control.Lens hiding (elements)
 import Data.Aeson
-import Data.Map (Map, toList, fromList)
+import Data.Map (toList, fromList)
 import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
 import Data.Text (Text, concat, pack)
 import GHC.Generics (Generic)
-import Network.HTTP.Media ((//), (/:))
-import Servant
-import Servant.Job.Async
-import Servant.Job.Utils (jsonOptions)
-import Web.FormUrlEncoded (FromForm)
-
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Ngrams (getNgramsTableMap, setListNgrams)
-import Gargantext.API.Ngrams.Types (NgramsTableMap, RepoCmdM, Versioned(..))
+import Gargantext.API.Ngrams.Types (RepoCmdM, Versioned(..), NgramsList)
 import Gargantext.API.Node.Corpus.New.File (FileType(..))
 import Gargantext.API.Prelude (GargServer)
 import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes)
+import Gargantext.Database.Schema.Ngrams (ngramsTypes)
 import Gargantext.Prelude
-
+import Network.HTTP.Media ((//), (/:))
+import Servant
+import Servant.Job.Async
+import Servant.Job.Utils (jsonOptions)
+import Web.FormUrlEncoded (FromForm)
 ------------------------------------------------------------------------
-type NgramsList = (Map NgramsType (Versioned NgramsTableMap))
+
 ------------------------------------------------------------------------
 type API =  Get '[JSON, HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
        -- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool

src/Gargantext/API/Ngrams/NgramsTree.hs

@@ -68,7 +68,8 @@ toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots
                     $ List.nub
                     $ map (\(c, c') -> case _nre_root c' of
                                        Nothing -> Just c
-                                       _ -> _nre_root c') (HashMap.toList m)
+                                       _ -> _nre_root c'
+                          ) (HashMap.toList m)
 
     roots = map fst
           $ filter (\(_,l) -> l == lt)

src/Gargantext/API/Ngrams/Prelude.hs

+{-|
+Module      : Gargantext.API.Ngrams.Prelude
+Description : Tools to manage Ngrams Elements (from the API)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE TypeFamilies #-}
+
+module Gargantext.API.Ngrams.Prelude
+  where
+
+import Data.Maybe (catMaybes)
+import Control.Lens (view)
+import Data.Hashable (Hashable)
+import Data.Validity
+import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Types (ListType)
+import Gargantext.Database.Schema.Ngrams (NgramsType)
+import Gargantext.Prelude
+import Gargantext.Core.Text.List.Social.Prelude
+import Gargantext.Core.Text.Context (TermList)
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Map.Strict as Map
+import qualified Data.List as List
+import qualified Data.Text as Text
+
+------------------------------------------------------------------------
+-- | Tools
+-- Usage example: toTermList MapTerm NgramsTerms ngramsList
+toTermList :: ListType -> NgramsType -> NgramsList -> Maybe TermList
+toTermList lt nt nl = toTermList' lt <$> Map.lookup nt nl
+  where
+    toTermList' :: ListType -> Versioned NgramsTableMap -> TermList
+    toTermList' lt' = (toTermList'' lt') . Map.toList . view v_data
+
+    toTermList'' :: ListType -> [(NgramsTerm, NgramsRepoElement)] -> TermList
+    toTermList'' lt'' ns = Map.toList
+                       $ Map.mapKeys toTerm
+                       $ Map.fromListWith (<>) (roots' <> children')
+      where
+        toTerm = Text.splitOn " " . unNgramsTerm
+
+        (roots, children) = List.partition (\(_t, nre) -> view nre_root nre == Nothing)
+                          $ List.filter (\(_t,nre) -> view nre_list nre == lt'') ns
+
+        roots'    = catMaybes
+                   $ map (\(t,nre) -> (,) <$> Just t
+                                           <*> Just (map toTerm $ unMSet 
+                                                                $ view nre_children nre
+                                                    )
+                         ) roots
+
+        children' = catMaybes
+                  $ map (\(t,nre) -> (,) <$> view nre_root nre
+                                          <*> Just (map toTerm $ [t] 
+                                                              <> (unMSet $ view nre_children nre)
+                                                   )
+                        ) children 
+
+------------------------------------------
+patchMSet_toList :: (Ord a, Hashable a) => PatchMSet a -> [(a,AddRem)]
+patchMSet_toList = HM.toList . unPatchMapToHashMap . unPatchMSet
+
+unMSet :: MSet a -> [a]
+unMSet (MSet a) = Map.keys a
+

src/Gargantext/API/Ngrams/Tools.hs

@@ -142,3 +142,5 @@ getCoocByNgrams' f (Diagonal diag) m =
               ]
 
   where ks = HM.keys m
+
+------------------------------------------

src/Gargantext/API/Ngrams/Types.hs

@@ -55,6 +55,9 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger
 import Gargantext.Database.Prelude (fromField', CmdM', HasConnectionPool, HasConfig)
 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
+------------------------------------------------------------------------
+
+
 ------------------------------------------------------------------------
 --data FacetFormat = Table | Chart
 data TabType   = Docs   | Trash   | MoreFav | MoreTrash
@@ -218,7 +221,7 @@ instance Arbitrary NgramsElement where
 newtype NgramsTable = NgramsTable [NgramsElement]
   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 
-type NgramsList = NgramsTable
+-- type NgramsList = NgramsTable
 
 makePrisms ''NgramsTable
 
@@ -753,12 +756,10 @@ instance Arbitrary NgramsRepoElement where
     where
       NgramsTable ns = mockTable
 
---{-
 instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
   where
     parseUrlPiece x = maybeToEither x (decode $ cs x)
 
-
 ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
 ngramsTypeFromTabType tabType =
   let lieu = "Garg.API.Ngrams: " :: Text in
@@ -783,3 +784,7 @@ instance FromJSON UpdateTableNgramsCharts where
   parseJSON = genericParseJSON $ jsonOptions "_utn_"
 instance ToSchema UpdateTableNgramsCharts where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_utn_")
+
+------------------------------------------------------------------------
+type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
+

src/Gargantext/Core/Text/List/Social/Patch.hs

@@ -18,6 +18,7 @@ import Data.HashMap.Strict (HashMap)
 import Data.Monoid
 import Data.Semigroup
 import Gargantext.API.Ngrams.Types
+import Gargantext.API.Ngrams.Prelude (unMSet, patchMSet_toList)
 import Gargantext.Core.Text.List.Social.Prelude
 import Gargantext.Core.Types (ListId)
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
@@ -28,9 +29,9 @@ import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Patch.Class    as Patch (Replace(..))
 
 addScorePatches :: NgramsType -> [ListId]
-               -> FlowCont NgramsTerm FlowListScores
-               -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-               -> FlowCont NgramsTerm FlowListScores
+                -> FlowCont NgramsTerm FlowListScores
+                -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
+                -> FlowCont NgramsTerm FlowListScores
 addScorePatches nt listes fl repo = foldl' (addScorePatchesList nt repo) fl listes
 
 
@@ -136,9 +137,4 @@ score field list n m = (Just mempty <> m)
                      %~ (<> Just n)
 
 ------------------------------------------------------------------------
-patchMSet_toList :: (Ord a, Hashable a) => PatchMSet a -> [(a,AddRem)]
-patchMSet_toList = HashMap.toList . unPatchMapToHashMap . unPatchMSet
-
-unMSet :: MSet a -> [a]
-unMSet (MSet a) = Map.keys a