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 ------------------------------------------------------------------------
  39 flowSocialList :: ( RepoCmdM env err m
  40                   , CmdM     env err m
  41                   , HasNodeError err
  42                   , HasTreeError err
  43                   )
  44                   => User -> NgramsType -> Set Text
  45                   -> m (Map ListType (Set Text))
  46 flowSocialList user nt ngrams' = do
  47   privateLists <- flowSocialListByMode Private user nt ngrams'
  48   -- printDebug "* privateLists *: \n" privateLists
  49   -- here preference to privateLists (discutable)
  50   sharedLists  <- flowSocialListByMode Shared  user nt (termsByList CandidateTerm privateLists)
  51   -- printDebug "* sharedLists *: \n" sharedLists
  52    -- TODO publicMapList
  53
  54   let result = unions [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
  55                       , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
  56                       ]
  57   -- printDebug "* socialLists *: results \n" result
  58   pure result
  59
  60
  61 ------------------------------------------------------------------------
  62 unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
  63       => [Map a (Set b)] -> Map a (Set b)
  64 unions = invertBack . Map.unionsWith (<>) . map invertForw
  65
  66 invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
  67 invertForw = Map.unionsWith (<>)
  68            . (map (\(k,sets) -> Map.fromSet (\_ -> k) sets))
  69            . Map.toList
  70
  71 invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
  72 invertBack = Map.fromListWith (<>)
  73            . (map (\(b,a) -> (a, Set.singleton b)))
  74            .  Map.toList
  75
  76 unions_test :: Map ListType (Set Text)
  77 unions_test = unions [m1, m2]
  78   where
  79     m1 = Map.fromList [ (StopTerm     , Set.singleton "Candidate")]
  80     m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
  81                       , (MapTerm      , Set.singleton "Candidate")
  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 ----------------------
 173 -- | Tools to inherit groupings
 174 ----------------------
 175 type Parent = Text
 176
 177 parentUnionsMerge :: (Ord a, Ord b, Num c)
 178              => [Map a (Map b c)]
 179              ->  Map a (Map b c)
 180 parentUnionsMerge = Map.unionsWith (Map.unionWith (+))
 181
 182 -- This Parent union is specific
 183 -- [Private, Shared, Public]
 184 -- means the following preferences:
 185 -- Private > Shared > Public
 186 -- if data have not been tagged privately, then use others tags
 187 -- This unions behavior takes first key only and ignore others
 188 parentUnionsExcl :: Ord a
 189                  => [Map a b]
 190                  -> Map a b
 191 parentUnionsExcl = Map.unions
 192
 193
 194 hasParent :: Text
 195           -> Map Text (Map Parent Int)
 196           -> Maybe Parent
 197 hasParent t m = case Map.lookup t m of
 198   Nothing  -> Nothing
 199   Just  m' -> (fst . fst) <$> Map.maxViewWithKey m'
 200
 201
 202 toMapTextParent :: Set Text
 203                 ->  Map Text (Map Parent Int)
 204                 -> [Map Text NgramsRepoElement]
 205                 -> Map Text (Map Parent Int)
 206 toMapTextParent ts = foldl' (toMapTextParent' ts)
 207   where
 208
 209     toMapTextParent' :: Set Text
 210                     -> Map Text (Map Parent Int)
 211                     -> Map Text NgramsRepoElement
 212                     -> Map Text (Map Parent Int)
 213     toMapTextParent' ts' to from = Set.foldl' (toMapTextParent'' ts' from) to ts'
 214
 215
 216     toMapTextParent'' :: Set Text
 217                       -> Map Text NgramsRepoElement
 218                       -> Map Text (Map Parent Int)
 219                       -> Text
 220                       -> Map Text (Map Parent Int)
 221     toMapTextParent'' ss from to t = case Map.lookup t from of
 222       Nothing  -> to
 223       Just nre -> case _nre_parent nre of
 224         Just (NgramsTerm p')  -> if Set.member p' ss
 225                                     then Map.alter (addParent p') t to
 226                                     else to
 227           where
 228             addParent p'' Nothing   = Just $ addCountParent p'' Map.empty
 229             addParent p'' (Just ps) = Just $ addCountParent p'' ps
 230
 231             addCountParent :: Parent -> Map Parent Int -> Map Parent Int
 232             addCountParent p m = Map.alter addCount p m
 233               where
 234                 addCount Nothing  = Just 1
 235                 addCount (Just n) = Just $ n + 1
 236
 237         _ -> to
 238
 239
 240 ------------------------------------------------------------------------
 241 toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
 242 toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
 243      List.zip terms (List.cycle [lt'])
 244       where
 245         terms =  [t]
 246               -- <> maybe [] (\n -> [unNgramsTerm n]) root
 247               -- <> maybe [] (\n -> [unNgramsTerm n]) parent
 248               <> (map unNgramsTerm $ Map.keys children)
 249         lt'   = listOf m nre
 250
 251 listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
 252 listOf m ng = case _nre_parent ng of
 253   Nothing -> _nre_list ng
 254   Just  p -> case Map.lookup (unNgramsTerm p) m of
 255     Just ng' -> listOf m ng'
 256     Nothing  -> CandidateTerm
 257     -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
 258
 259 ------------------------------------------------------------------------
 260 countList :: Text
 261           -> Map Text ListType
 262           -> Map Text (Map ListType Int)
 263           -> Map Text (Map ListType Int)
 264 countList t m input = case Map.lookup t m of
 265   Nothing -> input
 266   Just l  -> Map.alter addList t input
 267     where
 268       addList Nothing   = Just $ addCountList l Map.empty
 269       addList (Just lm) = Just $ addCountList l lm
 270
 271 addCountList :: ListType -> Map ListType Int -> Map ListType Int
 272 addCountList l m = Map.alter (plus l) l  m
 273   where
 274     plus CandidateTerm Nothing  = Just 1
 275     plus CandidateTerm (Just x) = Just $ x + 1
 276
 277     plus _ Nothing              = Just 3
 278     plus _ (Just x)             = Just $ x + 3
 279
 280 ------------------------------------------------------------------------
 281 findListsId :: (HasNodeError err, HasTreeError err)
 282             => NodeMode -> User -> Cmd err [NodeId]
 283 findListsId mode u = do
 284   r <- getRootId u
 285   ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
 286                        <$> findNodes' mode r
 287   -- printDebug "findListsIds" ns
 288   pure ns
 289
 290
 291 findNodes' :: HasTreeError err
 292           => NodeMode -> RootId
 293           -> Cmd err [DbTreeNode]
 294 findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
 295 findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
 296 findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes
 297
 298 commonNodes:: [NodeType]
 299 commonNodes = [NodeFolder, NodeCorpus, NodeList]
 300