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 import Data.Map (Map)
  15 import Data.Maybe (fromMaybe)
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.Set (Set)
  18 import Data.Text (Text)
  19 import Gargantext.API.Ngrams.Tools -- (getListNgrams)
  20 import Gargantext.API.Ngrams.Types
  21 import Gargantext.Core.Text.List.Social.Find
  22 import Gargantext.Core.Text.List.Social.ListType
  23 import Gargantext.Core.Text.List.Social.Scores
  24 import Gargantext.Core.Types.Individu
  25 import Gargantext.Core.Types.Main
  26 import Gargantext.Database.Admin.Types.Node
  27 import Gargantext.Database.Prelude
  28 import Gargantext.Database.Query.Table.Node.Error
  29 import Gargantext.Database.Query.Tree
  30 import Gargantext.Database.Schema.Ngrams
  31 import Gargantext.Prelude
  32 import qualified Data.Map   as Map
  33 import qualified Data.Set   as Set
  34
  35 ------------------------------------------------------------------------
  36 flowSocialList :: ( RepoCmdM env err m
  37                   , CmdM     env err m
  38                   , HasNodeError err
  39                   , HasTreeError err
  40                   )
  41                   => User -> NgramsType -> Set Text
  42                   -> m (Map ListType (Set Text))
  43 flowSocialList user nt ngrams' = do
  44   -- Here preference to privateLists (discutable: let user choice)
  45   privateListIds <- findListsId user Private
  46   privateLists <- flowSocialListByMode privateListIds nt ngrams'
  47   -- printDebug "* privateLists *: \n" privateLists
  48
  49   sharedListIds <- findListsId user Shared
  50   sharedLists  <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
  51   -- printDebug "* sharedLists *: \n" sharedLists
  52
  53   -- TODO publicMapList:
  54   -- Note: if both produce 3 identic repetition => refactor mode
  55   -- publicListIds <- findListsId Public user
  56   -- publicLists   <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
  57
  58   let result = parentUnionsExcl
  59              [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
  60              , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
  61              -- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
  62              ]
  63   -- printDebug "* socialLists *: results \n" result
  64   pure result
  65
  66 ------------------------------------------------------------------------
  67 ------------------------------------------------------------------------
  68 -- | FlowSocialListPriority
  69 -- Sociological assumption: either private or others (public) first
  70 -- This parameter depends on the user choice
  71 data FlowSocialListPriority = MySelfFirst | OthersFirst
  72
  73 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
  74 flowSocialListPriority MySelfFirst = [Private, Shared{-, Public -}]
  75 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
  76
  77 ------------------------------------------------------------------------
  78 flowSocialList' :: ( RepoCmdM env err m
  79                    , CmdM     env err m
  80                    , HasNodeError err
  81                    , HasTreeError err
  82                    )
  83                   => FlowSocialListPriority
  84                   -> User -> NgramsType -> Set Text
  85                   -> m (Map Text FlowListScores)
  86 flowSocialList' flowPriority user nt ngrams' =
  87   parentUnionsExcl <$> mapM (flowSocialListByMode' user nt ngrams')
  88                             (flowSocialListPriority flowPriority)
  89
  90 ------------------------------------------------------------------------
  91 flowSocialListByMode :: ( RepoCmdM env err m
  92                        , CmdM     env err m
  93                        , HasNodeError err
  94                        , HasTreeError err
  95                        )
  96                     => [NodeId]-> NgramsType -> Set Text
  97                     -> m (Map (Maybe ListType) (Set Text))
  98 flowSocialListByMode      [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
  99 flowSocialListByMode listIds  nt ngrams' = do
 100     counts  <- countFilterList ngrams' nt listIds Map.empty
 101     let r = toSocialList counts ngrams'
 102     pure r
 103
 104
 105 flowSocialListByMode' :: ( RepoCmdM env err m
 106                          , CmdM     env err m
 107                          , HasNodeError err
 108                          , HasTreeError err
 109                          )
 110                       => User -> NgramsType -> Set Text -> NodeMode
 111                       -> m (Map Text FlowListScores)
 112 flowSocialListByMode' user nt st mode =
 113       findListsId user mode
 114   >>= flowSocialListByModeWith nt st
 115
 116
 117 flowSocialListByModeWith :: ( RepoCmdM env err m
 118                             , CmdM     env err m
 119                             , HasNodeError err
 120                             , HasTreeError err
 121                             )
 122                          => NgramsType -> Set Text -> [NodeId]
 123                          -> m (Map Text FlowListScores)
 124 flowSocialListByModeWith nt st ns =
 125       mapM (\l -> getListNgrams [l] nt) ns
 126   >>= pure
 127     . toFlowListScores (keepAllParents nt) st Map.empty
 128
 129
 130 -- | We keep the parents for all ngrams but terms
 131 keepAllParents :: NgramsType -> KeepAllParents
 132 keepAllParents NgramsTerms = KeepAllParents False
 133 keepAllParents _           = KeepAllParents True
 134
 135 ------------------------------------------------------------------------
 136 -- TODO: maybe use social groups too
 137 -- | TODO what if equality ?
 138 -- choice depends on Ord instance of ListType
 139 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
 140 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
 141 -- (we minimize errors on MapTerms if doubt)
 142 toSocialList :: Map Text (Map ListType Int)
 143              -> Set Text
 144              -> Map (Maybe ListType) (Set Text)
 145 toSocialList m = Map.fromListWith (<>)
 146                . Set.toList
 147                . Set.map (toSocialList1 m)
 148
 149 toSocialList1 :: Map Text (Map ListType Int)
 150              -> Text
 151              -> (Maybe ListType, Set Text)
 152 toSocialList1 m t = case Map.lookup t m of
 153   Nothing -> (Nothing, Set.singleton t)
 154   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
 155               , Set.singleton t
 156               )
 157
 158 toSocialList1_testIsTrue :: Bool
 159 toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
 160   where
 161     result = toSocialList1 (Map.fromList [(token, m)]) token
 162     token  = "token"
 163     m = Map.fromList [ (CandidateTerm, 1)
 164                      , (MapTerm      , 2)
 165                      , (StopTerm     , 3)
 166                      ]
 167
 168 ------------------------------------------------------------------------
 169 -- | Tools
 170 ------------------------------------------------------------------------
 171 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
 172 termsByList CandidateTerm m = Set.unions
 173                           $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
 174                           [ Nothing, Just CandidateTerm ]
 175 termsByList l m =
 176   fromMaybe Set.empty $ Map.lookup (Just l) m
 177
 178 ------------------------------------------------------------------------
 179 unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
 180       => [Map a (Set b)] -> Map a (Set b)
 181 unions = invertBack . Map.unionsWith (<>) . map invertForw
 182
 183 invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
 184 invertForw = Map.unionsWith (<>)
 185            . (map (\(k,sets) -> Map.fromSet (\_ -> k) sets))
 186            . Map.toList
 187
 188 invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
 189 invertBack = Map.fromListWith (<>)
 190            . (map (\(b,a) -> (a, Set.singleton b)))
 191            .  Map.toList
 192
 193 unions_test :: Map ListType (Set Text)
 194 unions_test = unions [m1, m2]
 195   where
 196     m1 = Map.fromList [ (StopTerm     , Set.singleton "Candidate")]
 197     m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
 198                       , (MapTerm      , Set.singleton "Candidate")
 199                       ]