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