Skip to content

haskell-gargantext
haskell-gargantext
Commit 4ea0d7f8 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[CLEAN] removing previous code (WIP)

parent 480f7bb9
Hide whitespace changes
Inline Side-by-side
Showing with 55 additions and 509 deletions
src/Gargantext/Core/Text/List.hs
View file @ 4ea0d7f8
......@@ -17,7 +17,7 @@ module Gargantext.Core.Text.List
import Control.Lens hiding (both) -- ((^.), view, over, set, (_1), (_2))
import Data.Map (Map)
import Data.Maybe (catMaybes)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (mempty)
import Data.Ord (Down(..))
import Data.Set (Set)
......@@ -31,7 +31,7 @@ import Gargantext.Core.Text.List.Group.Prelude
import Gargantext.Core.Text.List.Group.WithStem
import Gargantext.Core.Text.List.Social
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Text.Metrics (scored', Scored(..), scored_speExc, scored_genInc, normalizeGlobal, normalizeLocal)
import Gargantext.Core.Text.Metrics (scored', Scored(..), scored_speExc, scored_genInc, normalizeGlobal, normalizeLocal, scored_terms)
import Gargantext.Core.Types (ListType(..), MasterCorpusId, UserCorpusId)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getNodesByNgramsOnlyUser)
......@@ -50,6 +50,16 @@ import qualified Data.Set as Set
import qualified Data.Text as Text
{-
-- TODO maybe useful for later
isStopTerm :: StopSize -> Text -> Bool
isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
where
isStopChar c = not (c `elem` ("- /()%" :: [Char]) || Char.isAlpha c)
-}
-- | TODO improve grouping functions of Authors, Sources, Institutes..
buildNgramsLists :: ( RepoCmdM env err m
, CmdM env err m
......@@ -94,20 +104,9 @@ buildNgramsOthersList user uCid groupParams (nt, MapListSize mapListSize) = do
$ List.zip (Map.keys allTerms)
(List.cycle [mempty])
)
{-
printDebug "flowSocialList'"
$ Map.filter (not . ((==) Map.empty) . (view fls_parents))
$ view flc_scores socialLists'
-}
let
groupedWithList = toGroupedTree groupParams socialLists' allTerms
{-
printDebug "groupedWithList"
$ view flc_cont groupedWithList
-}
let
(stopTerms, tailTerms) = Map.partition ((== Just StopTerm) . viewListType) $ view flc_scores groupedWithList
(mapTerms, tailTerms') = Map.partition ((== Just MapTerm) . viewListType) tailTerms
......@@ -149,36 +148,15 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
$ List.zip (Map.keys allTerms)
(List.cycle [mempty])
)
{-
printDebug "flowSocialList'"
$ Map.filter (not . ((==) Map.empty) . (view fls_parents))
$ view flc_scores socialLists'
-}
let groupedWithList = toGroupedTree groupParams socialLists' allTerms
{-
-- TODO remove
-- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
-- First remove stops terms
socialLists <- flowSocialList user nt (Set.fromList $ map fst $ Map.toList allTerms)
-- Grouping the ngrams and keeping the maximum score for label
let grouped = groupedTextWithStem ( GroupedTextParams (groupWith groupParams) identity (const Set.empty) (const Set.empty) {-(size . _gt_label)-} ) allTerms
groupedWithList = map (addListType (invertForw socialLists)) grouped
-- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
-}
(stopTerms, candidateTerms) = Map.partition ((== Just StopTerm) . viewListType)
$ view flc_scores groupedWithList
-- (groupedMono, groupedMult) = Map.partition (\t -> t ^. gt_size < 2) candidateTerms
(groupedMono, groupedMult) = Map.partitionWithKey (\t _v -> size t < 2) candidateTerms
-- printDebug "\n * stopTerms * \n" stopTerms
-- splitting monterms and multiterms to take proportional candidates
let
listSizeGlobal = 2000 :: Double -- use % of list if to big, or Int if too small
-- use % of list if to big, or Int if too small
listSizeGlobal = 2000 :: Double
monoSize = 0.4 :: Double
multSize = 1 - monoSize
......@@ -190,24 +168,9 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
(groupedMonoHead, groupedMonoTail) = splitAt monoSize groupedMono
(groupedMultHead, groupedMultTail) = splitAt multSize groupedMult
-- printDebug "groupedMonoHead" (List.length groupedMonoHead)
-- printDebug "groupedMonoTail" (List.length groupedMonoHead)
-- printDebug "groupedMultHead" (List.length groupedMultHead)
-- printDebug "groupedMultTail" (List.length groupedMultTail)
{-
let
-- Get Local Scores now for selected grouped ngrams
-- TODO HasTerms
selectedTerms = Set.toList $ List.foldl'
(\set' (GroupedText _ l' _ g _ _ _ ) -> Set.union set'
$ Set.insert l' g
)
Set.empty
(groupedMonoHead <> groupedMultHead)
-}
selectedTerms = Set.toList $ hasTerms (groupedMonoHead <> groupedMultHead)
-- TO remove (and remove HasNodeError instance)
-- TO remove (and remove HasNodeError instance)
userListId <- defaultList uCid
masterListId <- defaultList mCid
......@@ -216,30 +179,11 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
nt
selectedTerms
-- TODO
let
groupedTreeScores_SetNodeId = setScoresWith mapTextDocIds (groupedMonoHead <> groupedMultHead)
{-
-- TODO remove
-- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
let
mapGroups = Map.fromList
$ map (\g -> (g ^. gt_stem, g))
$ groupedMonoHead <> groupedMultHead
-- grouping with Set NodeId
contextsAdded = foldl' (\mapGroups' k ->
let k' = groupWith groupParams k in
case Map.lookup k' mapGroups' of
Nothing -> mapGroups'
Just g -> case Map.lookup k mapTextDocIds of
Nothing -> mapGroups'
Just ns -> Map.insert k' (over gt_nodes (Set.union ns) g) mapGroups'
)
mapGroups
$ Map.keys mapTextDocIds
-}
groupedTreeScores_SetNodeId :: Map Text (GroupedTreeScores (Set NodeId))
groupedTreeScores_SetNodeId = undefined
-- setScoresWith (\_ _ -> mempty) (groupedMonoHead <> groupedMultHead)
-- groupedTreeScores_SetNodeId = setScoresWith ((fromMaybe mempty) . ((flip Map.lookup) mapTextDocIds)) (groupedMonoHead <> groupedMultHead)
-- | Coocurrences computation
--, t1 >= t2 -- permute byAxis diag -- since matrix symmetric
......@@ -255,43 +199,24 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
let
-- computing scores
mapScores f = Map.fromList
$ map (\s@(Scored t g s') -> (t, f s))
$ map (\g -> (view scored_terms g, f g))
$ normalizeGlobal
$ map normalizeLocal
$ scored' mapCooc
let
-- groupedTreeScores_SpeGen :: GroupedTreeScores (Scored Double)
groupedTreeScores_SpeGen = setScoresWith (mapScores identity) (groupedMonoHead <> groupedMultHead)
{-
-- TODO remove
-- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
groupsWithScores = catMaybes
$ map (\(stem, g)
-> case Map.lookup stem mapScores' of
Nothing -> Nothing
Just s' -> set gts'_score s' g
) $ Map.toList $ view flc_scores contextsAdded
where
mapScores' = mapScores identity
-- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
-- TODO remove
-}
-- adapt2 TOCHECK with DC
-- printDebug "groupsWithScores" groupsWithScores
-- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
-- TODO remove
--}
groupedTreeScores_SpeGen :: Map Text (GroupedTreeScores (Scored Double))
groupedTreeScores_SpeGen = undefined
-- setScoresWith (\k v -> set gts'_score (Scored "" 0 0) v) (groupedMonoHead <> groupedMultHead)
-- groupedTreeScores_SpeGen = setScoresWith (\k v -> set gts'_score (fromMaybe (Scored "" 0 0) $ Map.lookup k (mapScores identity)) v) (groupedMonoHead <> groupedMultHead)
let
-- sort / partition / split
-- filter mono/multi again
-- filter mono/multi again
(monoScored, multScored) = Map.partitionWithKey (\t _v -> size t < 2) groupedTreeScores_SpeGen
-- (monoScored, multScored) = List.partition (\g -> _gt_size g < 2) groupsWithScores
-- filter with max score
-- partitionWithMaxScore = List.partition (\g -> let (s1,s2) = viewScore g in s1 > s2 )
partitionWithMaxScore = Map.partition (\g -> (view scored_genInc $ view gts'_score g)
> (view scored_speExc $ view gts'_score g)
)
......@@ -299,25 +224,23 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
(monoScoredIncl, monoScoredExcl) = partitionWithMaxScore monoScored
(multScoredIncl, multScoredExcl) = partitionWithMaxScore multScored
-- splitAt
-- splitAt
let
listSizeLocal = 1000 :: Double -- use % of list if to big, or Int if to small
-- use % of list if to big, or Int if to small
listSizeLocal = 1000 :: Double
inclSize = 0.4 :: Double
exclSize = 1 - inclSize
--splitAt' n' = (both (Map.fromListWith (<>))) . (List.splitAt (round $ n' * listSizeLocal))
splitAt' n' = (both (Map.fromList)) . (List.splitAt (round $ n' * listSizeLocal))
sortOn f = (List.sortOn (Down . f . _gts'_score . snd)) . Map.toList
--sortOn f = (List.sortOn (Down . (gts'_score))) . Map.toList
-- sort = (List.sortOn (Down . viewScore))
sortOn f = (List.sortOn (Down . f . _gts'_score . snd)) . Map.toList
(monoScoredInclHead, monoScoredInclTail) = splitAt' (monoSize * inclSize / 2) $ (sortOn _scored_genInc) monoScoredIncl
(monoScoredExclHead, monoScoredExclTail) = splitAt' (monoSize * inclSize / 2) $ (sortOn _scored_speExc) monoScoredExcl
(multScoredInclHead, multScoredInclTail) = splitAt' (multSize * exclSize / 2) $ (sortOn _scored_genInc) multScoredIncl
(multScoredExclHead, multScoredExclTail) = splitAt' (multSize * exclSize / 2) $ (sortOn _scored_speExc) multScoredExcl
monoInc_size = monoSize * inclSize / 2
(monoScoredInclHead, monoScoredInclTail) = splitAt' monoInc_size $ (sortOn _scored_genInc) monoScoredIncl
(monoScoredExclHead, monoScoredExclTail) = splitAt' monoInc_size $ (sortOn _scored_speExc) monoScoredExcl
multExc_size = multSize * exclSize / 2
(multScoredInclHead, multScoredInclTail) = splitAt' multExc_size $ (sortOn _scored_genInc) multScoredIncl
(multScoredExclHead, multScoredExclTail) = splitAt' multExc_size $ (sortOn _scored_speExc) multScoredExcl
-- Final Step building the Typed list
termListHead = maps <> cands
......@@ -336,30 +259,13 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
termListTail = (setListType (Just CandidateTerm)) (groupedMonoTail <> groupedMultTail)
-- printDebug "monoScoredInclHead" monoScoredInclHead
-- printDebug "monoScoredExclHead" monoScoredExclTail
-- printDebug "multScoredInclHead" multScoredInclHead
-- printDebug "multScoredExclTail" multScoredExclTail
let result = Map.unionsWith (<>)
[ Map.fromList [( nt, toNgramsElement termListHead
<> toNgramsElement termListTail
<> toNgramsElement stopTerms
)]
]
-- printDebug "\n result \n" r
pure result
toGargList :: Maybe ListType -> b -> (Maybe ListType, b)
toGargList l n = (l,n)
isStopTerm :: StopSize -> Text -> Bool
isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
where
isStopChar c = not (c `elem` ("- /()%" :: [Char]) || Char.isAlpha c)
------------------------------------------------------------------------------
src/Gargantext/Core/Text/List/Group.hs
View file @ 4ea0d7f8
......@@ -18,7 +18,7 @@ Portability : POSIX
module Gargantext.Core.Text.List.Group
where
import Control.Lens (set, view)
import Control.Lens (set, view, over)
import Data.Set (Set)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
......@@ -52,30 +52,24 @@ toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
True -> flow1
False -> groupWithStem' groupParams flow1
setScoresWith :: Map Text a
-> Map Text (GroupedTreeScores b)
{-
DM.foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a
-}
setScoresWith :: (Ord a, Ord b)
=> (Text -> (GroupedTreeScores a) -> (GroupedTreeScores b))
-> Map Text (GroupedTreeScores a)
setScoresWith = undefined
-> Map Text (GroupedTreeScores b)
setScoresWith = Map.mapWithKey
{-
Map.foldlWithKey (\k v ->
{- over gts'_children (setScoresWith fun)
$ over gts'_score (fun k)
-}
set gts'_score Set.empty -- (fun k)
v
) mempty m
-}
------------------------------------------------------------------------
------------------------------------------------------------------------
-- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
-- | TODO To be removed
toGroupedText :: GroupedTextParams a b
-> Map Text FlowListScores
-> Map Text (Set NodeId)
-> Map Stem (GroupedText Int)
toGroupedText groupParams scores =
(groupWithStem groupParams) . (groupWithScores scores)
addListType :: Map Text ListType -> GroupedText a -> GroupedText a
addListType m g = set gt_listType (hasListType m g) g
where
hasListType :: Map Text ListType -> GroupedText a -> Maybe ListType
hasListType m' (GroupedText _ label _ g' _ _ _) =
List.foldl' (<>) Nothing
$ map (\t -> Map.lookup t m')
$ Set.toList
$ Set.insert label g'
src/Gargantext/Core/Text/List/Group/Prelude.hs
View file @ 4ea0d7f8
......@@ -32,6 +32,7 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.List as List
type Stem = Text
------------------------------------------------------------------------
-- | Main Types to group With Scores but preserving Tree dependencies
-- Therefore there is a need of Tree of GroupedTextScores
......@@ -162,108 +163,3 @@ instance ToNgramsElement (Text, GroupedTreeScores a) where
$ view gts'_children gts'
-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
-- TODO to remove below
data GroupedWithListScores =
GroupedWithListScores { _gwls_listType :: !(Maybe ListType)
, _gwls_children :: !(Set Text)
} deriving (Show)
instance Semigroup GroupedWithListScores where
(<>) (GroupedWithListScores c1 l1)
(GroupedWithListScores c2 l2) =
GroupedWithListScores (c1 <> c2)
(l1 <> l2)
instance Monoid GroupedWithListScores where
mempty = GroupedWithListScores Nothing Set.empty
makeLenses ''GroupedWithListScores
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Group With Stem Main Types
type Stem = Text
data GroupedText score =
GroupedText { _gt_listType :: !(Maybe ListType)
, _gt_label :: !Text
, _gt_score :: !score
, _gt_children :: !(Set Text)
, _gt_size :: !Int
, _gt_stem :: !Stem -- needed ?
, _gt_nodes :: !(Set NodeId)
} deriving (Show, Eq) --}
-- | Lenses Instances
makeLenses 'GroupedText
instance ViewListType (GroupedText a) where
viewListType = view gt_listType
instance SetListType (GroupedText a) where
setListType = set gt_listType
instance Ord a => ViewScore (GroupedText a) a where
viewScore = (view gt_score)
{-
instance Show score => Show (GroupedText score) where
show (GroupedText lt l s _ _ _ _) = show l <> " : " <> show lt <> " : " <> show s
--}
{-
instance (Eq a) => Eq (GroupedText a) where
(==) (GroupedText _ _ score1 _ _ _ _)
(GroupedText _ _ score2 _ _ _ _) = (==) score1 score2
-}
instance (Eq a, Ord a) => Ord (GroupedText a) where
compare (GroupedText _ _ score1 _ _ _ _)
(GroupedText _ _ score2 _ _ _ _) = compare score1 score2
instance Ord a => Semigroup (GroupedText a) where
(<>) (GroupedText lt1 label1 score1 group1 s1 stem1 nodes1)
(GroupedText lt2 label2 score2 group2 s2 stem2 nodes2)
| score1 >= score2 = GroupedText lt label1 score1 (Set.insert label2 gr) s1 stem1 nodes
| otherwise = GroupedText lt label2 score2 (Set.insert label1 gr) s2 stem2 nodes
where
lt = lt1 <> lt2
gr = Set.union group1 group2
nodes = Set.union nodes1 nodes2
instance SetListType [GroupedText Int] where
setListType lt = map (setListType lt)
instance ToNgramsElement (Map Stem (GroupedText Int)) where
toNgramsElement = List.concat . (map toNgramsElement) . Map.elems
instance ToNgramsElement [GroupedText a] where
toNgramsElement = List.concat . (map toNgramsElement)
instance ToNgramsElement (GroupedText a) where
toNgramsElement :: GroupedText a -> [NgramsElement]
toNgramsElement (GroupedText listType label _ setNgrams _ _ _) =
[parentElem] <> childrenElems
where
parent = label
children = Set.toList setNgrams
parentElem = mkNgramsElement (NgramsTerm parent)
(fromMaybe CandidateTerm listType)
Nothing
(mSetFromList (NgramsTerm <$> children))
childrenElems = map (\t -> mkNgramsElement t (fromMaybe CandidateTerm $ listType)
(Just $ RootParent (NgramsTerm parent) (NgramsTerm parent))
(mSetFromList [])
) (NgramsTerm <$> children)
-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
src/Gargantext/Core/Text/List/Group/WithScores.hs
View file @ 4ea0d7f8
......@@ -98,78 +98,4 @@ toGroupedTree' m notEmpty
--8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<--
-- TODO TO BE REMOVED
data GroupedTextScores score =
GroupedTextScores { _gts_listType :: !(Maybe ListType)
, _gts_score :: score
, _gts_children :: !(Set Text)
} deriving (Show)
makeLenses 'GroupedTextScores
instance Semigroup a => Semigroup (GroupedTextScores a) where
(<>) (GroupedTextScores l1 s1 c1)
(GroupedTextScores l2 s2 c2)
= GroupedTextScores (l1 <> l2)
(s1 <> s2)
(c1 <> c2)
-- | Main function
groupWithScores :: Map Text FlowListScores
-> Map Text (Set NodeId)
-> Map Text (GroupedTextScores (Set NodeId))
groupWithScores scores ms = orphans <> groups
where
groups = addScore ms
$ fromGroupedScores
$ fromListScores scores
orphans = addIfNotExist scores ms
------------------------------------------------------------------------
addScore :: Map Text (Set NodeId)
-> Map Text (GroupedTextScores (Set NodeId))
-> Map Text (GroupedTextScores (Set NodeId))
addScore mapNs = Map.mapWithKey scoring
where
scoring k g = set gts_score ( Set.unions
$ catMaybes
$ map (\n -> Map.lookup n mapNs)
$ [k] <> (Set.toList $ view gts_children g)
) g
addIfNotExist :: Map Text FlowListScores
-> Map Text (Set NodeId)
-> Map Text (GroupedTextScores (Set NodeId))
addIfNotExist mapSocialScores mapScores =
foldl' (addIfNotExist' mapSocialScores) mempty $ Map.toList mapScores
where
addIfNotExist' mss m (t,ns) =
case Map.lookup t mss of
Nothing -> Map.alter (add ns) t m
_ -> m
add ns' Nothing = Just $ GroupedTextScores Nothing ns' mempty
add _ _ = Nothing -- should not be present
------------------------------------------------------------------------
------------------------------------------------------------------------
fromGroupedScores :: Map Parent GroupedWithListScores
-> Map Parent (GroupedTextScores (Set NodeId))
fromGroupedScores = Map.map (\(GroupedWithListScores l c) -> GroupedTextScores l mempty c)
------------------------------------------------------------------------
fromListScores :: Map Text FlowListScores -> Map Parent GroupedWithListScores
fromListScores = Map.fromListWith (<>) . (map fromScores') . Map.toList
where
fromScores' :: (Text, FlowListScores) -> (Text, GroupedWithListScores)
fromScores' (t, fs) = case (keyWithMaxValue $ view fls_parents fs) of
Nothing -> (t, set gwls_listType (keyWithMaxValue $ view fls_listType fs) mempty)
-- Parent case: taking its listType, for now children Set is empty
Just parent -> (parent, set gwls_children (Set.singleton t) mempty)
-- We ignore the ListType of children for the parents' one
-- added after and winner of semigroup actions
--8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<-- -8<--
src/Gargantext/Core/Text/List/Group/WithStem.hs
View file @ 4ea0d7f8
......@@ -185,65 +185,3 @@ mergeWith_Double fun flc = FlowCont scores mempty
-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
-------------------------------------------------------------------
-- TODO to remove
data GroupedTextParams a b =
GroupedTextParams { _gt_fun_stem :: Text -> Text
, _gt_fun_score :: a -> b
, _gt_fun_texts :: a -> Set Text
, _gt_fun_nodeIds :: a -> Set NodeId
-- , _gt_fun_size :: a -> Int
}
makeLenses 'GroupedTextParams
groupWithStem :: {- ( HasNgrams a
, HasGroupWithScores a b
, Semigroup a
, Ord b
)
=> -} GroupedTextParams a b
-> Map Text (GroupedTextScores (Set NodeId))
-> Map Stem (GroupedText Int)
groupWithStem _ = Map.mapWithKey scores2groupedText
scores2groupedText :: Text -> GroupedTextScores (Set NodeId) -> GroupedText Int
scores2groupedText t g = GroupedText (view gts_listType g)
t
(Set.size $ view gts_score g)
(Set.delete t $ view gts_children g)
(size t)
t
(view gts_score g)
------------------------------------------------------------------------
------------------------------------------------------------------------
groupedTextWithStem :: Ord b
=> GroupedTextParams a b
-> Map Text a
-> Map Stem (GroupedText b)
groupedTextWithStem gparams from =
Map.fromListWith (<>) $ map (group gparams) $ Map.toList from
where
group gparams' (t,d) = let t' = (view gt_fun_stem gparams') t
in (t', GroupedText
Nothing
t
((view gt_fun_score gparams') d)
((view gt_fun_texts gparams') d)
(size t)
t'
((view gt_fun_nodeIds gparams') d)
)
------------------------------------------------------------------------
src/Gargantext/Core/Text/List/Social.hs
View file @ 4ea0d7f8
......@@ -98,84 +98,3 @@ flowSocialList' flowPriority user nt flc =
. toFlowListScores (keepAllParents nt'') flc''
---8<-TODO-REMOVE ALL BELOW--8<--8<-- 8<-- 8<--8<--8<--
-- | Choice depends on Ord instance of ListType
-- for now : data ListType = StopTerm | CandidateTerm | MapTerm
-- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
-- (we minimize errors on MapTerms if doubt)
-- * TODO what if equality ?
-- * TODO maybe use social groups too
toSocialList :: Map Text (Map ListType Int)
-> Set Text
-> Map (Maybe ListType) (Set Text)
toSocialList m = Map.fromListWith (<>)
. Set.toList
. Set.map (toSocialList1 m)
toSocialList1 :: Map Text (Map ListType Int)
-> Text
-> (Maybe ListType, Set Text)
toSocialList1 m t = case Map.lookup t m of
Nothing -> (Nothing, Set.singleton t)
Just m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
, Set.singleton t
)
toSocialList1_testIsTrue :: Bool
toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
where
result = toSocialList1 (Map.fromList [(token, m)]) token
token = "token"
m = Map.fromList [ (CandidateTerm, 1)
, (MapTerm , 2)
, (StopTerm , 3)
]
flowSocialList :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> User -> NgramsType -> Set Text
-> m (Map ListType (Set Text))
flowSocialList user nt ngrams' = do
-- Here preference to privateLists (discutable: let user choice)
privateListIds <- findListsId user Private
privateLists <- flowSocialListByMode privateListIds nt ngrams'
-- printDebug "* privateLists *: \n" privateLists
sharedListIds <- findListsId user Shared
sharedLists <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
-- printDebug "* sharedLists *: \n" sharedLists
-- TODO publicMapList:
-- Note: if both produce 3 identic repetition => refactor mode
-- publicListIds <- findListsId Public user
-- publicLists <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
let result = parentUnionsExcl
[ Map.mapKeys (fromMaybe CandidateTerm) privateLists
, Map.mapKeys (fromMaybe CandidateTerm) sharedLists
-- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
]
-- printDebug "* socialLists *: results \n" result
pure result
-- | TODO remove
flowSocialListByMode :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> [NodeId]-> NgramsType -> Set Text
-> m (Map (Maybe ListType) (Set Text))
flowSocialListByMode [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
flowSocialListByMode listIds nt ngrams' = do
counts <- countFilterList ngrams' nt listIds Map.empty
let r = toSocialList counts ngrams'
pure r
src/Gargantext/Core/Text/List/Social/Prelude.hs
View file @ 4ea0d7f8
......@@ -110,36 +110,3 @@ hasParent t m = case Map.lookup t m of
keyWithMaxValue :: Map a b -> Maybe a
keyWithMaxValue m = (fst . fst) <$> Map.maxViewWithKey m
------------------------------------------------------------------------
-- | Tools TODO clean it (some need to be removed)
------------------------------------------------------------------------
termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
termsByList CandidateTerm m = Set.unions
$ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
[ Nothing, Just CandidateTerm ]
termsByList l m =
fromMaybe Set.empty $ Map.lookup (Just l) m
------------------------------------------------------------------------
unions' :: (Ord a, Semigroup a, Semigroup b, Ord b)
=> [Map a (Set b)] -> Map a (Set b)
unions' = invertBack . Map.unionsWith (<>) . map invertForw
invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
invertForw = Map.unionsWith (<>)
. (map (\(k,st) -> Map.fromSet (\_ -> k) st))
. Map.toList
invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
invertBack = Map.fromListWith (<>)
. (map (\(b,a) -> (a, Set.singleton b)))
. Map.toList
unions_test :: Map ListType (Set Text)
unions_test = unions' [m1, m2]
where
m1 = Map.fromList [ (StopTerm , Set.singleton "Candidate")]
m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
, (MapTerm , Set.singleton "Candidate")
]
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment