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

   1 {-|
   2 Module      : Gargantext.Core.Text.List.Social
   3 Description :
   4 Copyright   : (c) CNRS, 2018-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 module Gargantext.Core.Text.List.Social
  12   where
  13
  14 -- findList imports
  15 import Gargantext.Core.Types.Individu
  16 import Gargantext.Database.Admin.Config
  17 import Gargantext.Database.Admin.Types.Node
  18 import Gargantext.Database.Prelude
  19 import Gargantext.Database.Query.Table.Node.Error
  20 import Gargantext.Database.Query.Tree
  21 import Gargantext.Database.Query.Tree.Root (getRootId)
  22 import Gargantext.Prelude
  23
  24 -- filterList imports
  25 import Data.Maybe (fromMaybe)
  26 import Data.Map (Map)
  27 import Data.Set (Set)
  28 import Data.Semigroup (Semigroup(..))
  29 import Data.Text (Text)
  30 import Gargantext.API.Ngrams.Tools -- (getListNgrams)
  31 import Gargantext.API.Ngrams.Types
  32 import Gargantext.Core.Types.Main
  33 import Gargantext.Database.Schema.Ngrams
  34 import qualified Data.List  as List
  35 import qualified Data.Map   as Map
  36 import qualified Data.Set   as Set
  37
  38 flowSocialList :: ( RepoCmdM env err m
  39                   , CmdM     env err m
  40                   , HasNodeError err
  41                   , HasTreeError err
  42                   )
  43                   => User -> NgramsType -> Set Text
  44                   -> m (Map ListType (Set Text))
  45 flowSocialList user nt ngrams' = do
  46   privateLists <- flowSocialListByMode Private user nt ngrams'
  47   -- printDebug "* privateLists *: \n" privateLists
  48   -- here preference to privateLists (discutable)
  49   sharedLists  <- flowSocialListByMode Shared  user nt (termsByList CandidateTerm privateLists)
  50   -- printDebug "* sharedLists *: \n" sharedLists
  51    -- TODO publicMapList
  52
  53   let result = unions [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
  54                       , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
  55                       ]
  56   printDebug "* socialLists *: results \n" result
  57   pure result
  58
  59
  60 ------------------------------------------------------------------------
  61 unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
  62       => [Map a (Set b)] -> Map a (Set b)
  63 unions = invertBack . Map.unionsWith (<>) . map invertForw
  64
  65 invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
  66 invertForw = Map.unionsWith (<>)
  67            . (map (\(k,sets) -> Map.fromSet (\_ -> k) sets))
  68            . Map.toList
  69
  70 invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
  71 invertBack = Map.fromListWith (<>)
  72            . (map (\(b,a) -> (a, Set.singleton b)))
  73            .  Map.toList
  74
  75 unions_test :: Map ListType (Set Text)
  76 unions_test = unions [m1, m2]
  77   where
  78     m1 = Map.fromList [ (StopTerm, Set.singleton "Candidate")]
  79     m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
  80                       , (MapTerm, Set.singleton "Candidate")
  81                       ]
  82
  83 ------------------------------------------------------------------------
  84
  85 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
  86 termsByList CandidateTerm m = Set.unions
  87                           $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
  88                           [ Nothing, Just CandidateTerm ]
  89 termsByList l m =
  90   fromMaybe Set.empty $ Map.lookup (Just l) m
  91
  92
  93 flowSocialListByMode :: ( RepoCmdM env err m
  94                         , CmdM     env err m
  95                         , HasNodeError err
  96                         , HasTreeError err
  97                         )
  98                      => NodeMode -> User -> NgramsType -> Set Text
  99                      -> m (Map (Maybe ListType) (Set Text))
 100 flowSocialListByMode mode user nt ngrams' = do
 101   listIds <- findListsId mode user
 102   case listIds of
 103     [] -> pure $ Map.fromList [(Nothing, ngrams')]
 104     _  -> do
 105       counts  <- countFilterList ngrams' nt listIds Map.empty
 106       -- printDebug "flowSocialListByMode counts" counts
 107       let r = toSocialList counts ngrams'
 108       -- printDebug "flowSocialListByMode r" r
 109       pure r
 110
 111 ---------------------------------------------------------------------------
 112 -- TODO: maybe use social groups too
 113 toSocialList :: Map Text (Map ListType Int)
 114              -> Set Text
 115              -> Map (Maybe ListType) (Set Text)
 116 toSocialList m = Map.fromListWith (<>)
 117                . Set.toList
 118                . Set.map (toSocialList1 m)
 119
 120 -- | TODO what if equality ?
 121 -- choice depends on Ord instance of ListType
 122 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
 123 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
 124 -- (we minimize errors on MapTerms if doubt)
 125 toSocialList1 :: Map Text (Map ListType Int)
 126              -> Text
 127              -> (Maybe ListType, Set Text)
 128 toSocialList1 m t = case Map.lookup t m of
 129   Nothing -> (Nothing, Set.singleton t)
 130   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
 131               , Set.singleton t
 132               )
 133
 134 toSocialList1_testIsTrue :: Bool
 135 toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
 136   where
 137     result = toSocialList1 (Map.fromList [(token, m)]) token
 138     token  = "token"
 139     m = Map.fromList [ (CandidateTerm, 1)
 140                      , (MapTerm      , 2)
 141                      , (StopTerm     , 3)
 142                      ]
 143
 144 ---------------------------------------------------------------------------
 145 -- | [ListId] does not merge the lists (it is for Master and User lists
 146 -- here we need UserList only
 147 countFilterList :: RepoCmdM env err m
 148         => Set Text -> NgramsType -> [ListId]
 149         -> Map Text (Map ListType Int)
 150         -> m (Map Text (Map ListType Int))
 151 countFilterList st nt ls input =
 152   foldM' (\m l -> countFilterList' st nt [l] m) input ls
 153
 154
 155 countFilterList' :: RepoCmdM env err m
 156         => Set Text -> NgramsType -> [ListId]
 157         -> Map Text (Map ListType Int)
 158         -> m (Map Text (Map ListType Int))
 159 countFilterList' st nt ls input = do
 160   ml <- toMapTextListType <$> getListNgrams ls nt
 161   -- printDebug "countFilterList'" ml
 162   pure $ Set.foldl' (\m t -> countList t ml m) input st
 163
 164 ---------------------------------------------------------------------------
 165 -- FIXME children have to herit the ListType of the parent
 166 toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
 167 toMapTextListType m = Map.fromListWith (<>)
 168                     $  List.concat
 169                     $ (map (toList m))
 170                     $  Map.toList m
 171
 172 toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
 173 toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
 174      List.zip terms (List.cycle [lt'])
 175       where
 176         terms =  [t]
 177               -- <> maybe [] (\n -> [unNgramsTerm n]) root
 178               -- <> maybe [] (\n -> [unNgramsTerm n]) parent
 179               <> (map unNgramsTerm $ Map.keys children)
 180         lt'   = listOf m nre
 181
 182 listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
 183 listOf m ng = case _nre_parent ng of
 184   Nothing -> _nre_list ng
 185   Just  p -> case Map.lookup (unNgramsTerm p) m of
 186     Just ng' -> listOf m ng'
 187     Nothing  -> panic "CandidateTerm -- Should Not happen"
 188
 189 ---------------------------------------------------------------------------
 190 countList :: Text
 191           -> Map Text ListType
 192           -> Map Text (Map ListType Int)
 193           -> Map Text (Map ListType Int)
 194 countList t m input = case Map.lookup t m of
 195   Nothing -> input
 196   Just l  -> Map.alter addList t input
 197     where
 198       addList Nothing   = Just $ addCount l Map.empty
 199       addList (Just lm) = Just $ addCount l lm
 200
 201 addCount :: ListType -> Map ListType Int -> Map ListType Int
 202 addCount l m = Map.alter (plus l) l  m
 203   where
 204     plus CandidateTerm Nothing  = Just 1
 205     plus CandidateTerm (Just x) = Just $ x + 1
 206
 207     plus _ Nothing              = Just 3
 208     plus _ (Just x)             = Just $ x + 3
 209
 210 ------------------------------------------------------------------------
 211 findListsId :: (HasNodeError err, HasTreeError err)
 212             => NodeMode -> User -> Cmd err [NodeId]
 213 findListsId mode u = do
 214   r <- getRootId u
 215   ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
 216                        <$> findNodes' mode r
 217   -- printDebug "findListsIds" ns
 218   pure ns
 219
 220
 221 findNodes' :: HasTreeError err
 222           => NodeMode -> RootId
 223           -> Cmd err [DbTreeNode]
 224 findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
 225 findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
 226 findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes
 227
 228 commonNodes:: [NodeType]
 229 commonNodes = [NodeFolder, NodeCorpus, NodeList]
 230
 231
 232