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.Group
  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 = PrivateFirst | OthersFirst
  72
  73 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
  74 flowSocialListPriority PrivateFirst = [Private, Shared{-, Public -}]
  75 flowSocialListPriority OthersFirst  = reverse $ flowSocialListPriority PrivateFirst
  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 ------------------------------------------------------------------------
  92 flowSocialListByMode :: ( RepoCmdM env err m
  93                        , CmdM     env err m
  94                        , HasNodeError err
  95                        , HasTreeError err
  96                        )
  97                     => [NodeId]-> NgramsType -> Set Text
  98                     -> m (Map (Maybe ListType) (Set Text))
  99 flowSocialListByMode      [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
 100 flowSocialListByMode listIds  nt ngrams' = do
 101     counts  <- countFilterList ngrams' nt listIds Map.empty
 102     let r = toSocialList counts ngrams'
 103     pure r
 104
 105
 106 flowSocialListByMode' :: ( RepoCmdM env err m
 107                          , CmdM     env err m
 108                          , HasNodeError err
 109                          , HasTreeError err
 110                          )
 111                       => User -> NgramsType -> Set Text -> NodeMode
 112                       -> m (Map Text FlowListScores)
 113 flowSocialListByMode' user nt st mode =
 114       findListsId user mode
 115   >>= flowSocialListByModeWith nt st
 116
 117
 118 flowSocialListByModeWith :: ( RepoCmdM env err m
 119                          , CmdM     env err m
 120                          , HasNodeError err
 121                          , HasTreeError err
 122                          )
 123                       => NgramsType -> Set Text -> [NodeId]
 124                       -> m (Map Text FlowListScores)
 125 flowSocialListByModeWith nt st ns =
 126       mapM (\l -> getListNgrams [l] nt) ns
 127   >>= pure
 128     . toFlowListScores (keepAllParents nt) st Map.empty
 129
 130
 131 -- | We keep the parents for all ngrams but terms
 132 keepAllParents :: NgramsType -> KeepAllParents
 133 keepAllParents NgramsTerms = KeepAllParents False
 134 keepAllParents _           = KeepAllParents True
 135
 136 ------------------------------------------------------------------------
 137 -- TODO: maybe use social groups too
 138 -- | TODO what if equality ?
 139 -- choice depends on Ord instance of ListType
 140 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
 141 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
 142 -- (we minimize errors on MapTerms if doubt)
 143 toSocialList :: Map Text (Map ListType Int)
 144              -> Set Text
 145              -> Map (Maybe ListType) (Set Text)
 146 toSocialList m = Map.fromListWith (<>)
 147                . Set.toList
 148                . Set.map (toSocialList1 m)
 149
 150 toSocialList1 :: Map Text (Map ListType Int)
 151              -> Text
 152              -> (Maybe ListType, Set Text)
 153 toSocialList1 m t = case Map.lookup t m of
 154   Nothing -> (Nothing, Set.singleton t)
 155   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
 156               , Set.singleton t
 157               )
 158
 159 toSocialList1_testIsTrue :: Bool
 160 toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
 161   where
 162     result = toSocialList1 (Map.fromList [(token, m)]) token
 163     token  = "token"
 164     m = Map.fromList [ (CandidateTerm, 1)
 165                      , (MapTerm      , 2)
 166                      , (StopTerm     , 3)
 167                      ]
 168
 169 ------------------------------------------------------------------------
 170 -- | Tools
 171 ------------------------------------------------------------------------
 172 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
 173 termsByList CandidateTerm m = Set.unions
 174                           $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
 175                           [ Nothing, Just CandidateTerm ]
 176 termsByList l m =
 177   fromMaybe Set.empty $ Map.lookup (Just l) m
 178
 179 ------------------------------------------------------------------------
 180 unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
 181       => [Map a (Set b)] -> Map a (Set b)
 182 unions = invertBack . Map.unionsWith (<>) . map invertForw
 183
 184 invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
 185 invertForw = Map.unionsWith (<>)
 186            . (map (\(k,sets) -> Map.fromSet (\_ -> k) sets))
 187            . Map.toList
 188
 189 invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
 190 invertBack = Map.fromListWith (<>)
 191            . (map (\(b,a) -> (a, Set.singleton b)))
 192            .  Map.toList
 193
 194 unions_test :: Map ListType (Set Text)
 195 unions_test = unions [m1, m2]
 196   where
 197     m1 = Map.fromList [ (StopTerm     , Set.singleton "Candidate")]
 198     m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
 199                       , (MapTerm      , Set.singleton "Candidate")
 200                       ]