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 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 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
  85 termsByList CandidateTerm m = Set.unions
  86                           $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
  87                           [ Nothing, Just CandidateTerm ]
  88 termsByList l m =
  89   fromMaybe Set.empty $ Map.lookup (Just l) m
  90
  91
  92 flowSocialListByMode :: ( RepoCmdM env err m
  93                         , CmdM     env err m
  94                         , HasNodeError err
  95                         , HasTreeError err
  96                         )
  97                      => NodeMode -> User -> NgramsType -> Set Text
  98                      -> m (Map (Maybe ListType) (Set Text))
  99 flowSocialListByMode mode user nt ngrams' = do
 100   listIds <- findListsId mode user
 101   case listIds of
 102     [] -> pure $ Map.fromList [(Nothing, ngrams')]
 103     _  -> do
 104       counts  <- countFilterList ngrams' nt listIds Map.empty
 105       -- printDebug "flowSocialListByMode counts" counts
 106       let r = toSocialList counts ngrams'
 107       -- printDebug "flowSocialListByMode r" r
 108       pure r
 109
 110 ------------------------------------------------------------------------
 111 -- TODO: maybe use social groups too
 112 toSocialList :: Map Text (Map ListType Int)
 113              -> Set Text
 114              -> Map (Maybe ListType) (Set Text)
 115 toSocialList m = Map.fromListWith (<>)
 116                . Set.toList
 117                . Set.map (toSocialList1 m)
 118
 119 -- | TODO what if equality ?
 120 -- choice depends on Ord instance of ListType
 121 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
 122 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
 123 -- (we minimize errors on MapTerms if doubt)
 124 toSocialList1 :: Map Text (Map ListType Int)
 125              -> Text
 126              -> (Maybe ListType, Set Text)
 127 toSocialList1 m t = case Map.lookup t m of
 128   Nothing -> (Nothing, Set.singleton t)
 129   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
 130               , Set.singleton t
 131               )
 132
 133 toSocialList1_testIsTrue :: Bool
 134 toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
 135   where
 136     result = toSocialList1 (Map.fromList [(token, m)]) token
 137     token  = "token"
 138     m = Map.fromList [ (CandidateTerm, 1)
 139                      , (MapTerm      , 2)
 140                      , (StopTerm     , 3)
 141                      ]
 142
 143 ------------------------------------------------------------------------
 144 -- | [ListId] does not merge the lists (it is for Master and User lists
 145 -- here we need UserList only
 146 countFilterList :: RepoCmdM env err m
 147         => Set Text -> NgramsType -> [ListId]
 148         -> Map Text (Map ListType Int)
 149         -> m (Map Text (Map ListType Int))
 150 countFilterList st nt ls input =
 151   foldM' (\m l -> countFilterList' st nt [l] m) input ls
 152
 153
 154 countFilterList' :: RepoCmdM env err m
 155         => Set Text -> NgramsType -> [ListId]
 156         -> Map Text (Map ListType Int)
 157         -> m (Map Text (Map ListType Int))
 158 countFilterList' st nt ls input = do
 159   ml <- toMapTextListType <$> getListNgrams ls nt
 160   -- printDebug "countFilterList'" ml
 161   pure $ Set.foldl' (\m t -> countList t ml m) input st
 162
 163 ------------------------------------------------------------------------
 164 -- FIXME children have to herit the ListType of the parent
 165 toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
 166 toMapTextListType m = Map.fromListWith (<>)
 167                     $ List.concat
 168                     $ map (toList m)
 169                     $ Map.toList m
 170
 171 ----------------------
 172 -- | Tools to inherit groupings
 173 ----------------------
 174 type Parent = Text
 175
 176 parentUnionsMerge :: (Ord a, Ord b, Num c)
 177              => [Map a (Map b c)]
 178              ->  Map a (Map b c)
 179 parentUnionsMerge = Map.unionsWith (Map.unionWith (+))
 180
 181 -- This Parent union is specific
 182 -- [Private, Shared, Public]
 183 -- means the following preferences:
 184 -- Private > Shared > Public
 185 -- if data have not been tagged privately, then use others tags
 186 -- This unions behavior takes first key only and ignore others
 187 parentUnionsExcl :: Ord a
 188                  => [Map a b]
 189                  -> Map a b
 190 parentUnionsExcl = Map.unions
 191
 192
 193 hasParent :: Text
 194           -> Map Text (Map Parent Int)
 195           -> Maybe Parent
 196 hasParent t m = case Map.lookup t m of
 197   Nothing  -> Nothing
 198   Just  m' -> (fst . fst) <$> Map.maxViewWithKey m'
 199
 200
 201 toMapTextParent :: Set Text
 202                 ->  Map Text (Map Parent Int)
 203                 -> [Map Text NgramsRepoElement]
 204                 -> Map Text (Map Parent Int)
 205 toMapTextParent ts = foldl' (toMapTextParent' ts)
 206   where
 207
 208     toMapTextParent' :: Set Text
 209                     -> Map Text (Map Parent Int)
 210                     -> Map Text NgramsRepoElement
 211                     -> Map Text (Map Parent Int)
 212     toMapTextParent' ts' to from = Set.foldl' (toMapTextParent'' ts' from) to ts'
 213
 214
 215     toMapTextParent'' :: Set Text
 216                       -> Map Text NgramsRepoElement
 217                       -> Map Text (Map Parent Int)
 218                       -> Text
 219                       -> Map Text (Map Parent Int)
 220     toMapTextParent'' ss from to t = case Map.lookup t from of
 221       Nothing  -> to
 222       Just nre -> case _nre_parent nre of
 223         Just (NgramsTerm p')  -> if Set.member p' ss
 224                                     then Map.alter (addParent p') t to
 225                                     else to
 226           where
 227             addParent p'' Nothing   = Just $ addCountParent p'' Map.empty
 228             addParent p'' (Just ps) = Just $ addCountParent p'' ps
 229
 230             addCountParent :: Parent -> Map Parent Int -> Map Parent Int
 231             addCountParent p m = Map.alter addCount p m
 232               where
 233                 addCount Nothing  = Just 1
 234                 addCount (Just n) = Just $ n + 1
 235
 236         _ -> to
 237
 238
 239 ------------------------------------------------------------------------
 240 toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
 241 toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
 242      List.zip terms (List.cycle [lt'])
 243       where
 244         terms =  [t]
 245               -- <> maybe [] (\n -> [unNgramsTerm n]) root
 246               -- <> maybe [] (\n -> [unNgramsTerm n]) parent
 247               <> (map unNgramsTerm $ Map.keys children)
 248         lt'   = listOf m nre
 249
 250 listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
 251 listOf m ng = case _nre_parent ng of
 252   Nothing -> _nre_list ng
 253   Just  p -> case Map.lookup (unNgramsTerm p) m of
 254     Just ng' -> listOf m ng'
 255     Nothing  -> CandidateTerm
 256     -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
 257
 258 ------------------------------------------------------------------------
 259 countList :: Text
 260           -> Map Text ListType
 261           -> Map Text (Map ListType Int)
 262           -> Map Text (Map ListType Int)
 263 countList t m input = case Map.lookup t m of
 264   Nothing -> input
 265   Just l  -> Map.alter addList t input
 266     where
 267       addList Nothing   = Just $ addCountList l Map.empty
 268       addList (Just lm) = Just $ addCountList l lm
 269
 270 addCountList :: ListType -> Map ListType Int -> Map ListType Int
 271 addCountList l m = Map.alter (plus l) l  m
 272   where
 273     plus CandidateTerm Nothing  = Just 1
 274     plus CandidateTerm (Just x) = Just $ x + 1
 275
 276     plus _ Nothing              = Just 3
 277     plus _ (Just x)             = Just $ x + 3
 278
 279 ------------------------------------------------------------------------
 280 findListsId :: (HasNodeError err, HasTreeError err)
 281             => NodeMode -> User -> Cmd err [NodeId]
 282 findListsId mode u = do
 283   r <- getRootId u
 284   ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
 285                        <$> findNodes' mode r
 286   -- printDebug "findListsIds" ns
 287   pure ns
 288
 289
 290 findNodes' :: HasTreeError err
 291           => NodeMode -> RootId
 292           -> Cmd err [DbTreeNode]
 293 findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
 294 findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
 295 findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes
 296
 297 commonNodes:: [NodeType]
 298 commonNodes = [NodeFolder, NodeCorpus, NodeList]
 299