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 Private user
  46   privateLists <- flowSocialListByMode privateListIds nt ngrams'
  47   -- printDebug "* privateLists *: \n" privateLists
  48
  49   sharedListIds <- findListsId Shared user
  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 flowSocialListByMode :: ( RepoCmdM env err m
  68                        , CmdM     env err m
  69                        , HasNodeError err
  70                        , HasTreeError err
  71                        )
  72                     => [NodeId]-> NgramsType -> Set Text
  73                     -> m (Map (Maybe ListType) (Set Text))
  74 flowSocialListByMode      [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
  75 flowSocialListByMode listIds  nt ngrams' = do
  76     counts  <- countFilterList ngrams' nt listIds Map.empty
  77     let r = toSocialList counts ngrams'
  78     pure r
  79
  80
  81 flowSocialListByMode' :: ( RepoCmdM env err m
  82                          , CmdM     env err m
  83                          , HasNodeError err
  84                          , HasTreeError err
  85                          )
  86                       => KeepAllParents -> [NodeId]-> NgramsType -> Set Text
  87                       -> m (Map Text FlowListScores)
  88 flowSocialListByMode' k ns nt st = do
  89   ngramsRepos <- mapM (\l -> getListNgrams [l] nt) ns
  90   pure $ toFlowListScores k st Map.empty ngramsRepos
  91
  92 ------------------------------------------------------------------------
  93 -- TODO: maybe use social groups too
  94 -- | TODO what if equality ?
  95 -- choice depends on Ord instance of ListType
  96 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
  97 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
  98 -- (we minimize errors on MapTerms if doubt)
  99 toSocialList :: Map Text (Map ListType Int)
 100              -> Set Text
 101              -> Map (Maybe ListType) (Set Text)
 102 toSocialList m = Map.fromListWith (<>)
 103                . Set.toList
 104                . Set.map (toSocialList1 m)
 105
 106 toSocialList1 :: Map Text (Map ListType Int)
 107              -> Text
 108              -> (Maybe ListType, Set Text)
 109 toSocialList1 m t = case Map.lookup t m of
 110   Nothing -> (Nothing, Set.singleton t)
 111   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
 112               , Set.singleton t
 113               )
 114
 115 toSocialList1_testIsTrue :: Bool
 116 toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
 117   where
 118     result = toSocialList1 (Map.fromList [(token, m)]) token
 119     token  = "token"
 120     m = Map.fromList [ (CandidateTerm, 1)
 121                      , (MapTerm      , 2)
 122                      , (StopTerm     , 3)
 123                      ]
 124
 125 ------------------------------------------------------------------------
 126 -- | Tools
 127 ------------------------------------------------------------------------
 128 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
 129 termsByList CandidateTerm m = Set.unions
 130                           $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
 131                           [ Nothing, Just CandidateTerm ]
 132 termsByList l m =
 133   fromMaybe Set.empty $ Map.lookup (Just l) m
 134
 135 ------------------------------------------------------------------------
 136 unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
 137       => [Map a (Set b)] -> Map a (Set b)
 138 unions = invertBack . Map.unionsWith (<>) . map invertForw
 139
 140 invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
 141 invertForw = Map.unionsWith (<>)
 142            . (map (\(k,sets) -> Map.fromSet (\_ -> k) sets))
 143            . Map.toList
 144
 145 invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
 146 invertBack = Map.fromListWith (<>)
 147            . (map (\(b,a) -> (a, Set.singleton b)))
 148            .  Map.toList
 149
 150 unions_test :: Map ListType (Set Text)
 151 unions_test = unions [m1, m2]
 152   where
 153     m1 = Map.fromList [ (StopTerm     , Set.singleton "Candidate")]
 154     m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
 155                       , (MapTerm      , Set.singleton "Candidate")
 156                       ]